1 ;;; sml-proc.el --- Comint based interaction mode for Standard ML.
3 ;; Copyright (C) 1999,2000,03,04 Stefan Monnier
4 ;; Copyright (C) 1994-1997 Matthew J. Morley
5 ;; Copyright (C) 1989 Lars Bo Nielsen
10 ;; ====================================================================
12 ;; This file is not part of GNU Emacs, but it is distributed under the
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.
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.
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.)
30 ;; ====================================================================
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.
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 ;; achieved by M-x run-sml which starts a sub-process under emacs. You may
42 ;; need to set this up for autoloading in your .emacs:
44 ;; (autoload 'run-sml "sml-proc" "Run an inferior ML process." t)
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 ;; run-sml) you will be prompted for a different program to execute from
49 ;; 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).
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
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).
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 ;; reported by the compiler, C-x ` (next-error) will step through
70 ;; the errors with you.
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 ;; Moscow ML, and Poly/ML. For other compilers, add the relevant
76 ;; regexp to sml-error-regexp-alist and send it to me.
78 ;; 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
87 ;; - Keep improving `sml-compile'.
88 ;; - ignore warnings (if requested) for next-error
92 (eval-when-compile (require 'cl))
99 "Interacting with an SML process."
102 (defcustom sml-program-name "sml"
103 "*Program to run as ML."
107 (defcustom sml-default-arg ""
108 "*Default command line option to pass, if any."
112 (defcustom sml-host-name ""
113 "*Host on which to run ML."
117 (defcustom sml-config-file "~/.smlproc.sml"
118 "*File that should be fed to the ML process when started."
122 (defcustom sml-compile-command "CM.make()"
123 "The command used by default by `sml-compile'.
124 See also `sml-compile-commands-alist'.")
126 (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.")
136 (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.")
140 (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).")
147 (defvar sml-buffer nil
148 "*The current ML process buffer.
150 MULTIPLE PROCESS SUPPORT (Whoever wants multi-process support anyway?)
151 =====================================================================
152 `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 between the different process buffers with \\[switch-to-buffer].
159 NB *sml* is just the default name for the buffer. It actually gets
160 it's name from the value of `sml-program-name' -- *poly*, *smld*,...
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 `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 inferior ML's running:
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?
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'.
179 This process selection is performed by function `sml-proc' which looks
180 at the value of `sml-buffer' -- which must be a Lisp buffer object, or
183 Whenever \\[sml] fires up a new process, it resets `sml-buffer' to be
184 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 `sml-buffer' to another process buffer with \\[set-variable], or
187 use the command \\[sml-buffer] in the interaction buffer of choice.")
190 ;;; ALL STUFF THAT DEFAULTS TO THE SML/NJ COMPILER (0.93)
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.")
197 (defvar sml-cd-command "OS.FileSys.chDir \"%s\""
198 "*Command template for changing working directories under ML.
199 Set this to nil if your compiler can't change directories.
201 The format specifier \"%s\" will be converted into the directory name
202 specified when running the command \\[sml-cd].")
204 (defcustom sml-prompt-regexp "^[-=>#] *"
205 "*Regexp used to recognise prompts in the inferior ML process."
209 (defvar sml-error-regexp-alist
210 `( ;; Poly/ML messages
211 ("\\(Error\\|Warning:\\) in '\\(.+\\)', line \\([0-9]+\\)" 2 3)
213 ("File \"\\([^\"]+\\)\", line \\([0-9]+\\)\\(-\\([0-9]+\\)\\)?, characters \\([0-9]+\\)-\\([0-9]+\\):" 1 2 5)
214 ,@(if (not (fboundp 'compilation-fake-loc))
215 ;; SML/NJ: the file-pattern is anchored to avoid
216 ;; pathological behavior with very long lines.
218 ("^[-= ]*\\(.*[^\n)]\\)\\( (.*)\\)?:\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warning\\): .*" 1 sml-make-error 3 4 6 7)
219 ("^ +\\(raised at: \\)?\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2 sml-make-error 3 4 6 7))
220 '(("^[-= ]*\\(.*[^\n)]\\)\\( (.*)\\)?:\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warnin\\(g\\)\\): .*" 1 (3 . 6) (4 . 7) (9))
221 ;; SML/NJ's exceptions: see above.
222 ("^ +\\(raised at: \\)?\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2 (3 . 6) (4 . 7)))))
223 "Alist that specifies how to match errors in compiler output.
224 See `compilation-error-regexp-alist' for a description of the format.")
227 (defconst inferior-sml-font-lock-keywords
228 `(;; prompt and following interactive command
229 (,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
230 (1 font-lock-prompt-face)
231 (2 font-lock-command-face keep))
233 ("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face)
234 ;; SML/NJ's irritating GC messages
235 ("^GC #.*" . font-lock-comment-face)
237 ,@(mapcar (lambda (ra) (cons (car ra) 'font-lock-warning-face))
238 sml-error-regexp-alist))
239 "Font-locking specification for inferior SML mode.")
241 (defface font-lock-prompt-face
243 "Font Lock mode face used to highlight prompts."
244 :group 'font-lock-highlighting-faces)
245 (defvar font-lock-prompt-face 'font-lock-prompt-face
246 "Face name to use for prompts.")
248 (defface font-lock-command-face
250 "Font Lock mode face used to highlight interactive commands."
251 :group 'font-lock-highlighting-faces)
252 (defvar font-lock-command-face 'font-lock-command-face
253 "Face name to use for interactive commands.")
255 (defconst inferior-sml-font-lock-defaults
256 '(inferior-sml-font-lock-keywords nil nil nil nil))
261 (defmap inferior-sml-mode-map
262 '(("\C-c\C-s" . run-sml)
263 ("\C-c\C-l" . sml-load-file)
264 ("\t" . comint-dynamic-complete))
265 "Keymap for inferior-sml mode"
266 :inherit comint-mode-map
272 (defvar sml-temp-file nil)
273 ;;(defvar sml-error-file nil) ; file from which the last error came
274 (defvar sml-error-cursor nil) ; ditto
276 (defun sml-proc-buffer ()
277 "Return the current ML process buffer.
278 or the current buffer if it is in `inferior-sml-mode'. Raises an error
279 if the variable `sml-buffer' does not appear to point to an existing
281 (or (and (eq major-mode 'inferior-sml-mode) (current-buffer))
283 (let ((buf (get-buffer sml-buffer)))
284 ;; buffer-name returns nil if the buffer has been killed
285 (and buf (buffer-name buf) buf)))
286 ;; no buffer found, make a new one
287 (save-excursion (call-interactively 'run-sml))))
289 (defun sml-buffer (echo)
290 "Make the current buffer the current `sml-buffer' if that is sensible.
291 Lookup variable `sml-buffer' to see why this might be useful.
292 If prefix argument ECHO is set, then it only reports on the current state."
296 (if (eq major-mode 'inferior-sml-mode) (current-buffer)
297 (read-buffer "Set ML process buffer to: " nil t))))
298 (message "ML process buffer is now %s."
299 (or (ignore-errors (buffer-name (get-buffer sml-buffer)))
303 "Return the current ML process. See variable `sml-buffer'."
304 (assert (eq major-mode 'inferior-sml-mode))
305 (or (get-buffer-process (current-buffer))
306 (progn (call-interactively 'run-sml)
307 (get-buffer-process (current-buffer)))))
309 (define-derived-mode inferior-sml-mode comint-mode "Inferior-SML"
310 "Major mode for interacting with an inferior ML process.
312 The following commands are available:
313 \\{inferior-sml-mode-map}
315 An ML process can be fired up (again) with \\[sml].
317 Customisation: Entry to this mode runs the hooks on `comint-mode-hook'
318 and `inferior-sml-mode-hook' (in that order).
320 Variables controlling behaviour of this mode are
322 `sml-program-name' (default \"sml\")
323 Program to run as ML.
325 `sml-use-command' (default \"use \\\"%s\\\"\")
326 Template for loading a file into the inferior ML process.
328 `sml-cd-command' (default \"System.Directory.cd \\\"%s\\\"\")
329 ML command for changing directories in ML process (if possible).
331 `sml-prompt-regexp' (default \"^[\\-=] *\")
332 Regexp used to recognise prompts in the inferior ML process.
334 You can send text to the inferior ML process from other buffers containing
336 `switch-to-sml' switches the current buffer to the ML process buffer.
337 `sml-send-function' sends the current *paragraph* to the ML process.
338 `sml-send-region' sends the current region to the ML process.
340 Prefixing the sml-send-<whatever> commands with \\[universal-argument]
341 causes a switch to the ML process buffer after sending the text.
343 For information on running multiple processes in multiple buffers, see
344 documentation for variable `sml-buffer'.
347 RET after the end of the process' output sends the text from the
348 end of process to point.
349 RET before the end of the process' output copies the current line
350 to the end of the process' output, and sends it.
351 DEL converts tabs to spaces as it moves back.
352 TAB file name completion, as in shell-mode, etc.."
353 (setq comint-prompt-regexp sml-prompt-regexp)
356 (set (make-local-variable 'font-lock-defaults)
357 inferior-sml-font-lock-defaults)
358 ;; For sequencing through error messages:
359 (set (make-local-variable 'sml-error-cursor) (point-max-marker))
360 (set-marker-insertion-type sml-error-cursor nil)
362 ;; Compilation support (used for `next-error').
363 ;; The keymap of compilation-minor-mode is too unbearable, so we
364 ;; just can't use the minor-mode if we can't override the map.
365 (when (boundp 'minor-mode-overriding-map-alist)
366 (set (make-local-variable 'compilation-error-regexp-alist)
367 sml-error-regexp-alist)
368 (compilation-minor-mode 1)
369 ;; Eliminate compilation-minor-mode's map.
370 (add-to-list 'minor-mode-overriding-map-alist
371 (cons 'compilation-minor-mode (make-sparse-keymap)))
372 ;; I'm sure people might kill me for that
373 (setq compilation-error-screen-columns nil)
374 (make-local-variable 'sml-endof-error-alist))
375 ;;(make-local-variable 'sml-error-overlay)
377 (setq mode-line-process '(": %s")))
379 ;;; FOR RUNNING ML FROM EMACS
382 (autoload 'run-sml "sml-proc" nil t)
383 (defalias 'run-sml 'sml-run)
384 (defun sml-run (cmd arg &optional host)
385 "Run the program CMD with given arguments ARG.
386 The command is run in buffer *CMD* using mode `inferior-sml-mode'.
387 If the buffer already exists and has a running process, then
388 just go to this buffer.
390 This updates `sml-buffer' to the new buffer.
391 You can have several inferior M(or L process running, but only one (> s
392 current one -- given by `sml-buffer' (qv).
394 If a prefix argument is used, the user is also prompted for a HOST
395 on which to run CMD using `remote-shell-program'.
397 \(Type \\[describe-mode] in the process buffer for a list of commands.)"
400 (read-string "ML command: " sml-program-name)
401 (if (or current-prefix-arg (> (length sml-default-arg) 0))
402 (read-string "Any args: " sml-default-arg)
404 (if (or current-prefix-arg (> (length sml-host-name) 0))
405 (read-string "On host: " sml-host-name)
407 (let* ((pname (file-name-nondirectory cmd))
408 (args (if (equal arg "") () (split-string arg)))
409 (file (when (and sml-config-file (file-exists-p sml-config-file))
411 ;; and this -- to keep these as defaults even if
412 ;; they're set in the mode hooks.
413 (setq sml-program-name cmd)
414 (setq sml-default-arg arg)
415 (setq sml-host-name host)
416 ;; For remote execution, use `remote-shell-program'
417 (when (> (length host) 0)
418 (setq args (list* host "cd" default-directory ";" cmd args))
419 (setq cmd remote-shell-program))
421 (let ((exec-path (if (file-name-directory cmd)
422 ;; If the command has slashes, make sure we
423 ;; first look relative to the current directory.
424 ;; Emacs-21 does it for us, but not Emacs-20.
425 (cons default-directory exec-path) exec-path)))
426 (setq sml-buffer (apply 'make-comint pname cmd file args)))
428 (pop-to-buffer sml-buffer)
429 ;;(message (format "Starting \"%s\" in background." pname))
431 (goto-char (point-max))
434 (defun switch-to-sml (eobp)
435 "Switch to the ML process buffer.
436 Move point to the end of buffer unless prefix argument EOBP is set."
438 (pop-to-buffer (sml-proc-buffer))
440 (push-mark (point) t)
441 (goto-char (point-max))))
443 ;; Fakes it with a "use <temp-file>;" if necessary.
445 (defun sml-send-region (start end &optional and-go)
446 "Send current region START..END to the inferior ML process.
447 Prefix AND-GO argument means switch-to-sml afterwards.
449 The region is written out to a temporary file and a \"use <temp-file>\" command
450 is sent to the compiler.
451 See variables `sml-use-command'."
454 (message "The region is zero (ignored)")
455 (let* ((buf (sml-proc-buffer))
456 (marker (copy-marker start))
457 (tmp (make-temp-file "sml")))
458 (write-region start end tmp nil 'silently)
459 (with-current-buffer buf
461 (ignore-errors (delete-file (car sml-temp-file)))
462 (set-marker (cdr sml-temp-file) nil))
463 (setq sml-temp-file (cons tmp marker))
464 (sml-send-string (format sml-use-command tmp) nil and-go)))))
466 ;; This is quite bogus, so it isn't bound to a key by default.
467 ;; Anyone coming up with an algorithm to recognise fun & local
468 ;; declarations surrounding point will do everyone a favour!
470 (defun sml-send-function (&optional and-go)
471 "Send current paragraph to the inferior ML process.
472 With a prefix argument AND-GO switch to the sml buffer as well
473 \(cf. `sml-send-region'\)."
477 (sml-send-region (point) (mark)))
478 (if and-go (switch-to-sml nil)))
480 (defvar sml-source-modes '(sml-mode)
481 "*Used to determine if a buffer contains ML source code.
482 If it's loaded into a buffer that is in one of these major modes, it's
483 considered an ML source file by `sml-load-file'. Used by these commands
484 to determine defaults.")
486 (defun sml-send-buffer (&optional and-go)
487 "Send buffer to inferior shell running ML process.
488 With a prefix argument AND-GO switch to the sml buffer as well
489 \(cf. `sml-send-region'\)."
491 (if (memq major-mode sml-source-modes)
492 (sml-send-region (point-min) (point-max) and-go)))
494 ;; Since sml-send-function/region take an optional prefix arg, these
495 ;; commands are redundant. But they are kept around for the user to
496 ;; bind if she wishes, since its easier to type C-c r than C-u C-c C-r.
498 (defun sml-send-region-and-go (start end)
499 "Send current region START..END to the inferior ML process, and go there."
501 (sml-send-region start end t))
503 (defun sml-send-function-and-go ()
504 "Send current paragraph to the inferior ML process, and go there."
506 (sml-send-function t))
508 ;;; LOADING AND IMPORTING SOURCE FILES:
510 (defvar sml-prev-dir/file nil
511 "Cache for (DIRECTORY . FILE) pair last.
512 Set in `sml-load-file' and `sml-cd' commands.
513 Used to determine the default in the next `ml-load-file'.")
515 (defun sml-load-file (&optional and-go)
516 "Load an ML file into the current inferior ML process.
517 With a prefix argument AND-GO switch to sml buffer as well.
519 This command uses the ML command template `sml-use-command' to construct
520 the command to send to the ML process\; a trailing \"\;\\n\" will be added
523 (let ((file (car (comint-get-source
524 "Load ML file: " sml-prev-dir/file sml-source-modes t))))
525 (with-current-buffer (sml-proc-buffer)
526 ;; Check if buffer needs saved. Should (save-some-buffers) instead?
527 (comint-check-source file)
528 (setq sml-prev-dir/file
529 (cons (file-name-directory file) (file-name-nondirectory file)))
530 (sml-send-string (format sml-use-command file) nil and-go))))
533 "Change the working directory of the inferior ML process.
534 The default directory of the process buffer is changed to DIR. If the
535 variable `sml-cd-command' is non-nil it should be an ML command that will
536 be executed to change the compiler's working directory\; a trailing
537 \"\;\\n\" will be added automatically."
538 (interactive "DSML Directory: ")
539 (let ((dir (expand-file-name dir)))
540 (with-current-buffer (sml-proc-buffer)
541 (sml-send-string (format sml-cd-command dir) t)
542 (setq default-directory dir))
543 (setq sml-prev-dir/file (cons dir nil))))
545 (defun sml-send-string (str &optional print and-go)
546 (let ((proc (sml-proc))
547 (str (concat str ";\n"))
548 (win (get-buffer-window (current-buffer) 'visible)))
549 (when win (select-window win))
550 (goto-char (point-max))
551 (when print (insert str))
553 (set-marker (process-mark proc) (point-max))
554 (setq compilation-last-buffer (current-buffer))
555 (comint-send-string proc str)
556 (when and-go (switch-to-sml nil))))
558 (defun sml-compile (command)
559 "Pass a COMMAND to the SML process to compile the current program.
561 You can then use the command \\[next-error] to find the next error message
562 and move to the source code that caused it.
564 Interactively, prompts for the command if `compilation-read-command' is
565 non-nil. With prefix arg, always prompts."
567 (let* ((dir default-directory)
569 ;; look for files to determine the default command
570 (while (and (stringp dir)
571 (dolist (cf sml-compile-commands-alist 1)
572 (when (file-exists-p (expand-file-name (cdr cf) dir))
573 (setq cmd (concat cmd "\"; " (car cf))) (return nil))))
574 (let ((newdir (file-name-directory (directory-file-name dir))))
575 (setq dir (unless (equal newdir dir) newdir))
576 (setq cmd (concat cmd "/.."))))
579 ((local-variable-p 'sml-compile-command) sml-compile-command)
580 ((string-match "^\\s-*cd\\s-+\"\\.\"\\s-*;\\s-*" cmd)
581 (substring cmd (match-end 0)))
582 ((string-match "^\\s-*cd\\s-+\"\\(\\./\\)" cmd)
583 (replace-match "" t t cmd 1))
584 ((string-match ";" cmd) cmd)
585 (t sml-compile-command)))
586 ;; code taken from compile.el
587 (if (or compilation-read-command current-prefix-arg)
588 (list (read-from-minibuffer "Compile command: "
589 cmd nil nil '(compile-history . 1)))
591 ;; ;; now look for command's file to determine the directory
592 ;; (setq dir default-directory)
593 ;; (while (and (stringp dir)
594 ;; (dolist (cf sml-compile-commands-alist t)
595 ;; (when (and (equal cmd (car cf))
596 ;; (file-exists-p (expand-file-name (cdr cf) dir)))
598 ;; (let ((newdir (file-name-directory (directory-file-name dir))))
599 ;; (setq dir (unless (equal newdir dir) newdir))))
600 ;; (setq dir (or dir default-directory))
602 (set (make-local-variable 'sml-compile-command) command)
603 (save-some-buffers (not compilation-ask-about-save) nil)
604 (let ((dir default-directory))
605 (when (string-match "^\\s-*cd\\s-+\"\\([^\"]+\\)\"\\s-*;" command)
606 (setq dir (match-string 1 command))
607 (setq command (replace-match "" t t command)))
608 (setq dir (expand-file-name dir))
609 (with-current-buffer (sml-proc-buffer)
610 (setq default-directory dir)
611 (sml-send-string (concat (format sml-cd-command dir) "; " command) t t))))
613 ;;; PARSING ERROR MESSAGES
615 ;; This should need no modification to support other compilers.
617 ;; Update the buffer-local error-cursor in proc-buffer to be its
618 ;; current proc mark.
620 (defvar sml-endof-error-alist nil)
622 (defun sml-update-cursor ()
623 ;; Update buffer local variable.
624 (set-marker sml-error-cursor (1- (process-mark (sml-proc))))
625 (setq sml-endof-error-alist nil)
626 (compilation-forget-errors)
627 (if (fboundp 'compilation-fake-loc)
628 (compilation-fake-loc (cdr sml-temp-file) (car sml-temp-file)))
629 (if (markerp compilation-parsing-end)
630 (set-marker compilation-parsing-end sml-error-cursor)
631 (setq compilation-parsing-end sml-error-cursor)))
633 (defun sml-make-error (f c)
634 (let ((err (point-marker))
635 (linenum (string-to-number c))
636 (filename (list (first f) (second f)))
637 (column (string-to-number (match-string (third f)))))
638 ;; record the end of error, if any
640 (let ((endlinestr (match-string (fourth f))))
642 (let* ((endline (string-to-number endlinestr))
643 (endcol (string-to-number
644 (or (match-string (fifth f)) "0")))
645 (linediff (- endline linenum)))
646 (push (list err linediff (if (= 0 linediff) (- endcol column) endcol))
647 sml-endof-error-alist)))))
648 ;; build the error descriptor
649 (if (string= (car sml-temp-file) (first f))
650 ;; special case for code sent via sml-send-region
651 (let ((marker (cdr sml-temp-file)))
652 (with-current-buffer (marker-buffer marker)
654 (forward-line (1- linenum))
655 (forward-char (1- column))
656 ;; A pair of markers is the right thing to return, but some
657 ;; code in compile.el doesn't like it (when we reach the end
658 ;; of the errors). So we could try to avoid it, but we don't
659 ;; because that doesn't work correctly if the current buffer
660 ;; has unsaved modifications. And it's fixed in Emacs-21.
661 ;; (if buffer-file-name
662 ;; (list err buffer-file-name
663 ;; (count-lines (point-min) (point)) (current-column))
664 (cons err (point-marker)))) ;; )
665 ;; taken from compile.el
666 (list err filename linenum column))))
668 (unless (fboundp 'compilation-fake-loc)
669 (defadvice compilation-goto-locus (after sml-endof-error activate)
670 (let* ((next-error (ad-get-arg 0))
671 (err (car next-error))
672 (pos (cdr next-error))
673 (endof (with-current-buffer (marker-buffer err)
674 (assq err sml-endof-error-alist))))
675 (if (not endof) (sml-error-overlay 'undo)
676 (with-current-buffer (marker-buffer pos)
678 (let ((linediff (second endof))
679 (coldiff (third endof)))
680 (when (> 0 linediff) (forward-line linediff))
681 (forward-char coldiff))
682 (sml-error-overlay nil pos (point))
683 (push-mark nil t (not sml-error-overlay))
686 (defun sml-error-overlay (undo &optional beg end)
687 "Move `sml-error-overlay' to the text region in the current buffer.
688 If the buffer-local variable `sml-error-overlay' is
689 non-nil it should be an overlay \(or extent, in XEmacs speak\)\; this
690 function moves the overlay over the current region. If the optional
691 BUFFER argument is given, move the overlay in that buffer instead of
694 Called interactively, the optional prefix argument UNDO indicates that
695 the overlay should simply be removed: \\[universal-argument] \
696 \\[sml-error-overlay]."
698 (when sml-error-overlay
699 (unless (overlayp sml-error-overlay)
700 (let ((ol sml-error-overlay))
701 (setq sml-error-overlay (make-overlay 0 0))
702 (overlay-put sml-error-overlay 'face (if (symbolp ol) ol 'region))))
703 (if undo (move-overlay sml-error-overlay 1 1 (current-buffer))
704 ;; if active regions, signals mark not active if no region set
705 (let ((beg (or beg (region-beginning)))
706 (end (or end (region-end))))
707 (move-overlay sml-error-overlay beg end (current-buffer))))))
711 ;;; sml-proc.el ends here