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 535 - (view) (download)

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

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