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 1695 - (view) (download)
Original Path: sml/trunk/sml-mode/sml-proc.el

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

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