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-mode/trunk/sml-proc.el
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2851 - (view) (download)

1 : monnier 535 ;;; sml-proc.el --- Comint based interaction mode for Standard ML.
2 : monnier 32
3 : monnier 2723 ;; Copyright (C) 1999, 2000, 2003, 2004, 2005, 2007 Stefan Monnier
4 : monnier 1478 ;; Copyright (C) 1994-1997 Matthew J. Morley
5 : monnier 541 ;; Copyright (C) 1989 Lars Bo Nielsen
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 : monnier 2817 ;; published by the Free Software Foundation; either version 3, or (at
18 : monnier 32 ;; 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 1478 `( ;; Poly/ML messages
211 : monnier 1695 ("^\\(Error\\|Warning:\\) in '\\(.+\\)', line \\([0-9]+\\)" 2 3)
212 : monnier 332 ;; Moscow ML
213 : monnier 1695 ("^File \"\\([^\"]+\\)\", line \\([0-9]+\\)\\(-\\([0-9]+\\)\\)?, characters \\([0-9]+\\)-\\([0-9]+\\):" 1 2 5)
214 :     ;; SML/NJ: the file-pattern is anchored to avoid
215 :     ;; pathological behavior with very long lines.
216 :     ("^[-= ]*\\(.*[^\n)]\\)\\( (.*)\\)?:\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warnin\\(g\\)\\): .*" 1
217 :     ,@(if (fboundp 'compilation-fake-loc) ;New compile.el.
218 :     '((3 . 6) (4 . 7) (9))
219 :     '(sml-make-error 3 4 6 7)))
220 :     ;; SML/NJ's exceptions: see above.
221 :     ("^ +\\(raised at: \\)?\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2
222 :     ,@(if (fboundp 'compilation-fake-loc) ;New compile.el.
223 :     '((3 . 6) (4 . 7))
224 :     '(sml-make-error 3 4 6 7))))
225 : monnier 395 "Alist that specifies how to match errors in compiler output.
226 :     See `compilation-error-regexp-alist' for a description of the format.")
227 : monnier 32
228 : monnier 33 ;; font-lock support
229 : monnier 332 (defconst inferior-sml-font-lock-keywords
230 :     `(;; prompt and following interactive command
231 : monnier 2824 ;; FIXME: Actually, this should already be taken care of by comint.
232 : monnier 332 (,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
233 : monnier 33 (1 font-lock-prompt-face)
234 :     (2 font-lock-command-face keep))
235 : monnier 332 ;; CM's messages
236 : monnier 39 ("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face)
237 : monnier 332 ;; SML/NJ's irritating GC messages
238 :     ("^GC #.*" . font-lock-comment-face)
239 :     ;; error messages
240 : monnier 2824 ,@(unless (fboundp 'compilation-fake-loc)
241 :     (mapcar (lambda (ra) (cons (car ra) 'font-lock-warning-face))
242 :     sml-error-regexp-alist)))
243 : monnier 332 "Font-locking specification for inferior SML mode.")
244 : monnier 33
245 : monnier 394 (defface font-lock-prompt-face
246 :     '((t (:bold t)))
247 :     "Font Lock mode face used to highlight prompts."
248 :     :group 'font-lock-highlighting-faces)
249 :     (defvar font-lock-prompt-face 'font-lock-prompt-face
250 :     "Face name to use for prompts.")
251 : monnier 33
252 : monnier 394 (defface font-lock-command-face
253 :     '((t (:bold t)))
254 :     "Font Lock mode face used to highlight interactive commands."
255 :     :group 'font-lock-highlighting-faces)
256 :     (defvar font-lock-command-face 'font-lock-command-face
257 :     "Face name to use for interactive commands.")
258 :    
259 :     (defconst inferior-sml-font-lock-defaults
260 : monnier 33 '(inferior-sml-font-lock-keywords nil nil nil nil))
261 :    
262 : monnier 535
263 : monnier 32 ;;; CODE
264 :    
265 : monnier 319 (defmap inferior-sml-mode-map
266 :     '(("\C-c\C-s" . run-sml)
267 : monnier 700 ("\C-c\C-l" . sml-load-file)
268 : monnier 319 ("\t" . comint-dynamic-complete))
269 :     "Keymap for inferior-sml mode"
270 : monnier 700 :inherit comint-mode-map
271 : monnier 394 :group 'sml-proc)
272 : monnier 32
273 : monnier 319
274 : monnier 32 ;; buffer-local
275 :    
276 : monnier 332 (defvar sml-temp-file nil)
277 : monnier 378 ;;(defvar sml-error-file nil) ; file from which the last error came
278 : monnier 32 (defvar sml-error-cursor nil) ; ditto
279 :    
280 :     (defun sml-proc-buffer ()
281 : monnier 535 "Return the current ML process buffer.
282 :     or the current buffer if it is in `inferior-sml-mode'. Raises an error
283 : monnier 32 if the variable `sml-buffer' does not appear to point to an existing
284 :     buffer."
285 : monnier 332 (or (and (eq major-mode 'inferior-sml-mode) (current-buffer))
286 :     (and sml-buffer
287 :     (let ((buf (get-buffer sml-buffer)))
288 :     ;; buffer-name returns nil if the buffer has been killed
289 :     (and buf (buffer-name buf) buf)))
290 :     ;; no buffer found, make a new one
291 : monnier 888 (save-excursion (call-interactively 'run-sml))))
292 : monnier 32
293 :     (defun sml-buffer (echo)
294 :     "Make the current buffer the current `sml-buffer' if that is sensible.
295 : monnier 535 Lookup variable `sml-buffer' to see why this might be useful.
296 :     If prefix argument ECHO is set, then it only reports on the current state."
297 : monnier 32 (interactive "P")
298 : monnier 535 (when (not echo)
299 :     (setq sml-buffer
300 :     (if (eq major-mode 'inferior-sml-mode) (current-buffer)
301 :     (read-buffer "Set ML process buffer to: " nil t))))
302 :     (message "ML process buffer is now %s."
303 : monnier 332 (or (ignore-errors (buffer-name (get-buffer sml-buffer)))
304 :     "undefined")))
305 : monnier 32
306 : monnier 535 (defun sml-proc ()
307 :     "Return the current ML process. See variable `sml-buffer'."
308 :     (assert (eq major-mode 'inferior-sml-mode))
309 :     (or (get-buffer-process (current-buffer))
310 :     (progn (call-interactively 'run-sml)
311 :     (get-buffer-process (current-buffer)))))
312 :    
313 : monnier 2822 (defun sml-proc-comint-input-filter-function (str)
314 :     ;; `compile.el' in Emacs-22 fails to notice that file location info from
315 :     ;; errors should be recomputed afresh (without using stale info from
316 :     ;; earlier compilations). We used to cause a refresh in sml-send-string,
317 :     ;; but this doesn't catch the case when the user types commands directly
318 :     ;; at the prompt.
319 :     (compilation-forget-errors) ;Has to run before compilation-fake-loc.
320 :     (if (and (fboundp 'compilation-fake-loc) sml-temp-file)
321 :     (compilation-fake-loc (cdr sml-temp-file) (car sml-temp-file)))
322 :     str)
323 :    
324 : monnier 2817 (defun inferior-sml-next-error-hook ()
325 :     ;; Try to recognize SML/NJ type error message and to highlight finely the
326 :     ;; difference between the two types (in case they're large, it's not
327 :     ;; always obvious to spot it).
328 : monnier 2851 ;;
329 :     ;; Sample messages:
330 :     ;;
331 :     ;; Data.sml:31.9-33.33 Error: right-hand-side of clause doesn't agree with function result type [tycon mismatch]
332 :     ;; expression: Hstring
333 :     ;; result type: Hstring * int
334 :     ;; in declaration:
335 :     ;; des2hs = (fn SYM_ID hs => hs
336 :     ;; | SYM_OP hs => hs
337 :     ;; | SYM_CHR hs => hs)
338 :     ;; Data.sml:35.44-35.63 Error: operator and operand don't agree [tycon mismatch]
339 :     ;; operator domain: Hstring * Hstring
340 :     ;; operand: (Hstring * int) * (Hstring * int)
341 :     ;; in expression:
342 :     ;; HSTRING.ieq (h1,h2)
343 : monnier 2817 (save-current-buffer
344 :     (when (and (derived-mode-p 'sml-mode 'inferior-sml-mode)
345 :     (boundp 'next-error-last-buffer)
346 :     (bufferp next-error-last-buffer)
347 :     (set-buffer next-error-last-buffer)
348 :     (derived-mode-p 'inferior-sml-mode)
349 :     ;; The position of `point' is not guaranteed :-(
350 : monnier 2851 (looking-at (concat ".*\\[tycon mismatch\\]\n"
351 :     " \\(operator domain\\|expression\\): +")))
352 : monnier 2817 (ignore-errors (require 'smerge-mode))
353 :     (if (not (fboundp 'smerge-refine-subst))
354 :     (remove-hook 'next-error-hook 'inferior-sml-next-error-hook)
355 :     (save-excursion
356 :     (let ((b1 (match-end 0))
357 :     e1 b2 e2)
358 : monnier 2851 (when (re-search-forward "\n in \\(expression\\|declaration\\):\n"
359 :     nil t)
360 : monnier 2817 (setq e2 (match-beginning 0))
361 : monnier 2851 (when (re-search-backward "\n \\(operand\\|result type\\): +"
362 :     b1 t)
363 : monnier 2817 (setq e1 (match-beginning 0))
364 :     (setq b2 (match-end 0))
365 :     (smerge-refine-subst b1 e1 b2 e2
366 :     '((face . smerge-refined-change)))))))))))
367 :    
368 : monnier 535 (define-derived-mode inferior-sml-mode comint-mode "Inferior-SML"
369 : monnier 32 "Major mode for interacting with an inferior ML process.
370 :    
371 :     The following commands are available:
372 :     \\{inferior-sml-mode-map}
373 :    
374 :     An ML process can be fired up (again) with \\[sml].
375 :    
376 :     Customisation: Entry to this mode runs the hooks on `comint-mode-hook'
377 :     and `inferior-sml-mode-hook' (in that order).
378 :    
379 :     Variables controlling behaviour of this mode are
380 :    
381 :     `sml-program-name' (default \"sml\")
382 :     Program to run as ML.
383 :    
384 :     `sml-use-command' (default \"use \\\"%s\\\"\")
385 :     Template for loading a file into the inferior ML process.
386 :    
387 :     `sml-cd-command' (default \"System.Directory.cd \\\"%s\\\"\")
388 :     ML command for changing directories in ML process (if possible).
389 :    
390 :     `sml-prompt-regexp' (default \"^[\\-=] *\")
391 :     Regexp used to recognise prompts in the inferior ML process.
392 :    
393 :     You can send text to the inferior ML process from other buffers containing
394 : monnier 535 ML source.
395 : monnier 32 `switch-to-sml' switches the current buffer to the ML process buffer.
396 :     `sml-send-function' sends the current *paragraph* to the ML process.
397 :     `sml-send-region' sends the current region to the ML process.
398 :    
399 :     Prefixing the sml-send-<whatever> commands with \\[universal-argument]
400 :     causes a switch to the ML process buffer after sending the text.
401 :    
402 :     For information on running multiple processes in multiple buffers, see
403 :     documentation for variable `sml-buffer'.
404 :    
405 :     Commands:
406 : monnier 535 RET after the end of the process' output sends the text from the
407 : monnier 32 end of process to point.
408 :     RET before the end of the process' output copies the current line
409 :     to the end of the process' output, and sends it.
410 :     DEL converts tabs to spaces as it moves back.
411 :     TAB file name completion, as in shell-mode, etc.."
412 :     (setq comint-prompt-regexp sml-prompt-regexp)
413 :     (sml-mode-variables)
414 :    
415 : monnier 2817 ;; We have to install it globally, 'cause it's run in the *source* buffer :-(
416 :     (add-hook 'next-error-hook 'inferior-sml-next-error-hook)
417 :    
418 : monnier 2724 ;; Make TAB add a " rather than a space at the end of a file name.
419 :     (set (make-local-variable 'comint-completion-addsuffix) '(?/ . ?\"))
420 : monnier 2822 (add-hook 'comint-input-filter-functions
421 :     'sml-proc-comint-input-filter-function nil t)
422 : monnier 2724
423 : monnier 700 (set (make-local-variable 'font-lock-defaults)
424 :     inferior-sml-font-lock-defaults)
425 : monnier 32 ;; For sequencing through error messages:
426 : monnier 300 (set (make-local-variable 'sml-error-cursor) (point-max-marker))
427 : monnier 332 (set-marker-insertion-type sml-error-cursor nil)
428 : monnier 32
429 : monnier 765 ;; Compilation support (used for `next-error').
430 :     ;; The keymap of compilation-minor-mode is too unbearable, so we
431 :     ;; just can't use the minor-mode if we can't override the map.
432 :     (when (boundp 'minor-mode-overriding-map-alist)
433 :     (set (make-local-variable 'compilation-error-regexp-alist)
434 :     sml-error-regexp-alist)
435 :     (compilation-minor-mode 1)
436 :     ;; Eliminate compilation-minor-mode's map.
437 : monnier 1871 (let ((map (make-sparse-keymap)))
438 :     (dolist (keys '([menu-bar] [follow-link]))
439 :     ;; Preserve some of the bindings.
440 :     (define-key map keys (lookup-key compilation-minor-mode-map keys)))
441 :     (add-to-list 'minor-mode-overriding-map-alist
442 :     (cons 'compilation-minor-mode map)))
443 : monnier 765 ;; I'm sure people might kill me for that
444 :     (setq compilation-error-screen-columns nil)
445 :     (make-local-variable 'sml-endof-error-alist))
446 :     ;;(make-local-variable 'sml-error-overlay)
447 : monnier 32
448 : monnier 535 (setq mode-line-process '(": %s")))
449 : monnier 32
450 :     ;;; FOR RUNNING ML FROM EMACS
451 :    
452 : monnier 33 ;;;###autoload
453 : monnier 535 (autoload 'run-sml "sml-proc" nil t)
454 :     (defalias 'run-sml 'sml-run)
455 :     (defun sml-run (cmd arg &optional host)
456 :     "Run the program CMD with given arguments ARG.
457 :     The command is run in buffer *CMD* using mode `inferior-sml-mode'.
458 :     If the buffer already exists and has a running process, then
459 :     just go to this buffer.
460 : monnier 32
461 : monnier 535 This updates `sml-buffer' to the new buffer.
462 :     You can have several inferior M(or L process running, but only one (> s
463 : monnier 32 current one -- given by `sml-buffer' (qv).
464 :    
465 : monnier 535 If a prefix argument is used, the user is also prompted for a HOST
466 :     on which to run CMD using `remote-shell-program'.
467 :    
468 : monnier 32 \(Type \\[describe-mode] in the process buffer for a list of commands.)"
469 : monnier 535 (interactive
470 :     (list
471 :     (read-string "ML command: " sml-program-name)
472 :     (if (or current-prefix-arg (> (length sml-default-arg) 0))
473 :     (read-string "Any args: " sml-default-arg)
474 :     sml-default-arg)
475 :     (if (or current-prefix-arg (> (length sml-host-name) 0))
476 :     (read-string "On host: " sml-host-name)
477 :     sml-host-name)))
478 : monnier 32 (let* ((pname (file-name-nondirectory cmd))
479 : monnier 535 (args (if (equal arg "") () (split-string arg)))
480 :     (file (when (and sml-config-file (file-exists-p sml-config-file))
481 :     sml-config-file)))
482 : monnier 332 ;; and this -- to keep these as defaults even if
483 :     ;; they're set in the mode hooks.
484 :     (setq sml-program-name cmd)
485 :     (setq sml-default-arg arg)
486 : monnier 535 (setq sml-host-name host)
487 :     ;; For remote execution, use `remote-shell-program'
488 :     (when (> (length host) 0)
489 :     (setq args (list* host "cd" default-directory ";" cmd args))
490 :     (setq cmd remote-shell-program))
491 :     ;; go for it
492 : monnier 700 (let ((exec-path (if (file-name-directory cmd)
493 :     ;; If the command has slashes, make sure we
494 :     ;; first look relative to the current directory.
495 :     ;; Emacs-21 does it for us, but not Emacs-20.
496 :     (cons default-directory exec-path) exec-path)))
497 :     (setq sml-buffer (apply 'make-comint pname cmd file args)))
498 : monnier 32
499 : monnier 535 (pop-to-buffer sml-buffer)
500 :     ;;(message (format "Starting \"%s\" in background." pname))
501 : monnier 332 (inferior-sml-mode)
502 :     (goto-char (point-max))
503 :     sml-buffer))
504 :    
505 : monnier 535 (defun switch-to-sml (eobp)
506 : monnier 32 "Switch to the ML process buffer.
507 : monnier 535 Move point to the end of buffer unless prefix argument EOBP is set."
508 : monnier 32 (interactive "P")
509 : monnier 33 (pop-to-buffer (sml-proc-buffer))
510 : monnier 535 (unless eobp
511 :     (push-mark (point) t)
512 :     (goto-char (point-max))))
513 : monnier 32
514 :     ;; Fakes it with a "use <temp-file>;" if necessary.
515 :    
516 :     (defun sml-send-region (start end &optional and-go)
517 : monnier 535 "Send current region START..END to the inferior ML process.
518 :     Prefix AND-GO argument means switch-to-sml afterwards.
519 : monnier 32
520 : monnier 332 The region is written out to a temporary file and a \"use <temp-file>\" command
521 :     is sent to the compiler.
522 :     See variables `sml-use-command'."
523 : monnier 32 (interactive "r\nP")
524 : monnier 332 (if (= start end)
525 :     (message "The region is zero (ignored)")
526 :     (let* ((buf (sml-proc-buffer))
527 :     (marker (copy-marker start))
528 :     (tmp (make-temp-file "sml")))
529 :     (write-region start end tmp nil 'silently)
530 :     (with-current-buffer buf
531 :     (when sml-temp-file
532 :     (ignore-errors (delete-file (car sml-temp-file)))
533 :     (set-marker (cdr sml-temp-file) nil))
534 :     (setq sml-temp-file (cons tmp marker))
535 :     (sml-send-string (format sml-use-command tmp) nil and-go)))))
536 : monnier 32
537 :     ;; This is quite bogus, so it isn't bound to a key by default.
538 :     ;; Anyone coming up with an algorithm to recognise fun & local
539 :     ;; declarations surrounding point will do everyone a favour!
540 :    
541 :     (defun sml-send-function (&optional and-go)
542 :     "Send current paragraph to the inferior ML process.
543 : monnier 535 With a prefix argument AND-GO switch to the sml buffer as well
544 : monnier 32 \(cf. `sml-send-region'\)."
545 :     (interactive "P")
546 :     (save-excursion
547 :     (sml-mark-function)
548 :     (sml-send-region (point) (mark)))
549 :     (if and-go (switch-to-sml nil)))
550 :    
551 : monnier 332 (defvar sml-source-modes '(sml-mode)
552 :     "*Used to determine if a buffer contains ML source code.
553 : monnier 319 If it's loaded into a buffer that is in one of these major modes, it's
554 : monnier 535 considered an ML source file by `sml-load-file'. Used by these commands
555 : monnier 319 to determine defaults.")
556 :    
557 : monnier 32 (defun sml-send-buffer (&optional and-go)
558 :     "Send buffer to inferior shell running ML process.
559 : monnier 535 With a prefix argument AND-GO switch to the sml buffer as well
560 : monnier 32 \(cf. `sml-send-region'\)."
561 :     (interactive "P")
562 :     (if (memq major-mode sml-source-modes)
563 :     (sml-send-region (point-min) (point-max) and-go)))
564 :    
565 :     ;; Since sml-send-function/region take an optional prefix arg, these
566 :     ;; commands are redundant. But they are kept around for the user to
567 :     ;; bind if she wishes, since its easier to type C-c r than C-u C-c C-r.
568 :    
569 :     (defun sml-send-region-and-go (start end)
570 : monnier 535 "Send current region START..END to the inferior ML process, and go there."
571 : monnier 32 (interactive "r")
572 :     (sml-send-region start end t))
573 :    
574 :     (defun sml-send-function-and-go ()
575 :     "Send current paragraph to the inferior ML process, and go there."
576 :     (interactive)
577 :     (sml-send-function t))
578 :    
579 :     ;;; LOADING AND IMPORTING SOURCE FILES:
580 :    
581 : monnier 332 (defvar sml-prev-dir/file nil
582 : monnier 535 "Cache for (DIRECTORY . FILE) pair last.
583 :     Set in `sml-load-file' and `sml-cd' commands.
584 :     Used to determine the default in the next `ml-load-file'.")
585 : monnier 32
586 :     (defun sml-load-file (&optional and-go)
587 :     "Load an ML file into the current inferior ML process.
588 : monnier 535 With a prefix argument AND-GO switch to sml buffer as well.
589 : monnier 32
590 :     This command uses the ML command template `sml-use-command' to construct
591 :     the command to send to the ML process\; a trailing \"\;\\n\" will be added
592 :     automatically."
593 :     (interactive "P")
594 : monnier 332 (let ((file (car (comint-get-source
595 :     "Load ML file: " sml-prev-dir/file sml-source-modes t))))
596 :     (with-current-buffer (sml-proc-buffer)
597 :     ;; Check if buffer needs saved. Should (save-some-buffers) instead?
598 :     (comint-check-source file)
599 :     (setq sml-prev-dir/file
600 :     (cons (file-name-directory file) (file-name-nondirectory file)))
601 :     (sml-send-string (format sml-use-command file) nil and-go))))
602 : monnier 32
603 :     (defun sml-cd (dir)
604 :     "Change the working directory of the inferior ML process.
605 : monnier 535 The default directory of the process buffer is changed to DIR. If the
606 : monnier 32 variable `sml-cd-command' is non-nil it should be an ML command that will
607 :     be executed to change the compiler's working directory\; a trailing
608 :     \"\;\\n\" will be added automatically."
609 :     (interactive "DSML Directory: ")
610 : monnier 332 (let ((dir (expand-file-name dir)))
611 :     (with-current-buffer (sml-proc-buffer)
612 :     (sml-send-string (format sml-cd-command dir) t)
613 :     (setq default-directory dir))
614 :     (setq sml-prev-dir/file (cons dir nil))))
615 : monnier 32
616 : monnier 332 (defun sml-send-string (str &optional print and-go)
617 :     (let ((proc (sml-proc))
618 :     (str (concat str ";\n"))
619 :     (win (get-buffer-window (current-buffer) 'visible)))
620 :     (when win (select-window win))
621 :     (goto-char (point-max))
622 :     (when print (insert str))
623 :     (sml-update-cursor)
624 :     (set-marker (process-mark proc) (point-max))
625 :     (setq compilation-last-buffer (current-buffer))
626 :     (comint-send-string proc str)
627 :     (when and-go (switch-to-sml nil))))
628 : monnier 32
629 : monnier 2723 (defun sml-compile (command &optional and-go)
630 : monnier 535 "Pass a COMMAND to the SML process to compile the current program.
631 :    
632 :     You can then use the command \\[next-error] to find the next error message
633 :     and move to the source code that caused it.
634 :    
635 :     Interactively, prompts for the command if `compilation-read-command' is
636 : monnier 2723 non-nil. With prefix arg, always prompts.
637 :    
638 :     Prefix arg AND-GO also means to `switch-to-sml' afterwards."
639 : monnier 33 (interactive
640 : monnier 535 (let* ((dir default-directory)
641 :     (cmd "cd \"."))
642 :     ;; look for files to determine the default command
643 :     (while (and (stringp dir)
644 :     (dolist (cf sml-compile-commands-alist 1)
645 :     (when (file-exists-p (expand-file-name (cdr cf) dir))
646 :     (setq cmd (concat cmd "\"; " (car cf))) (return nil))))
647 :     (let ((newdir (file-name-directory (directory-file-name dir))))
648 :     (setq dir (unless (equal newdir dir) newdir))
649 :     (setq cmd (concat cmd "/.."))))
650 :     (setq cmd
651 :     (cond
652 :     ((local-variable-p 'sml-compile-command) sml-compile-command)
653 :     ((string-match "^\\s-*cd\\s-+\"\\.\"\\s-*;\\s-*" cmd)
654 :     (substring cmd (match-end 0)))
655 :     ((string-match "^\\s-*cd\\s-+\"\\(\\./\\)" cmd)
656 :     (replace-match "" t t cmd 1))
657 :     ((string-match ";" cmd) cmd)
658 :     (t sml-compile-command)))
659 :     ;; code taken from compile.el
660 :     (if (or compilation-read-command current-prefix-arg)
661 :     (list (read-from-minibuffer "Compile command: "
662 :     cmd nil nil '(compile-history . 1)))
663 :     (list cmd))))
664 :     ;; ;; now look for command's file to determine the directory
665 :     ;; (setq dir default-directory)
666 :     ;; (while (and (stringp dir)
667 :     ;; (dolist (cf sml-compile-commands-alist t)
668 :     ;; (when (and (equal cmd (car cf))
669 :     ;; (file-exists-p (expand-file-name (cdr cf) dir)))
670 :     ;; (return nil))))
671 :     ;; (let ((newdir (file-name-directory (directory-file-name dir))))
672 :     ;; (setq dir (unless (equal newdir dir) newdir))))
673 :     ;; (setq dir (or dir default-directory))
674 :     ;; (list cmd dir)))
675 :     (set (make-local-variable 'sml-compile-command) command)
676 : monnier 332 (save-some-buffers (not compilation-ask-about-save) nil)
677 : monnier 535 (let ((dir default-directory))
678 :     (when (string-match "^\\s-*cd\\s-+\"\\([^\"]+\\)\"\\s-*;" command)
679 : blume 566 (setq dir (match-string 1 command))
680 : monnier 535 (setq command (replace-match "" t t command)))
681 : blume 566 (setq dir (expand-file-name dir))
682 : monnier 332 (with-current-buffer (sml-proc-buffer)
683 :     (setq default-directory dir)
684 : monnier 2723 (sml-send-string (concat (format sml-cd-command dir) "; " command)
685 :     t and-go))))
686 : monnier 32
687 : monnier 33 ;;; PARSING ERROR MESSAGES
688 : monnier 32
689 :     ;; This should need no modification to support other compilers.
690 :    
691 : monnier 332 ;; Update the buffer-local error-cursor in proc-buffer to be its
692 :     ;; current proc mark.
693 : monnier 32
694 : monnier 332 (defvar sml-endof-error-alist nil)
695 : monnier 32
696 : monnier 332 (defun sml-update-cursor ()
697 : monnier 1478 ;; Update buffer local variable.
698 : monnier 332 (set-marker sml-error-cursor (1- (process-mark (sml-proc))))
699 :     (setq sml-endof-error-alist nil)
700 : monnier 2822 ;; This is now done in comint-input-filter-functions.
701 :     ;; (compilation-forget-errors) ;Has to run before compilation-fake-loc.
702 :     ;; (if (and (fboundp 'compilation-fake-loc) sml-temp-file)
703 :     ;; (compilation-fake-loc (cdr sml-temp-file) (car sml-temp-file)))
704 : monnier 378 (if (markerp compilation-parsing-end)
705 :     (set-marker compilation-parsing-end sml-error-cursor)
706 :     (setq compilation-parsing-end sml-error-cursor)))
707 : monnier 32
708 : monnier 332 (defun sml-make-error (f c)
709 :     (let ((err (point-marker))
710 :     (linenum (string-to-number c))
711 :     (filename (list (first f) (second f)))
712 : monnier 1691 (column (string-to-number (match-string (third f)))))
713 : monnier 332 ;; record the end of error, if any
714 :     (when (fourth f)
715 : monnier 1691 (let ((endlinestr (match-string (fourth f))))
716 : monnier 535 (when endlinestr
717 :     (let* ((endline (string-to-number endlinestr))
718 :     (endcol (string-to-number
719 : monnier 1691 (or (match-string (fifth f)) "0")))
720 : monnier 535 (linediff (- endline linenum)))
721 :     (push (list err linediff (if (= 0 linediff) (- endcol column) endcol))
722 :     sml-endof-error-alist)))))
723 : monnier 332 ;; build the error descriptor
724 :     (if (string= (car sml-temp-file) (first f))
725 :     ;; special case for code sent via sml-send-region
726 :     (let ((marker (cdr sml-temp-file)))
727 :     (with-current-buffer (marker-buffer marker)
728 :     (goto-char marker)
729 :     (forward-line (1- linenum))
730 :     (forward-char (1- column))
731 : monnier 1472 ;; A pair of markers is the right thing to return, but some
732 :     ;; code in compile.el doesn't like it (when we reach the end
733 :     ;; of the errors). So we could try to avoid it, but we don't
734 :     ;; because that doesn't work correctly if the current buffer
735 :     ;; has unsaved modifications. And it's fixed in Emacs-21.
736 :     ;; (if buffer-file-name
737 :     ;; (list err buffer-file-name
738 :     ;; (count-lines (point-min) (point)) (current-column))
739 :     (cons err (point-marker)))) ;; )
740 : monnier 332 ;; taken from compile.el
741 :     (list err filename linenum column))))
742 : monnier 32
743 : monnier 1478 (unless (fboundp 'compilation-fake-loc)
744 : monnier 332 (defadvice compilation-goto-locus (after sml-endof-error activate)
745 :     (let* ((next-error (ad-get-arg 0))
746 :     (err (car next-error))
747 :     (pos (cdr next-error))
748 :     (endof (with-current-buffer (marker-buffer err)
749 :     (assq err sml-endof-error-alist))))
750 :     (if (not endof) (sml-error-overlay 'undo)
751 :     (with-current-buffer (marker-buffer pos)
752 :     (goto-char pos)
753 :     (let ((linediff (second endof))
754 :     (coldiff (third endof)))
755 :     (when (> 0 linediff) (forward-line linediff))
756 :     (forward-char coldiff))
757 :     (sml-error-overlay nil pos (point))
758 :     (push-mark nil t (not sml-error-overlay))
759 : monnier 1478 (goto-char pos))))))
760 : monnier 32
761 : monnier 332 (defun sml-error-overlay (undo &optional beg end)
762 : monnier 535 "Move `sml-error-overlay' to the text region in the current buffer.
763 :     If the buffer-local variable `sml-error-overlay' is
764 : monnier 332 non-nil it should be an overlay \(or extent, in XEmacs speak\)\; this
765 :     function moves the overlay over the current region. If the optional
766 :     BUFFER argument is given, move the overlay in that buffer instead of
767 :     the current buffer.
768 :    
769 :     Called interactively, the optional prefix argument UNDO indicates that
770 :     the overlay should simply be removed: \\[universal-argument] \
771 :     \\[sml-error-overlay]."
772 : monnier 32 (interactive "P")
773 : monnier 332 (when sml-error-overlay
774 :     (unless (overlayp sml-error-overlay)
775 :     (let ((ol sml-error-overlay))
776 :     (setq sml-error-overlay (make-overlay 0 0))
777 :     (overlay-put sml-error-overlay 'face (if (symbolp ol) ol 'region))))
778 : monnier 394 (if undo (move-overlay sml-error-overlay 1 1 (current-buffer))
779 : monnier 332 ;; if active regions, signals mark not active if no region set
780 :     (let ((beg (or beg (region-beginning)))
781 :     (end (or end (region-end))))
782 :     (move-overlay sml-error-overlay beg end (current-buffer))))))
783 : monnier 32
784 : monnier 535 (provide 'sml-proc)
785 : monnier 32
786 : monnier 535 ;;; sml-proc.el ends here

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