Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/sml-mode/sml-proc.el
ViewVC logotype

Annotation of /sml/trunk/sml-mode/sml-proc.el

Parent Directory Parent Directory | Revision Log Revision Log


Revision 765 - (view) (download)

1 : monnier 535 ;;; sml-proc.el --- Comint based interaction mode for Standard ML.
2 : monnier 32
3 : monnier 541 ;; Copyright (C) 1989 Lars Bo Nielsen
4 :     ;; Copyright (C) 1994-1997 Matthew J. Morley
5 :     ;; Copyright (C) 1999-2000 Stefan Monnier
6 : monnier 32
7 :     ;; $Revision$
8 :     ;; $Date$
9 :    
10 :     ;; ====================================================================
11 :    
12 :     ;; This file is not part of GNU Emacs, but it is distributed under the
13 :     ;; same conditions.
14 :    
15 :     ;; This program is free software; you can redistribute it and/or
16 :     ;; modify it under the terms of the GNU General Public License as
17 :     ;; published by the Free Software Foundation; either version 2, or (at
18 :     ;; your option) any later version.
19 :    
20 :     ;; This program is distributed in the hope that it will be useful, but
21 :     ;; WITHOUT ANY WARRANTY; without even the implied warranty of
22 :     ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
23 :     ;; General Public License for more details.
24 :    
25 :     ;; You should have received a copy of the GNU General Public License
26 :     ;; along with GNU Emacs; see the file COPYING. If not, write to the
27 :     ;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 0139, USA.
28 :     ;; (See sml-mode.el for HISTORY.)
29 :    
30 :     ;; ====================================================================
31 :    
32 :     ;; [MJM 10/94] Separating this from sml-mode means sml-mode will run
33 :     ;; under 18.59 (or anywhere without comint, if there are such places).
34 :     ;; See sml-mode.el for further information.
35 :    
36 : monnier 535 ;;; Commentary:
37 : monnier 32
38 :     ;; Inferior-sml-mode is for interacting with an ML process run under
39 :     ;; emacs. This uses the comint package so you get history, expansion,
40 :     ;; backup and all the other benefits of comint. Interaction is
41 : monnier 394 ;; achieved by M-x run-sml which starts a sub-process under emacs. You may
42 : monnier 32 ;; need to set this up for autoloading in your .emacs:
43 :    
44 : monnier 394 ;; (autoload 'run-sml "sml-proc" "Run an inferior ML process." t)
45 : monnier 32
46 :     ;; Exactly what process is governed by the variable sml-program-name
47 :     ;; -- just "sml" by default. If you give a prefix argument (C-u M-x
48 : monnier 394 ;; run-sml) you will be prompted for a different program to execute from
49 : monnier 32 ;; the default -- if you just hit RETURN you get the default anyway --
50 :     ;; along with the option to specify any command line arguments. Once
51 :     ;; you select the ML program name in this manner, it remains the
52 :     ;; default (unless you set in a hook, or otherwise).
53 :    
54 :     ;; NOTE: inferior-sml-mode-hook is run AFTER the ML program has been
55 :     ;; launched. inferior-sml-load-hook is run only when sml-proc.el is
56 :     ;; loaded into Emacs.
57 :    
58 :     ;; When running an ML process some further key-bindings are effective
59 :     ;; in sml-mode buffer(s). C-c C-s (switch-to-sml) will split the
60 :     ;; screen into two windows if necessary and place you in the ML
61 :     ;; process buffer. In the interaction buffer, C-c C-s is bound to the
62 :     ;; `sml' command by default (in case you need to restart).
63 :    
64 :     ;; C-c C-l (sml-load-file) will load an SML source file into the
65 :     ;; inferior process, C-c C-r (sml-send-region) will send the current
66 :     ;; region of text to the ML process, etc. Given a prefix argument to
67 :     ;; these commands will switch you from the SML buffer to the ML
68 :     ;; process buffer as well as sending the text. If you get errors
69 : monnier 394 ;; reported by the compiler, C-x ` (next-error) will step through
70 : monnier 32 ;; the errors with you.
71 :    
72 :     ;; NOTE. There is only limited support for this as it obviously
73 :     ;; depends on the compiler's error messages being recognised by the
74 :     ;; mode. Error reporting is currently only geared up for SML/NJ,
75 : monnier 394 ;; Moscow ML, and Poly/ML. For other compilers, add the relevant
76 :     ;; regexp to sml-error-regexp-alist and send it to me.
77 : monnier 32
78 : monnier 394 ;; To send pieces of code to the underlying compiler, we never send the text
79 :     ;; directly but use a temporary file instead. This breaks if the compiler
80 :     ;; does not understand `use', but has the benefit of allowing better error
81 :     ;; reporting.
82 : monnier 32
83 : monnier 535 ;; Bugs:
84 : monnier 32
85 : monnier 535 ;; Todo:
86 : monnier 32
87 : monnier 535 ;; - Keep improving `sml-compile'.
88 :     ;; - ignore warnings (if requested) for next-error
89 :    
90 :     ;;; Code:
91 :    
92 : monnier 541 (eval-when-compile (require 'cl))
93 : monnier 32 (require 'sml-mode)
94 : monnier 332 (require 'sml-util)
95 : monnier 32 (require 'comint)
96 : monnier 332 (require 'compile)
97 : monnier 32
98 : monnier 394 (defgroup sml-proc ()
99 :     "Interacting with an SML process."
100 :     :group 'sml)
101 : monnier 32
102 : monnier 394 (defcustom sml-program-name "sml"
103 :     "*Program to run as ML."
104 :     :group 'sml-proc
105 :     :type '(string))
106 : monnier 32
107 : monnier 394 (defcustom sml-default-arg ""
108 :     "*Default command line option to pass, if any."
109 :     :group 'sml-proc
110 :     :type '(string))
111 :    
112 : monnier 535 (defcustom sml-host-name ""
113 :     "*Host on which to run ML."
114 :     :group 'sml-proc
115 :     :type '(string))
116 : monnier 32
117 : monnier 535 (defcustom sml-config-file "~/.smlproc.sml"
118 :     "*File that should be fed to the ML process when started."
119 :     :group 'sml-proc
120 :     :type '(string))
121 : monnier 32
122 : monnier 535 (defcustom sml-compile-command "CM.make()"
123 :     "The command used by default by `sml-compile'.
124 :     See also `sml-compile-commands-alist'.")
125 : monnier 32
126 : monnier 535 (defcustom sml-compile-commands-alist
127 :     '(("CMB.make()" . "all-files.cm")
128 :     ("CMB.make()" . "pathconfig")
129 :     ("CM.make()" . "sources.cm")
130 :     ("use \"load-all\"" . "load-all"))
131 :     "*Commands used by default by `sml-compile'.
132 :     Each command is associated with its \"main\" file.
133 :     It is perfectly OK to associate several files with a command or several
134 :     commands with the same file.")
135 :    
136 : monnier 32 (defvar inferior-sml-mode-hook nil
137 :     "*This hook is run when the inferior ML process is started.
138 :     All buffer local customisations for the interaction buffers go here.")
139 :    
140 : monnier 332 (defvar sml-error-overlay nil
141 :     "*Non-nil means use an overlay to highlight errorful code in the buffer.
142 :     The actual value is the name of a face to use for the overlay.
143 :     Instead of setting this variable to 'region, you can also simply keep
144 :     it NIL and use (transient-mark-mode) which will provide similar
145 :     benefits (but with several side effects).")
146 :    
147 : monnier 32 (defvar sml-buffer nil
148 :     "*The current ML process buffer.
149 :    
150 :     MULTIPLE PROCESS SUPPORT (Whoever wants multi-process support anyway?)
151 :     =====================================================================
152 : monnier 535 `sml-mode' supports, in a fairly simple fashion, running multiple ML
153 :     processes. To run multiple ML processes, you start the first up with
154 :     \\[sml]. It will be in a buffer named *sml*. Rename this buffer with
155 :     \\[rename-buffer]. You may now start up a new process with another
156 :     \\[sml]. It will be in a new buffer, named *sml*. You can switch
157 : monnier 32 between the different process buffers with \\[switch-to-buffer].
158 :    
159 : monnier 535 NB *sml* is just the default name for the buffer. It actually gets
160 : monnier 32 it's name from the value of `sml-program-name' -- *poly*, *smld*,...
161 :    
162 :     If you have more than one ML process around, commands that send text
163 :     from source buffers to ML processes -- like `sml-send-function' or
164 : monnier 535 `sml-send-region' -- have to choose a process to send it to. This is
165 :     determined by the global variable `sml-buffer'. Suppose you have three
166 : monnier 32 inferior ML's running:
167 :     Buffer Process
168 :     sml #<process sml>
169 :     mosml #<process mosml>
170 :     *sml* #<process sml<2>>
171 :     If you do a \\[sml-send-function] command on some ML source code,
172 :     what process do you send it to?
173 :    
174 :     - If you're in a process buffer (sml, mosml, or *sml*), you send it to
175 :     that process (usually makes sense only to `sml-load-file').
176 :     - If you're in some other buffer (e.g., a source file), you send it to
177 :     the process attached to buffer `sml-buffer'.
178 :    
179 :     This process selection is performed by function `sml-proc' which looks
180 : monnier 535 at the value of `sml-buffer' -- which must be a Lisp buffer object, or
181 : monnier 32 a string \(or nil\).
182 :    
183 :     Whenever \\[sml] fires up a new process, it resets `sml-buffer' to be
184 : monnier 535 the new process's buffer. If you only run one process, this will do
185 :     the right thing. If you run multiple processes, you can change
186 : monnier 32 `sml-buffer' to another process buffer with \\[set-variable], or
187 :     use the command \\[sml-buffer] in the interaction buffer of choice.")
188 :    
189 :    
190 :     ;;; ALL STUFF THAT DEFAULTS TO THE SML/NJ COMPILER (0.93)
191 :    
192 :     (defvar sml-use-command "use \"%s\""
193 :     "*Template for loading a file into the inferior ML process.
194 :     Set to \"use \\\"%s\\\"\" for SML/NJ or Edinburgh ML;
195 :     set to \"PolyML.use \\\"%s\\\"\" for Poly/ML, etc.")
196 :    
197 : monnier 33 (defvar sml-cd-command "OS.FileSys.chDir \"%s\""
198 : monnier 32 "*Command template for changing working directories under ML.
199 :     Set this to nil if your compiler can't change directories.
200 :    
201 :     The format specifier \"%s\" will be converted into the directory name
202 :     specified when running the command \\[sml-cd].")
203 :    
204 : monnier 394 (defcustom sml-prompt-regexp "^[-=>#] *"
205 :     "*Regexp used to recognise prompts in the inferior ML process."
206 :     :group 'sml-proc
207 :     :type '(regexp))
208 : monnier 32
209 : monnier 395 (defvar sml-error-regexp-alist
210 : monnier 332 '(;; Poly/ML messages
211 :     ("\\(Error\\|Warning:\\) in '\\(.+\\)', line \\([0-9]+\\)" 2 3)
212 :     ;; Moscow ML
213 :     ("File \"\\([^\"]+\\)\", line \\([0-9]+\\)\\(-\\([0-9]+\\)\\)?, characters \\([0-9]+\\)-\\([0-9]+\\):" 1 2 5)
214 : monnier 378 ;; SML/NJ: the file-pattern is anchored to avoid
215 : monnier 342 ;; pathological behavior with very long lines.
216 : monnier 378 ("^[-= ]*\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warning\\): .*" 1 sml-make-error 2 3 5 6)
217 : monnier 342 ;; SML/NJ's exceptions: see above.
218 : monnier 395 ("^ +\\(raised at: \\)?\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2 sml-make-error 3 4 6 7))
219 :     "Alist that specifies how to match errors in compiler output.
220 :     See `compilation-error-regexp-alist' for a description of the format.")
221 : monnier 32
222 : monnier 33 ;; font-lock support
223 : monnier 332 (defconst inferior-sml-font-lock-keywords
224 :     `(;; prompt and following interactive command
225 :     (,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
226 : monnier 33 (1 font-lock-prompt-face)
227 :     (2 font-lock-command-face keep))
228 : monnier 332 ;; CM's messages
229 : monnier 39 ("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face)
230 : monnier 332 ;; SML/NJ's irritating GC messages
231 :     ("^GC #.*" . font-lock-comment-face)
232 :     ;; error messages
233 :     ,@(mapcar (lambda (ra) (cons (car ra) 'font-lock-warning-face))
234 :     sml-error-regexp-alist))
235 :     "Font-locking specification for inferior SML mode.")
236 : monnier 33
237 : monnier 394 (defface font-lock-prompt-face
238 :     '((t (:bold t)))
239 :     "Font Lock mode face used to highlight prompts."
240 :     :group 'font-lock-highlighting-faces)
241 :     (defvar font-lock-prompt-face 'font-lock-prompt-face
242 :     "Face name to use for prompts.")
243 : monnier 33
244 : monnier 394 (defface font-lock-command-face
245 :     '((t (:bold t)))
246 :     "Font Lock mode face used to highlight interactive commands."
247 :     :group 'font-lock-highlighting-faces)
248 :     (defvar font-lock-command-face 'font-lock-command-face
249 :     "Face name to use for interactive commands.")
250 :    
251 :     (defconst inferior-sml-font-lock-defaults
252 : monnier 33 '(inferior-sml-font-lock-keywords nil nil nil nil))
253 :    
254 : monnier 535
255 : monnier 32 ;;; CODE
256 :    
257 : monnier 319 (defmap inferior-sml-mode-map
258 :     '(("\C-c\C-s" . run-sml)
259 : monnier 700 ("\C-c\C-l" . sml-load-file)
260 : monnier 319 ("\t" . comint-dynamic-complete))
261 :     "Keymap for inferior-sml mode"
262 : monnier 700 :inherit comint-mode-map
263 : monnier 394 :group 'sml-proc)
264 : monnier 32
265 : monnier 319
266 : monnier 32 ;; buffer-local
267 :    
268 : monnier 332 (defvar sml-temp-file nil)
269 : monnier 378 ;;(defvar sml-error-file nil) ; file from which the last error came
270 : monnier 32 (defvar sml-error-cursor nil) ; ditto
271 :    
272 :     (defun sml-proc-buffer ()
273 : monnier 535 "Return the current ML process buffer.
274 :     or the current buffer if it is in `inferior-sml-mode'. Raises an error
275 : monnier 32 if the variable `sml-buffer' does not appear to point to an existing
276 :     buffer."
277 : monnier 332 (or (and (eq major-mode 'inferior-sml-mode) (current-buffer))
278 :     (and sml-buffer
279 :     (let ((buf (get-buffer sml-buffer)))
280 :     ;; buffer-name returns nil if the buffer has been killed
281 :     (and buf (buffer-name buf) buf)))
282 :     ;; no buffer found, make a new one
283 : monnier 535 (call-interactively 'run-sml)))
284 : monnier 32
285 :     (defun sml-buffer (echo)
286 :     "Make the current buffer the current `sml-buffer' if that is sensible.
287 : monnier 535 Lookup variable `sml-buffer' to see why this might be useful.
288 :     If prefix argument ECHO is set, then it only reports on the current state."
289 : monnier 32 (interactive "P")
290 : monnier 535 (when (not echo)
291 :     (setq sml-buffer
292 :     (if (eq major-mode 'inferior-sml-mode) (current-buffer)
293 :     (read-buffer "Set ML process buffer to: " nil t))))
294 :     (message "ML process buffer is now %s."
295 : monnier 332 (or (ignore-errors (buffer-name (get-buffer sml-buffer)))
296 :     "undefined")))
297 : monnier 32
298 : monnier 535 (defun sml-proc ()
299 :     "Return the current ML process. See variable `sml-buffer'."
300 :     (assert (eq major-mode 'inferior-sml-mode))
301 :     (or (get-buffer-process (current-buffer))
302 :     (progn (call-interactively 'run-sml)
303 :     (get-buffer-process (current-buffer)))))
304 :    
305 :     (define-derived-mode inferior-sml-mode comint-mode "Inferior-SML"
306 : monnier 32 "Major mode for interacting with an inferior ML process.
307 :    
308 :     The following commands are available:
309 :     \\{inferior-sml-mode-map}
310 :    
311 :     An ML process can be fired up (again) with \\[sml].
312 :    
313 :     Customisation: Entry to this mode runs the hooks on `comint-mode-hook'
314 :     and `inferior-sml-mode-hook' (in that order).
315 :    
316 :     Variables controlling behaviour of this mode are
317 :    
318 :     `sml-program-name' (default \"sml\")
319 :     Program to run as ML.
320 :    
321 :     `sml-use-command' (default \"use \\\"%s\\\"\")
322 :     Template for loading a file into the inferior ML process.
323 :    
324 :     `sml-cd-command' (default \"System.Directory.cd \\\"%s\\\"\")
325 :     ML command for changing directories in ML process (if possible).
326 :    
327 :     `sml-prompt-regexp' (default \"^[\\-=] *\")
328 :     Regexp used to recognise prompts in the inferior ML process.
329 :    
330 :     You can send text to the inferior ML process from other buffers containing
331 : monnier 535 ML source.
332 : monnier 32 `switch-to-sml' switches the current buffer to the ML process buffer.
333 :     `sml-send-function' sends the current *paragraph* to the ML process.
334 :     `sml-send-region' sends the current region to the ML process.
335 :    
336 :     Prefixing the sml-send-<whatever> commands with \\[universal-argument]
337 :     causes a switch to the ML process buffer after sending the text.
338 :    
339 :     For information on running multiple processes in multiple buffers, see
340 :     documentation for variable `sml-buffer'.
341 :    
342 :     Commands:
343 : monnier 535 RET after the end of the process' output sends the text from the
344 : monnier 32 end of process to point.
345 :     RET before the end of the process' output copies the current line
346 :     to the end of the process' output, and sends it.
347 :     DEL converts tabs to spaces as it moves back.
348 :     TAB file name completion, as in shell-mode, etc.."
349 :     (setq comint-prompt-regexp sml-prompt-regexp)
350 :     (sml-mode-variables)
351 :    
352 : monnier 700 (set (make-local-variable 'font-lock-defaults)
353 :     inferior-sml-font-lock-defaults)
354 : monnier 32 ;; For sequencing through error messages:
355 : monnier 300 (set (make-local-variable 'sml-error-cursor) (point-max-marker))
356 : monnier 332 (set-marker-insertion-type sml-error-cursor nil)
357 : monnier 32
358 : monnier 765 ;; Compilation support (used for `next-error').
359 :     ;; The keymap of compilation-minor-mode is too unbearable, so we
360 :     ;; just can't use the minor-mode if we can't override the map.
361 :     (when (boundp 'minor-mode-overriding-map-alist)
362 :     (set (make-local-variable 'compilation-error-regexp-alist)
363 :     sml-error-regexp-alist)
364 :     (compilation-minor-mode 1)
365 :     ;; Eliminate compilation-minor-mode's map.
366 :     (add-to-list 'minor-mode-overriding-map-alist
367 :     (cons 'compilation-minor-mode (make-sparse-keymap)))
368 :     ;; I'm sure people might kill me for that
369 :     (setq compilation-error-screen-columns nil)
370 :     (make-local-variable 'sml-endof-error-alist))
371 :     ;;(make-local-variable 'sml-error-overlay)
372 : monnier 32
373 : monnier 535 (setq mode-line-process '(": %s")))
374 : monnier 32
375 :     ;;; FOR RUNNING ML FROM EMACS
376 :    
377 : monnier 33 ;;;###autoload
378 : monnier 535 (autoload 'run-sml "sml-proc" nil t)
379 :     (defalias 'run-sml 'sml-run)
380 :     (defun sml-run (cmd arg &optional host)
381 :     "Run the program CMD with given arguments ARG.
382 :     The command is run in buffer *CMD* using mode `inferior-sml-mode'.
383 :     If the buffer already exists and has a running process, then
384 :     just go to this buffer.
385 : monnier 32
386 : monnier 535 This updates `sml-buffer' to the new buffer.
387 :     You can have several inferior M(or L process running, but only one (> s
388 : monnier 32 current one -- given by `sml-buffer' (qv).
389 :    
390 : monnier 535 If a prefix argument is used, the user is also prompted for a HOST
391 :     on which to run CMD using `remote-shell-program'.
392 :    
393 : monnier 32 \(Type \\[describe-mode] in the process buffer for a list of commands.)"
394 : monnier 535 (interactive
395 :     (list
396 :     (read-string "ML command: " sml-program-name)
397 :     (if (or current-prefix-arg (> (length sml-default-arg) 0))
398 :     (read-string "Any args: " sml-default-arg)
399 :     sml-default-arg)
400 :     (if (or current-prefix-arg (> (length sml-host-name) 0))
401 :     (read-string "On host: " sml-host-name)
402 :     sml-host-name)))
403 : monnier 32 (let* ((pname (file-name-nondirectory cmd))
404 : monnier 535 (args (if (equal arg "") () (split-string arg)))
405 :     (file (when (and sml-config-file (file-exists-p sml-config-file))
406 :     sml-config-file)))
407 : monnier 332 ;; and this -- to keep these as defaults even if
408 :     ;; they're set in the mode hooks.
409 :     (setq sml-program-name cmd)
410 :     (setq sml-default-arg arg)
411 : monnier 535 (setq sml-host-name host)
412 :     ;; For remote execution, use `remote-shell-program'
413 :     (when (> (length host) 0)
414 :     (setq args (list* host "cd" default-directory ";" cmd args))
415 :     (setq cmd remote-shell-program))
416 :     ;; go for it
417 : monnier 700 (let ((exec-path (if (file-name-directory cmd)
418 :     ;; If the command has slashes, make sure we
419 :     ;; first look relative to the current directory.
420 :     ;; Emacs-21 does it for us, but not Emacs-20.
421 :     (cons default-directory exec-path) exec-path)))
422 :     (setq sml-buffer (apply 'make-comint pname cmd file args)))
423 : monnier 32
424 : monnier 535 (pop-to-buffer sml-buffer)
425 :     ;;(message (format "Starting \"%s\" in background." pname))
426 : monnier 332 (inferior-sml-mode)
427 :     (goto-char (point-max))
428 :     sml-buffer))
429 :    
430 : monnier 535 (defun switch-to-sml (eobp)
431 : monnier 32 "Switch to the ML process buffer.
432 : monnier 535 Move point to the end of buffer unless prefix argument EOBP is set."
433 : monnier 32 (interactive "P")
434 : monnier 33 (pop-to-buffer (sml-proc-buffer))
435 : monnier 535 (unless eobp
436 :     (push-mark (point) t)
437 :     (goto-char (point-max))))
438 : monnier 32
439 :     ;; Fakes it with a "use <temp-file>;" if necessary.
440 :    
441 :     (defun sml-send-region (start end &optional and-go)
442 : monnier 535 "Send current region START..END to the inferior ML process.
443 :     Prefix AND-GO argument means switch-to-sml afterwards.
444 : monnier 32
445 : monnier 332 The region is written out to a temporary file and a \"use <temp-file>\" command
446 :     is sent to the compiler.
447 :     See variables `sml-use-command'."
448 : monnier 32 (interactive "r\nP")
449 : monnier 332 (if (= start end)
450 :     (message "The region is zero (ignored)")
451 :     (let* ((buf (sml-proc-buffer))
452 :     (file (buffer-file-name))
453 :     (marker (copy-marker start))
454 :     (tmp (make-temp-file "sml")))
455 :     (write-region start end tmp nil 'silently)
456 :     (with-current-buffer buf
457 :     (when sml-temp-file
458 :     (ignore-errors (delete-file (car sml-temp-file)))
459 :     (set-marker (cdr sml-temp-file) nil))
460 :     (setq sml-temp-file (cons tmp marker))
461 :     (sml-send-string (format sml-use-command tmp) nil and-go)))))
462 : monnier 32
463 :     ;; This is quite bogus, so it isn't bound to a key by default.
464 :     ;; Anyone coming up with an algorithm to recognise fun & local
465 :     ;; declarations surrounding point will do everyone a favour!
466 :    
467 :     (defun sml-send-function (&optional and-go)
468 :     "Send current paragraph to the inferior ML process.
469 : monnier 535 With a prefix argument AND-GO switch to the sml buffer as well
470 : monnier 32 \(cf. `sml-send-region'\)."
471 :     (interactive "P")
472 :     (save-excursion
473 :     (sml-mark-function)
474 :     (sml-send-region (point) (mark)))
475 :     (if and-go (switch-to-sml nil)))
476 :    
477 : monnier 332 (defvar sml-source-modes '(sml-mode)
478 :     "*Used to determine if a buffer contains ML source code.
479 : monnier 319 If it's loaded into a buffer that is in one of these major modes, it's
480 : monnier 535 considered an ML source file by `sml-load-file'. Used by these commands
481 : monnier 319 to determine defaults.")
482 :    
483 : monnier 32 (defun sml-send-buffer (&optional and-go)
484 :     "Send buffer to inferior shell running ML process.
485 : monnier 535 With a prefix argument AND-GO switch to the sml buffer as well
486 : monnier 32 \(cf. `sml-send-region'\)."
487 :     (interactive "P")
488 :     (if (memq major-mode sml-source-modes)
489 :     (sml-send-region (point-min) (point-max) and-go)))
490 :    
491 :     ;; Since sml-send-function/region take an optional prefix arg, these
492 :     ;; commands are redundant. But they are kept around for the user to
493 :     ;; bind if she wishes, since its easier to type C-c r than C-u C-c C-r.
494 :    
495 :     (defun sml-send-region-and-go (start end)
496 : monnier 535 "Send current region START..END to the inferior ML process, and go there."
497 : monnier 32 (interactive "r")
498 :     (sml-send-region start end t))
499 :    
500 :     (defun sml-send-function-and-go ()
501 :     "Send current paragraph to the inferior ML process, and go there."
502 :     (interactive)
503 :     (sml-send-function t))
504 :    
505 :     ;;; H A C K A T T A C K ! X E M A C S V E R S U S E M A C S
506 :    
507 :     (defun sml-drag-region (event)
508 :     "Highlight the text the mouse is dragged over, and send it to ML.
509 : monnier 535 This must be bound to a button-down mouse EVENT, currently \\[sml-drag-region].
510 : monnier 32
511 :     If you drag the mouse (ie, keep the mouse button depressed) the
512 :     program text sent to the complier is delimited by where you started
513 :     dragging the mouse, and where you release the mouse button.
514 :    
515 :     If you only click the mouse, the program text sent to the compiler is
516 :     delimited by the current position of point and the place where you
517 :     click the mouse.
518 :    
519 :     In either event, the values of both point and mark are left
520 :     undisturbed once this operation is completed."
521 :     (interactive "e")
522 :     (let ((mark-ring) ;BAD: selection start gets cons'd
523 :     (pmark (point))) ;where point is now
524 :     (if (fboundp 'mouse-track-default)
525 :     ;; Assume this is XEmacs, otherwise assume its Emacs
526 :     (save-excursion
527 :     (let ((zmacs-regions))
528 :     (set-marker (mark-marker) nil)
529 :     (mouse-track-default event)
530 :     (if (not (region-exists-p)) (push-mark pmark nil t))
531 :     (call-interactively 'sml-send-region)))
532 :     ;; Emacs: making this buffer-local ought to happen in sml-mode
533 :     (make-local-variable 'transient-mark-mode)
534 :     (save-excursion
535 :     (let ((transient-mark-mode 1))
536 :     (mouse-drag-region event)
537 :     (if (not mark-active) (push-mark pmark nil t))
538 :     (call-interactively 'sml-send-region))))))
539 :    
540 :    
541 :     ;;; LOADING AND IMPORTING SOURCE FILES:
542 :    
543 : monnier 332 (defvar sml-prev-dir/file nil
544 : monnier 535 "Cache for (DIRECTORY . FILE) pair last.
545 :     Set in `sml-load-file' and `sml-cd' commands.
546 :     Used to determine the default in the next `ml-load-file'.")
547 : monnier 32
548 :     (defun sml-load-file (&optional and-go)
549 :     "Load an ML file into the current inferior ML process.
550 : monnier 535 With a prefix argument AND-GO switch to sml buffer as well.
551 : monnier 32
552 :     This command uses the ML command template `sml-use-command' to construct
553 :     the command to send to the ML process\; a trailing \"\;\\n\" will be added
554 :     automatically."
555 :     (interactive "P")
556 : monnier 332 (let ((file (car (comint-get-source
557 :     "Load ML file: " sml-prev-dir/file sml-source-modes t))))
558 :     (with-current-buffer (sml-proc-buffer)
559 :     ;; Check if buffer needs saved. Should (save-some-buffers) instead?
560 :     (comint-check-source file)
561 :     (setq sml-prev-dir/file
562 :     (cons (file-name-directory file) (file-name-nondirectory file)))
563 :     (sml-send-string (format sml-use-command file) nil and-go))))
564 : monnier 32
565 :     (defun sml-cd (dir)
566 :     "Change the working directory of the inferior ML process.
567 : monnier 535 The default directory of the process buffer is changed to DIR. If the
568 : monnier 32 variable `sml-cd-command' is non-nil it should be an ML command that will
569 :     be executed to change the compiler's working directory\; a trailing
570 :     \"\;\\n\" will be added automatically."
571 :     (interactive "DSML Directory: ")
572 : monnier 332 (let ((dir (expand-file-name dir)))
573 :     (with-current-buffer (sml-proc-buffer)
574 :     (sml-send-string (format sml-cd-command dir) t)
575 :     (setq default-directory dir))
576 :     (setq sml-prev-dir/file (cons dir nil))))
577 : monnier 32
578 : monnier 332 (defun sml-send-string (str &optional print and-go)
579 :     (let ((proc (sml-proc))
580 :     (str (concat str ";\n"))
581 :     (win (get-buffer-window (current-buffer) 'visible)))
582 :     (when win (select-window win))
583 :     (goto-char (point-max))
584 :     (when print (insert str))
585 :     (sml-update-cursor)
586 :     (set-marker (process-mark proc) (point-max))
587 :     (setq compilation-last-buffer (current-buffer))
588 :     (comint-send-string proc str)
589 :     (when and-go (switch-to-sml nil))))
590 : monnier 32
591 : monnier 332 (defun sml-compile (command)
592 : monnier 535 "Pass a COMMAND to the SML process to compile the current program.
593 :    
594 :     You can then use the command \\[next-error] to find the next error message
595 :     and move to the source code that caused it.
596 :    
597 :     Interactively, prompts for the command if `compilation-read-command' is
598 :     non-nil. With prefix arg, always prompts."
599 : monnier 33 (interactive
600 : monnier 535 (let* ((dir default-directory)
601 :     (cmd "cd \"."))
602 :     ;; look for files to determine the default command
603 :     (while (and (stringp dir)
604 :     (dolist (cf sml-compile-commands-alist 1)
605 :     (when (file-exists-p (expand-file-name (cdr cf) dir))
606 :     (setq cmd (concat cmd "\"; " (car cf))) (return nil))))
607 :     (let ((newdir (file-name-directory (directory-file-name dir))))
608 :     (setq dir (unless (equal newdir dir) newdir))
609 :     (setq cmd (concat cmd "/.."))))
610 :     (setq cmd
611 :     (cond
612 :     ((local-variable-p 'sml-compile-command) sml-compile-command)
613 :     ((string-match "^\\s-*cd\\s-+\"\\.\"\\s-*;\\s-*" cmd)
614 :     (substring cmd (match-end 0)))
615 :     ((string-match "^\\s-*cd\\s-+\"\\(\\./\\)" cmd)
616 :     (replace-match "" t t cmd 1))
617 :     ((string-match ";" cmd) cmd)
618 :     (t sml-compile-command)))
619 :     ;; code taken from compile.el
620 :     (if (or compilation-read-command current-prefix-arg)
621 :     (list (read-from-minibuffer "Compile command: "
622 :     cmd nil nil '(compile-history . 1)))
623 :     (list cmd))))
624 :     ;; ;; now look for command's file to determine the directory
625 :     ;; (setq dir default-directory)
626 :     ;; (while (and (stringp dir)
627 :     ;; (dolist (cf sml-compile-commands-alist t)
628 :     ;; (when (and (equal cmd (car cf))
629 :     ;; (file-exists-p (expand-file-name (cdr cf) dir)))
630 :     ;; (return nil))))
631 :     ;; (let ((newdir (file-name-directory (directory-file-name dir))))
632 :     ;; (setq dir (unless (equal newdir dir) newdir))))
633 :     ;; (setq dir (or dir default-directory))
634 :     ;; (list cmd dir)))
635 :     (set (make-local-variable 'sml-compile-command) command)
636 : monnier 332 (save-some-buffers (not compilation-ask-about-save) nil)
637 : monnier 535 (let ((dir default-directory))
638 :     (when (string-match "^\\s-*cd\\s-+\"\\([^\"]+\\)\"\\s-*;" command)
639 : blume 566 (setq dir (match-string 1 command))
640 : monnier 535 (setq command (replace-match "" t t command)))
641 : blume 566 (setq dir (expand-file-name dir))
642 : monnier 332 (with-current-buffer (sml-proc-buffer)
643 :     (setq default-directory dir)
644 :     (sml-send-string (concat (format sml-cd-command dir) "; " command) t t))))
645 : monnier 32
646 : monnier 33 ;;; PARSING ERROR MESSAGES
647 : monnier 32
648 :     ;; This should need no modification to support other compilers.
649 :    
650 : monnier 332 ;; Update the buffer-local error-cursor in proc-buffer to be its
651 :     ;; current proc mark.
652 : monnier 32
653 : monnier 332 (defvar sml-endof-error-alist nil)
654 : monnier 32
655 : monnier 332 (defun sml-update-cursor ()
656 :     ;; update buffer local variable
657 :     (set-marker sml-error-cursor (1- (process-mark (sml-proc))))
658 :     (setq sml-endof-error-alist nil)
659 :     (compilation-forget-errors)
660 : monnier 378 (if (markerp compilation-parsing-end)
661 :     (set-marker compilation-parsing-end sml-error-cursor)
662 :     (setq compilation-parsing-end sml-error-cursor)))
663 : monnier 32
664 : monnier 332 (defun sml-make-error (f c)
665 :     (let ((err (point-marker))
666 :     (linenum (string-to-number c))
667 :     (filename (list (first f) (second f)))
668 :     (column (string-to-number (compile-buffer-substring (third f)))))
669 :     ;; record the end of error, if any
670 :     (when (fourth f)
671 : monnier 535 (let ((endlinestr (compile-buffer-substring (fourth f))))
672 :     (when endlinestr
673 :     (let* ((endline (string-to-number endlinestr))
674 :     (endcol (string-to-number
675 :     (or (compile-buffer-substring (fifth f)) "0")))
676 :     (linediff (- endline linenum)))
677 :     (push (list err linediff (if (= 0 linediff) (- endcol column) endcol))
678 :     sml-endof-error-alist)))))
679 : monnier 332 ;; build the error descriptor
680 :     (if (string= (car sml-temp-file) (first f))
681 :     ;; special case for code sent via sml-send-region
682 :     (let ((marker (cdr sml-temp-file)))
683 :     (with-current-buffer (marker-buffer marker)
684 :     (goto-char marker)
685 :     (forward-line (1- linenum))
686 :     (forward-char (1- column))
687 :     (cons err (point-marker))))
688 :     ;; taken from compile.el
689 :     (list err filename linenum column))))
690 : monnier 32
691 : monnier 332 (defadvice compilation-goto-locus (after sml-endof-error activate)
692 :     (let* ((next-error (ad-get-arg 0))
693 :     (err (car next-error))
694 :     (pos (cdr next-error))
695 :     (endof (with-current-buffer (marker-buffer err)
696 :     (assq err sml-endof-error-alist))))
697 :     (if (not endof) (sml-error-overlay 'undo)
698 :     (with-current-buffer (marker-buffer pos)
699 :     (goto-char pos)
700 :     (let ((linediff (second endof))
701 :     (coldiff (third endof)))
702 :     (when (> 0 linediff) (forward-line linediff))
703 :     (forward-char coldiff))
704 :     (sml-error-overlay nil pos (point))
705 :     (push-mark nil t (not sml-error-overlay))
706 :     (goto-char pos)))))
707 : monnier 32
708 : monnier 332 (defun sml-error-overlay (undo &optional beg end)
709 : monnier 535 "Move `sml-error-overlay' to the text region in the current buffer.
710 :     If the buffer-local variable `sml-error-overlay' is
711 : monnier 332 non-nil it should be an overlay \(or extent, in XEmacs speak\)\; this
712 :     function moves the overlay over the current region. If the optional
713 :     BUFFER argument is given, move the overlay in that buffer instead of
714 :     the current buffer.
715 :    
716 :     Called interactively, the optional prefix argument UNDO indicates that
717 :     the overlay should simply be removed: \\[universal-argument] \
718 :     \\[sml-error-overlay]."
719 : monnier 32 (interactive "P")
720 : monnier 332 (when sml-error-overlay
721 :     (unless (overlayp sml-error-overlay)
722 :     (let ((ol sml-error-overlay))
723 :     (setq sml-error-overlay (make-overlay 0 0))
724 :     (overlay-put sml-error-overlay 'face (if (symbolp ol) ol 'region))))
725 : monnier 394 (if undo (move-overlay sml-error-overlay 1 1 (current-buffer))
726 : monnier 332 ;; if active regions, signals mark not active if no region set
727 :     (let ((beg (or beg (region-beginning)))
728 :     (end (or end (region-end))))
729 :     (move-overlay sml-error-overlay beg end (current-buffer))))))
730 : monnier 32
731 :     ;;; H A C K A T T A C K ! X E M A C S / E M A C S K E Y S
732 :    
733 : monnier 535 ;;(define-key sml-mode-map [(meta shift down-mouse-1)] 'sml-drag-region)
734 : monnier 32
735 : monnier 535 (provide 'sml-proc)
736 : monnier 32
737 : monnier 535 ;;; sml-proc.el ends here

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0