1 ;;; sml-proc.el. Comint based interaction mode for Standard ML.
3 ;; Copyright (C) 1989, Lars Bo Nielsen, 1994,1997 Matthew J. Morley
8 ;; ====================================================================
10 ;; This file is not part of GNU Emacs, but it is distributed under the
13 ;; This program is free software; you can redistribute it and/or
14 ;; modify it under the terms of the GNU General Public License as
15 ;; published by the Free Software Foundation; either version 2, or (at
16 ;; your option) any later version.
18 ;; This program is distributed in the hope that it will be useful, but
19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 ;; General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 0139, USA.
26 ;; (See sml-mode.el for HISTORY.)
28 ;; ====================================================================
30 ;; [MJM 10/94] Separating this from sml-mode means sml-mode will run
31 ;; under 18.59 (or anywhere without comint, if there are such places).
32 ;; See sml-mode.el for further information.
36 ;; Inferior-sml-mode is for interacting with an ML process run under
37 ;; emacs. This uses the comint package so you get history, expansion,
38 ;; backup and all the other benefits of comint. Interaction is
39 ;; achieved by M-x sml which starts a sub-process under emacs. You may
40 ;; need to set this up for autoloading in your .emacs:
42 ;; (autoload 'sml "sml-proc" "Run an inferior ML process." t)
44 ;; Exactly what process is governed by the variable sml-program-name
45 ;; -- just "sml" by default. If you give a prefix argument (C-u M-x
46 ;; sml) you will be prompted for a different program to execute from
47 ;; the default -- if you just hit RETURN you get the default anyway --
48 ;; along with the option to specify any command line arguments. Once
49 ;; you select the ML program name in this manner, it remains the
50 ;; default (unless you set in a hook, or otherwise).
52 ;; NOTE: inferior-sml-mode-hook is run AFTER the ML program has been
53 ;; launched. inferior-sml-load-hook is run only when sml-proc.el is
56 ;; When running an ML process some further key-bindings are effective
57 ;; in sml-mode buffer(s). C-c C-s (switch-to-sml) will split the
58 ;; screen into two windows if necessary and place you in the ML
59 ;; process buffer. In the interaction buffer, C-c C-s is bound to the
60 ;; `sml' command by default (in case you need to restart).
62 ;; C-c C-l (sml-load-file) will load an SML source file into the
63 ;; inferior process, C-c C-r (sml-send-region) will send the current
64 ;; region of text to the ML process, etc. Given a prefix argument to
65 ;; these commands will switch you from the SML buffer to the ML
66 ;; process buffer as well as sending the text. If you get errors
67 ;; reported by the compiler, C-c ` (sml-next-error) will step through
68 ;; the errors with you.
70 ;; NOTE. There is only limited support for this as it obviously
71 ;; depends on the compiler's error messages being recognised by the
72 ;; mode. Error reporting is currently only geared up for SML/NJ,
73 ;; Moscow ML, and Poly/ML (see file sml-{mosml,poly-ml}.el). Look at
74 ;; the documentation for sml-error-parser and sml-next-error -- you
75 ;; may only need to modify the former to recover this feature for some
76 ;; other ML systems, along with sml-error-regexp.
78 ;; While small pieces of text can be fed quite happily into the ML
79 ;; process directly, lager pieces should (probably) be sent via a
80 ;; temporary file making use of the compiler's "use" command.
82 ;; CURRENT RATIONALE: you get sense out of the error messages if
83 ;; there's a real file associated with a block of code, and XEmacs is
84 ;; less likely to hang. These are likely to change.
86 ;; For more information see the variable sml-temp-threshold. You
87 ;; should set the variable sml-use-command appropriately for your ML
88 ;; compiler. By default things are set up to work for the SML/NJ
93 ;; Here are some ideas for inferior-sml-*-hooks:
95 ;; (setq inferior-sml-load-hook
96 ;; '(lambda() "Set global defaults for inferior-sml-mode"
97 ;; (define-key inferior-sml-mode-map "\C-cd" 'sml-cd)
98 ;; (define-key sml-mode-map "\C-cd" 'sml-cd)
99 ;; (define-key sml-mode-map "\C-c\C-f" 'sml-send-function)
100 ;; (setq sml-temp-threshold 0))) ; safe: always use tmp file
102 ;; (setq inferior-sml-mode-hook
103 ;; '(lambda() "Inferior SML mode defaults"
104 ;; (setq comint-scroll-show-maximum-output t
105 ;; comint-scroll-to-bottom-on-output t
106 ;; comint-input-autoexpand nil)))
108 ;; ===================================================================
110 ;;; INFERIOR ML MODE VARIABLES
116 (defvar sml-program-name "sml"
117 "*Program to run as ML.")
119 (defvar sml-default-arg ""
120 "*Default command line option to pass, if any.")
122 (defvar sml-make-command "CM.make()"
123 "The command used by default by `sml-make'.")
125 (defvar sml-make-file-name "sources.cm"
126 "The name of the makefile that `sml-make' will look for (if non-nil).")
128 ;;(defvar sml-raise-on-error nil
129 ;; "*When non-nil, `sml-next-error' will raise the ML process's frame.")
131 (defvar sml-temp-threshold 0
132 "*Controls when emacs uses temporary files to communicate with ML.
133 If not a number (e.g., NIL), then emacs always sends text directly to
134 the subprocess. If an integer N, then emacs uses a temporary file
135 whenever the text is longer than N chars. `sml-temp-file' contains the
136 name of the temporary file for communicating. See variable
137 `sml-use-command' and function `sml-send-region'.
139 Sending regions directly through the pty (not using temp files)
140 doesn't work very well -- e.g., SML/NJ nor Poly/ML incorrectly report
141 the line # of errors occurring in std_in.")
143 (defvar sml-temp-file
145 (concat (file-name-as-directory (or (getenv "TMPDIR") "/tmp")) "/ml"))
146 "*Temp file that emacs uses to communicate with the ML process.
147 See `sml-temp-threshold'. Defaults to \(make-temp-name \"/tmp/ml\"\)")
149 (defvar inferior-sml-mode-hook nil
150 "*This hook is run when the inferior ML process is started.
151 All buffer local customisations for the interaction buffers go here.")
153 (defvar inferior-sml-load-hook nil
154 "*Hook run when inferior-sml-mode (sml-proc.el) is loaded into Emacs.
155 This is a good place to put your preferred key bindings.")
157 (defvar sml-buffer nil
158 "*The current ML process buffer.
160 MULTIPLE PROCESS SUPPORT (Whoever wants multi-process support anyway?)
161 =====================================================================
162 sml-mode supports, in a fairly simple fashion, running multiple ML
163 processes. To run multiple ML processes, you start the first up with
164 \\[sml]. It will be in a buffer named *sml*. Rename this buffer with
165 \\[rename-buffer]. You may now start up a new process with another
166 \\[sml]. It will be in a new buffer, named *sml*. You can switch
167 between the different process buffers with \\[switch-to-buffer].
169 NB *sml* is just the default name for the buffer. It actually gets
170 it's name from the value of `sml-program-name' -- *poly*, *smld*,...
172 If you have more than one ML process around, commands that send text
173 from source buffers to ML processes -- like `sml-send-function' or
174 `sml-send-region' -- have to choose a process to send it to. This is
175 determined by the global variable `sml-buffer'. Suppose you have three
176 inferior ML's running:
179 mosml #<process mosml>
180 *sml* #<process sml<2>>
181 If you do a \\[sml-send-function] command on some ML source code,
182 what process do you send it to?
184 - If you're in a process buffer (sml, mosml, or *sml*), you send it to
185 that process (usually makes sense only to `sml-load-file').
186 - If you're in some other buffer (e.g., a source file), you send it to
187 the process attached to buffer `sml-buffer'.
189 This process selection is performed by function `sml-proc' which looks
190 at the value of `sml-buffer' -- which must be a lisp buffer object, or
193 Whenever \\[sml] fires up a new process, it resets `sml-buffer' to be
194 the new process's buffer. If you only run one process, this will do
195 the right thing. If you run multiple processes, you can change
196 `sml-buffer' to another process buffer with \\[set-variable], or
197 use the command \\[sml-buffer] in the interaction buffer of choice.")
200 ;;; ALL STUFF THAT DEFAULTS TO THE SML/NJ COMPILER (0.93)
202 (defvar sml-use-command "use \"%s\""
203 "*Template for loading a file into the inferior ML process.
204 Set to \"use \\\"%s\\\"\" for SML/NJ or Edinburgh ML;
205 set to \"PolyML.use \\\"%s\\\"\" for Poly/ML, etc.")
207 (defvar sml-cd-command "OS.FileSys.chDir \"%s\""
208 "*Command template for changing working directories under ML.
209 Set this to nil if your compiler can't change directories.
211 The format specifier \"%s\" will be converted into the directory name
212 specified when running the command \\[sml-cd].")
214 (defvar sml-prompt-regexp "^[\-=] *"
215 "*Regexp used to recognise prompts in the inferior ML process.")
217 (defvar sml-error-parser 'sml-smlnj-error-parser
218 "*This function parses an error message into a 3-5 element list:
220 \(file start-line start-col end-line-col err-msg\).
222 The first three components are required by `sml-next-error', but the other
223 two are optional. If the file associated with the input is the standard
224 input stream, this function should probably return
226 \(\"std_in\" start-line start-col\).
228 This function will be called in a context in which the match data \(see
229 `match-data'\) are current for `sml-error-regexp'. The mode sets the
230 default value to the function `sml-smlnj-error-parser'.
232 In a step towards greater sml-mode modularity END-LINE-COL can be either
234 - the symbol nil \(in which case it is ignored\)
238 - an Emacs Lisp expression that when `eval'd at \(start-line,start-col\)
239 will move point to the end of the errorful text in the file.
241 Note that the compiler should return the full path name of the errorful
242 file, and that this might require you to fiddle with the compiler's
243 prettyprinting switches.")
245 ;; std_in:2.1-4.3 Error: operator and operand don't agree (tycon mismatch)
246 ;; std_in:2.1 Error: operator and operand don't agree (tycon mismatch)
248 (defconst sml-smlnj-error-regexp
250 "^[-= ]*\\(.+\\):" ;file name
251 "\\([0-9]+\\)\\.\\([0-9]+\\)" ;start line.column
252 "\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)?" ;end line.colum
253 ".+\\(\\(Error\\|Warning\\): .*\\)") ;the message
255 "Default regexp matching SML/NJ error and warning messages.
257 There should be no need to customise this, though you might decide
258 that you aren't interested in Warnings -- my advice would be to modify
259 `sml-error-regexp' explicitly to do that though.
261 If you do customise `sml-smlnj-error-regexp' you may need to modify
262 the function `sml-smlnj-error-parser' (qv).")
264 (defvar sml-error-regexp sml-smlnj-error-regexp
265 "*Regexp for matching \(the start of\) an error message.")
268 (defvar inferior-sml-font-lock-keywords
269 `((,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
270 (1 font-lock-prompt-face)
271 (2 font-lock-command-face keep))
272 (,sml-error-regexp . font-lock-warning-face)
273 ("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face)
274 ("^GC #.*" . font-lock-comment-face)))
276 ;; default faces values
277 (defvar font-lock-prompt-face
278 (if (facep 'font-lock-prompt-face)
279 'font-lock-prompt-face
280 'font-lock-keyword-face))
281 (defvar font-lock-command-face
282 (if (facep 'font-lock-command-face)
283 'font-lock-command-face
284 'font-lock-function-name-face))
286 (defvar inferior-sml-font-lock-defaults
287 '(inferior-sml-font-lock-keywords nil nil nil nil))
289 (defun sml-smlnj-error-parser (pt)
290 "This parses the SML/NJ error message at PT into a 5 element list
292 \(file start-line start-col end-of-err msg\)
294 where FILE is the file in which the error occurs\; START-LINE is the line
295 number in the file where the error occurs\; START-COL is the character
296 position on that line where the error occurs.
298 If present, the fourth return value is a simple Emacs Lisp expression that
299 will move point to the end of the errorful text, assuming that point is at
300 \(start-line,start-col\) to begin with\; and MSG is the text of the error
301 message given by the compiler."
303 ;; This function uses `sml-smlnj-error-regexp' to do the parsing, and
304 ;; assumes that regexp groups 1, 2, and 3 correspond to the first three
305 ;; elements of the list returned\; and groups 5, 6 and 7 correspond to the
306 ;; optional elements in that order.
310 (if (not (looking-at sml-smlnj-error-regexp))
311 ;; the user loses big time.
313 (let ((file (match-string 1)) ; the file
314 (slin (string-to-int (match-string 2))) ; the start line
315 (scol (string-to-int (match-string 3))) ; the start col
316 (msg (if (match-beginning 7) (match-string 7))))
317 ;; another loss: buggy sml/nj's produce nonsense like file:0.0 Error
318 (if (zerop slin) (list file nil scol)
319 ;; ok, was a range of characters mentioned?
320 (if (match-beginning 4)
321 ;; assume m-b 4 implies m-b 5 and m-b 6 (sml-smlnj-error-regexp)
322 (let* ((elin (string-to-int (match-string 5))) ; end line
323 (ecol (string-to-int (match-string 6))) ; end col
324 (jump (if (= elin slin)
325 ;; move forward on the same line
326 `(forward-char ,(1+ (- ecol scol)))
327 ;; otherwise move down, and over to ecol
329 (forward-line ,(- elin slin))
330 (forward-char ,ecol)))))
331 ;; nconc glues lists together. jump & msg aren't lists
332 (nconc (list file slin scol) (list jump) (list msg)))
333 (nconc (list file slin scol) (list nil) (list msg))))))))
335 (defun sml-smlnj (pfx)
336 "Set up and run Standard ML of New Jersey.
337 Prefix argument means accept the defaults below.
339 Note: defaults set here will be clobbered if you setq them in the
340 inferior-sml-mode-hook.
342 sml-program-name <option> \(default \"sml\"\)
343 sml-default-arg <option> \(default \"\"\)
344 sml-use-command \"use \\\"%s\\\"\"
345 sml-cd-command \"OS.FileSys.chDir \\\"%s\\\"\"
346 sml-prompt-regexp \"^[\\-=] *\"
347 sml-error-regexp sml-sml-nj-error-regexp
348 sml-error-parser 'sml-sml-nj-error-parser"
350 (let ((cmd (if pfx "sml"
351 (read-string "Command name: " sml-program-name)))
353 (read-string "Any arguments or options (default none): "))))
354 ;; sml-mode global variables
355 (setq sml-program-name cmd)
356 (setq sml-default-arg arg)
357 ;; buffer-local (compiler-local) variables
358 (setq-default sml-use-command "use \"%s\""
359 sml-cd-command "OS.FileSys.chDir \"%s\""
360 sml-prompt-regexp "^[\-=] *"
361 sml-error-regexp sml-smlnj-error-regexp
362 sml-error-parser 'sml-smlnj-error-parser)
363 (sml-run cmd sml-default-arg)))
368 (defvar inferior-sml-mode-map nil)
372 (defvar sml-error-file nil) ; file from which the last error came
373 (defvar sml-real-file nil) ; used for finding source errors
374 (defvar sml-error-cursor nil) ; ditto
376 (defun sml-proc-buffer ()
377 "Returns the current ML process buffer,
378 or the current buffer if it is in `inferior-sml-mode'. Raises an error
379 if the variable `sml-buffer' does not appear to point to an existing
382 (cond ((eq major-mode 'inferior-sml-mode)
383 ;; default to current buffer if it's in inferior-sml-mode
385 ((bufferp sml-buffer)
386 ;; buffer-name returns nil if the buffer has been killed
387 (buffer-name sml-buffer))
388 ((stringp sml-buffer)
389 ;; get-buffer returns nil if there's no buffer of that name
390 (get-buffer sml-buffer)))))
392 (error "No current process buffer. See variable sml-buffer"))))
395 "Returns the current ML process. See variable `sml-buffer'."
396 (let ((proc (get-buffer-process (sml-proc-buffer))))
398 (error "No current process. See variable sml-buffer"))))
400 (defun sml-buffer (echo)
401 "Make the current buffer the current `sml-buffer' if that is sensible.
402 Lookup variable `sml-buffer' to see why this might be useful."
405 (cond ((bufferp sml-buffer) (or (buffer-name sml-buffer) "undefined"))
406 ((stringp sml-buffer) sml-buffer)
408 (if echo (message (format "ML process buffer is %s." current))
409 (let ((buffer (if (eq major-mode 'inferior-sml-mode) (current-buffer))))
410 (if (not buffer) (message (format "ML process buffer is %s." current))
411 (setq sml-buffer buffer)
412 (message (format "ML process buffer is %s." (buffer-name buffer))))))))
415 "Nil iff `sml-proc' returns a process."
416 (condition-case nil (progn (sml-proc) nil) (error t)))
418 (defun sml-proc-tidy ()
419 "Something to add to `kill-emacs-hook' to tidy up tmp files on exit."
420 (if (file-readable-p sml-temp-file)
421 (delete-file sml-temp-file)))
423 (defun inferior-sml-mode ()
424 "Major mode for interacting with an inferior ML process.
426 The following commands are available:
427 \\{inferior-sml-mode-map}
429 An ML process can be fired up (again) with \\[sml].
431 Customisation: Entry to this mode runs the hooks on `comint-mode-hook'
432 and `inferior-sml-mode-hook' (in that order).
434 Variables controlling behaviour of this mode are
436 `sml-program-name' (default \"sml\")
437 Program to run as ML.
439 `sml-use-command' (default \"use \\\"%s\\\"\")
440 Template for loading a file into the inferior ML process.
442 `sml-cd-command' (default \"System.Directory.cd \\\"%s\\\"\")
443 ML command for changing directories in ML process (if possible).
445 `sml-prompt-regexp' (default \"^[\\-=] *\")
446 Regexp used to recognise prompts in the inferior ML process.
448 `sml-temp-threshold' (default 0)
449 Controls when emacs uses temporary files to communicate with ML.
450 If an integer N, then emacs uses a temporary file whenever the
451 text is longer than N chars.
453 `sml-temp-file' (default (make-temp-name \"/tmp/ml\"))
454 Temp file that emacs uses to communicate with the ML process.
457 (default -- complicated)
458 Regexp for matching error messages from the compiler.
460 `sml-error-parser' (default 'sml-smlnj-error-parser)
461 This function parses a error messages into a 3, 4 or 5 element list:
462 (file start-line start-col (end-line end-col) err-msg).
464 You can send text to the inferior ML process from other buffers containing
466 `switch-to-sml' switches the current buffer to the ML process buffer.
467 `sml-send-function' sends the current *paragraph* to the ML process.
468 `sml-send-region' sends the current region to the ML process.
470 Prefixing the sml-send-<whatever> commands with \\[universal-argument]
471 causes a switch to the ML process buffer after sending the text.
473 For information on running multiple processes in multiple buffers, see
474 documentation for variable `sml-buffer'.
477 RET after the end of the process' output sends the text from the
478 end of process to point.
479 RET before the end of the process' output copies the current line
480 to the end of the process' output, and sends it.
481 DEL converts tabs to spaces as it moves back.
482 TAB file name completion, as in shell-mode, etc.."
484 (kill-all-local-variables)
486 (setq comint-prompt-regexp sml-prompt-regexp)
489 ;; For sequencing through error messages:
491 (set (make-local-variable 'sml-error-cursor) (point-max-marker))
492 (set (make-local-variable 'sml-real-file) nil)
493 (set (make-local-variable 'font-lock-defaults)
494 inferior-sml-font-lock-defaults)
496 (make-local-variable 'sml-use-command)
497 (make-local-variable 'sml-cd-command)
498 (make-local-variable 'sml-prompt-regexp)
499 (make-local-variable 'sml-error-parser)
500 (make-local-variable 'sml-error-regexp)
502 (setq major-mode 'inferior-sml-mode)
503 (setq mode-name "Inferior ML")
504 (setq mode-line-process '(": %s"))
505 (use-local-map inferior-sml-mode-map)
506 (add-hook 'kill-emacs-hook 'sml-proc-tidy)
508 (run-hooks 'inferior-sml-mode-hook))
510 ;;; FOR RUNNING ML FROM EMACS
513 (defun run-sml (&optional pfx)
514 "Run an inferior ML process, input and output via buffer *sml*.
515 With a prefix argument, this command allows you to specify any command
516 line options to pass to the complier. The command runs hook functions
517 on `comint-mode-hook' and `inferior-sml-mode-hook' in that order.
519 If there is a process already running in *sml*, just switch to that
522 In fact the name of the buffer created is chosen to reflect the name
523 of the program name specified by `sml-program-name', or entered at the
524 prompt. You can have several inferior ML process running, but only one
525 current one -- given by `sml-buffer' (qv).
527 \(Type \\[describe-mode] in the process buffer for a list of commands.)"
530 (read-string "ML command: " sml-program-name)
533 (read-string "Any args: " sml-default-arg)
537 (defun sml-run (cmd arg)
538 "Run the ML program CMD with given arguments ARGS.
539 This usually updates `sml-buffer' to a buffer named *CMD*."
540 (let* ((pname (file-name-nondirectory cmd))
541 (bname (format "*%s*" pname))
542 (args (if (equal arg "") () (sml-args-to-list arg))))
543 (if (comint-check-proc bname)
544 (pop-to-buffer (sml-proc-buffer)) ;do nothing but switch buffer
547 ;; there is a good reason for this; to ensure
548 ;; *no* argument is sent, not even a "".
549 (set-buffer (apply 'make-comint pname cmd nil))
550 (set-buffer (apply 'make-comint pname cmd nil args))))
551 (message (format "Starting \"%s\" in background." pname))
553 (goto-char (point-max))
554 ;; and this -- to keep these as defaults even if
555 ;; they're set in the mode hooks.
556 (setq sml-program-name cmd)
557 (setq sml-default-arg arg))))
559 (defun sml-args-to-list (string)
560 (let ((where (string-match "[ \t]" string)))
561 (cond ((null where) (list string))
563 (cons (substring string 0 where)
564 (sml-args-to-list (substring string (+ 1 where)
566 (t (let ((pos (string-match "[^ \t]" string)))
569 (sml-args-to-list (substring string pos
570 (length string)))))))))
572 (defun sml-temp-threshold (&optional thold)
573 "Set the variable to the given prefix (nil, if no prefix given).
574 This is really mainly here to help debugging sml-mode!"
576 (setq sml-temp-threshold
577 (if current-prefix-arg (prefix-numeric-value thold)))
578 (message "%s" sml-temp-threshold))
581 (defun switch-to-sml (eob-p)
582 "Switch to the ML process buffer.
583 With prefix argument, positions cursor at point, otherwise at end of buffer."
585 (if (sml-noproc) (save-excursion (run-sml t)))
586 (pop-to-buffer (sml-proc-buffer))
588 (push-mark (point) t)
589 (goto-char (point-max)))))
591 ;; Fakes it with a "use <temp-file>;" if necessary.
594 (defun sml-send-region (start end &optional and-go)
595 "Send current region to the inferior ML process.
596 Prefix argument means switch-to-sml afterwards.
598 If the region is longer than `sml-temp-threshold' and the variable
599 `sml-use-command' is defined, the region is written out to a temporary file
600 and a \"use <temp-file>\" command is sent to the compiler\; otherwise the
601 text in the region is sent directly to the compiler. In either case a
602 trailing \"\;\\n\" will be added automatically.
604 See variables `sml-temp-threshold', `sml-temp-file' and `sml-use-command'."
606 (if (sml-noproc) (save-excursion (run-sml t)))
607 (cond ((equal start end)
608 (message "The region is zero (ignored)"))
609 ((and sml-use-command
610 (numberp sml-temp-threshold)
611 (< sml-temp-threshold (- end start)))
612 ;; Just in case someone is still reading from sml-temp-file:
613 (if (file-exists-p sml-temp-file)
614 (delete-file sml-temp-file))
615 (write-region start end sml-temp-file nil 'silently)
616 (sml-update-barrier (buffer-file-name (current-buffer)) start)
617 (sml-update-cursor (sml-proc-buffer))
618 (comint-send-string (sml-proc)
619 (concat (format sml-use-command sml-temp-file) ";\n")))
621 (comint-send-region (sml-proc) start end)
622 (comint-send-string (sml-proc) ";\n")))
623 (if and-go (switch-to-sml nil)))
625 ;; Update the buffer-local variables sml-real-file
626 ;; in the process buffer:
628 (defun sml-update-barrier (&optional file pos)
629 (let ((buf (current-buffer)))
631 (let* ((proc (sml-proc))
632 (pmark (marker-position (process-mark proc))))
633 (set-buffer (process-buffer proc))
634 ;; update buffer local variables
635 (setq sml-real-file (and file (cons file pos))))
638 ;; Update the buffer-local error-cursor in proc-buffer to be its
639 ;; current proc mark.
641 (defun sml-update-cursor (proc-buffer) ;always= sml-proc-buffer
642 (let ((buf (current-buffer)))
644 (let* ((proc (sml-proc)) ;just in case?
645 (pmark (marker-position (process-mark proc))))
646 (set-buffer proc-buffer)
647 ;; update buffer local variable
648 (set-marker sml-error-cursor pmark))
651 ;; This is quite bogus, so it isn't bound to a key by default.
652 ;; Anyone coming up with an algorithm to recognise fun & local
653 ;; declarations surrounding point will do everyone a favour!
655 (defun sml-send-function (&optional and-go)
656 "Send current paragraph to the inferior ML process.
657 With a prefix argument switch to the sml buffer as well
658 \(cf. `sml-send-region'\)."
662 (sml-send-region (point) (mark)))
663 (if and-go (switch-to-sml nil)))
666 (defun sml-send-buffer (&optional and-go)
667 "Send buffer to inferior shell running ML process.
668 With a prefix argument switch to the sml buffer as well
669 \(cf. `sml-send-region'\)."
671 (if (memq major-mode sml-source-modes)
672 (sml-send-region (point-min) (point-max) and-go)))
674 ;; Since sml-send-function/region take an optional prefix arg, these
675 ;; commands are redundant. But they are kept around for the user to
676 ;; bind if she wishes, since its easier to type C-c r than C-u C-c C-r.
678 (defun sml-send-region-and-go (start end)
679 "Send current region to the inferior ML process, and go there."
681 (sml-send-region start end t))
683 (defun sml-send-function-and-go ()
684 "Send current paragraph to the inferior ML process, and go there."
686 (sml-send-function t))
689 ;;; Mouse control and handling dedicated frames for Inferior ML
691 ;; simplified from frame.el in Emacs: special-display-popup-frame...
693 (defun sml-proc-frame ()
694 "Returns the current ML process buffer's frame, or creates one first."
695 (let ((buffer (sml-proc-buffer)))
696 (window-frame (display-buffer buffer))))
698 ;;(defun sml-pop-to-buffer (warp)
699 ;; "(Towards) handling multiple frames properly.
700 ;;Raises the frame, and warps the mouse over there, only if WARP is non-nil."
701 ;; (let ((current (window-frame (selected-window)))
702 ;; (buffer (sml-proc-buffer)))
703 ;; (let ((frame (sml-proc-frame)))
704 ;; (if (eq current frame)
705 ;; (pop-to-buffer buffer) ; stay on the same frame.
706 ;; (select-frame frame) ; XEmacs sometimes moves focus.
707 ;; (select-window (get-buffer-window buffer)) ; necc. for XEmacs
708 ;; ;; (raise-frame frame)
709 ;; (if warp (sml-warp-mouse frame))))))
712 ;;; H A C K A T T A C K ! X E M A C S V E R S U S E M A C S
714 ;; Only these two functions have to dance around the inane differences
715 ;; between Emacs and XEmacs (fortunately)
717 (defun sml-warp-mouse (frame)
718 "Warp the pointer across the screen to upper right corner of FRAME."
720 (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)
721 ;; LUCID (19.10) or later... set-m-pos needs a WINDOW
722 (set-mouse-position (frame-root-window frame) (1- (frame-width)) 0))
724 ;; GNU, post circa 19.19... set-m-pos needs a FRAME
725 (set-mouse-position frame (1- (frame-width)) 0)
726 ;; probably not needed post 19.29
727 (if (fboundp 'unfocus-frame) (unfocus-frame)))))
729 (defun sml-drag-region (event)
730 "Highlight the text the mouse is dragged over, and send it to ML.
731 This must be bound to a button-down mouse event, currently \\[sml-drag-region].
733 If you drag the mouse (ie, keep the mouse button depressed) the
734 program text sent to the complier is delimited by where you started
735 dragging the mouse, and where you release the mouse button.
737 If you only click the mouse, the program text sent to the compiler is
738 delimited by the current position of point and the place where you
741 In either event, the values of both point and mark are left
742 undisturbed once this operation is completed."
744 (let ((mark-ring) ;BAD: selection start gets cons'd
745 (pmark (point))) ;where point is now
746 (if (fboundp 'mouse-track-default)
747 ;; Assume this is XEmacs, otherwise assume its Emacs
749 (let ((zmacs-regions))
750 (set-marker (mark-marker) nil)
751 (mouse-track-default event)
752 (if (not (region-exists-p)) (push-mark pmark nil t))
753 (call-interactively 'sml-send-region)))
754 ;; Emacs: making this buffer-local ought to happen in sml-mode
755 (make-local-variable 'transient-mark-mode)
757 (let ((transient-mark-mode 1))
758 (mouse-drag-region event)
759 (if (not mark-active) (push-mark pmark nil t))
760 (call-interactively 'sml-send-region))))))
763 ;;; LOADING AND IMPORTING SOURCE FILES:
765 (defvar sml-source-modes '(sml-mode)
766 "*Used to determine if a buffer contains ML source code.
767 If it's loaded into a buffer that is in one of these major modes, it's
768 considered an ML source file by `sml-load-file'. Used by these commands
769 to determine defaults.")
771 (defvar sml-prev-l/c-dir/file nil
772 "Caches the (directory . file) pair used in the last `sml-load-file'
773 or `sml-cd' command. Used for determining the default in the next one.")
776 (defun sml-load-file (&optional and-go)
777 "Load an ML file into the current inferior ML process.
778 With a prefix argument switch to sml buffer as well.
780 This command uses the ML command template `sml-use-command' to construct
781 the command to send to the ML process\; a trailing \"\;\\n\" will be added
784 (if (sml-noproc) (save-excursion (run-sml t)))
787 (car (comint-get-source "Load ML file: " sml-prev-l/c-dir/file
788 sml-source-modes t))))
789 ;; Check if buffer needs saved. Should (save-some-buffers) instead?
790 (comint-check-source file)
791 (setq sml-prev-l/c-dir/file
792 (cons (file-name-directory file) (file-name-nondirectory file)))
793 (sml-update-cursor (sml-proc-buffer))
795 (sml-proc) (concat (format sml-use-command file) ";\n")))
796 (message "Can't load files if `sml-use-command' is undefined!"))
797 (if and-go (switch-to-sml nil)))
800 "Change the working directory of the inferior ML process.
801 The default directory of the process buffer is changed to DIR. If the
802 variable `sml-cd-command' is non-nil it should be an ML command that will
803 be executed to change the compiler's working directory\; a trailing
804 \"\;\\n\" will be added automatically."
805 (interactive "DSML Directory: ")
806 (let* ((buf (sml-proc-buffer))
807 (proc (get-buffer-process buf))
808 (dir (expand-file-name dir))
809 (string (concat (format sml-cd-command dir) ";\n")))
812 (goto-char (point-max))
814 (set-marker (process-mark proc) (point))
815 (if sml-cd-command (process-send-string proc string))
817 (setq sml-prev-l/c-dir/file (cons dir nil))))
819 (defun sml-send-command (cmd &optional dir print)
820 "Send string to ML process, display this string in ML's buffer"
821 (if (sml-noproc) (save-excursion (run-sml t)))
822 (let* ((my-dir (or dir (expand-file-name default-directory)))
823 (cd-cmd (if my-dir (concat (format sml-cd-command my-dir) "; ") ""))
824 (buf (sml-proc-buffer))
825 (win (get-buffer-window buf 'visible))
826 (proc (get-buffer-process buf))
827 (string (concat cd-cmd cmd ";\n")))
828 (save-some-buffers t)
831 (when win (select-window win))
832 (goto-char (point-max))
833 (when print (insert string))
834 (when my-dir (cd my-dir))
835 (sml-update-cursor buf)
837 (set-marker (process-mark proc) (point-max))
838 (comint-send-string proc string))
841 (defun sml-make (command)
842 "re-make a system using (by default) CM.
843 The exact command used can be specified by providing a prefix argument."
845 ;; code taken straight from compile.el
846 (if (or current-prefix-arg (not sml-make-command))
847 (list (read-from-minibuffer "Compile command: "
848 sml-make-command nil nil
849 '(compile-history . 1)))
850 (list sml-make-command)))
851 (setq sml-make-command command)
852 ;; try to find a makefile up the sirectory tree
853 (let ((dir (and sml-make-file-name (expand-file-name default-directory))))
854 (while (and dir (not (file-exists-p (concat dir sml-make-file-name))))
855 (let ((newdir (file-name-directory (directory-file-name dir))))
856 (setq dir (if (equal newdir dir) nil newdir))))
857 (sml-send-command command dir t)))
859 ;;; PARSING ERROR MESSAGES
861 ;; This should need no modification to support other compilers.
864 (defun sml-next-error (skip)
865 "Find the next error by parsing the inferior ML buffer.
866 A prefix argument means `sml-skip-errors' (qv) instead.
868 Move the error message on the top line of the window\; put the cursor
869 \(point\) at the beginning of the error source.
871 If the error message specifies a range, and `sml-error-parser' returns
872 the range, the mark is placed at the end of the range. If the variable
873 `sml-error-overlay' is non-nil, the region will also be highlighted.
875 If `sml-error-parser' returns a fifth component this is assumed to be
876 a string to indicate the nature of the error: this will be echoed in
879 Error interaction only works if there is a real file associated with
880 the input -- though of course it also depends on the compiler's error
881 messages \(also see documantation for `sml-error-parser'\).
883 However: if the last text sent went via `sml-load-file' (or the temp
884 file mechanism), the next error reported will be relative to the start
885 of the region sent, any error reports in the previous output being
886 forgotten. If the text went directly to the compiler the succeeding
887 error reported will be the next error relative to the location \(in
888 the output\) of the last error. This odd behaviour may have a use...?"
890 (if skip (sml-skip-errors) (sml-do-next-error)))
892 (defun sml-bottle (msg)
893 "Function to let `sml-next-error' give up gracefully."
894 (sml-warp-mouse (selected-frame))
897 (defun sml-do-next-error ()
898 "The buisiness end of `sml-next-error' (qv)"
899 (let ((case-fold-search nil)
900 ;; set this variable iff we called sml-next-error in a SML buffer
901 (sml-window (if (memq major-mode sml-source-modes) (selected-window)))
902 (proc-buffer (sml-proc-buffer)))
903 ;; undo (don't destroy) the previous overlay to be tidy
904 (sml-error-overlay 'undo 1 1
905 (and sml-error-file (get-file-buffer sml-error-file)))
906 ;; go to interaction buffer but don't raise it's frame
907 (pop-to-buffer (sml-proc-buffer))
908 ;; go to the last remembered error, and search for the next one.
909 (goto-char (marker-position sml-error-cursor))
910 (if (not (re-search-forward sml-error-regexp (point-max) t))
911 ;; no more errors -- move point to the sml prompt at the end
913 (goto-char (point-max))
914 (if sml-window (select-window sml-window)) ;return there, perhaps
915 (message "No error message(s) found."))
916 ;; error found: point is at end of last match; set the cursor posn.
917 (set-marker sml-error-cursor (point))
918 ;; move the SML window's text up to this line
919 (set-window-start (get-buffer-window proc-buffer) (match-beginning 0))
921 (parse (funcall sml-error-parser (match-beginning 0)))
923 (line0 (nth 1 parse))
925 (line/col1 (nth 3 parse))
927 ;; Give up immediately if the error report is scribble
928 (if (or (null file) (null line0))
929 (sml-bottle "Failed to parse/locate this error properly!"))
930 ;; decide what to do depending on the file returned
931 (if (string= file "std_in")
932 ;; presently a fundamental limitation i'm afraid.
933 (sml-bottle "Sorry, can't locate errors on std_in.")
934 (if (string= file sml-temp-file)
935 ;; errors found in tmp file; seek the real file
936 (if (not (car sml-real-file))
937 ;; sent from a buffer w/o a file attached.
938 ;; DEAL WITH THIS EVENTUALLY.
939 (sml-bottle "No real file associated with the temp file.")
940 ;; real file and error-barrier
941 (setq file (car sml-real-file))
942 (setq pos (cdr sml-real-file)))))
943 (if (not (file-readable-p file))
944 (sml-bottle (concat "Can't read " file))
945 ;; instead of (find-file-other-window file) to lookup the file
946 (find-file-other-window file)
947 ;; no good if the buffer's narrowed, still...
948 (goto-char (or pos 1)) ; line 1 if no tmp file
949 (forward-line (1- line0))
950 (forward-char (1- col0))
951 ;; point is at start of error text; seek the end.
952 (let ((start (point))
955 (progn (eval line/col1) (point))
957 ;; return to start anyway
959 ;; if point went to end, put mark there, and maybe highlight
960 (if end (progn (push-mark end t)
961 (sml-error-overlay nil start end)))
962 (setq sml-error-file file) ; remember this for next time
963 (if msg (message msg)))))))) ; echo the error/warning message
965 (defun sml-skip-errors ()
966 "Skip past the rest of the errors."
968 (if (memq major-mode sml-source-modes) (sml-error-overlay 'undo))
969 (sml-update-cursor (sml-proc-buffer))
970 (if (eq major-mode 'sml-inferior-mode) (goto-char (point-max))))
972 ;;; Set up the inferior mode keymap, using sml-mode bindings...
974 (cond ((not inferior-sml-mode-map)
975 (setq inferior-sml-mode-map (nconc (make-sparse-keymap) comint-mode-map))
976 (install-sml-keybindings inferior-sml-mode-map)
977 (define-key inferior-sml-mode-map "\C-c\C-s" 'run-sml)
978 (define-key inferior-sml-mode-map "\t" 'comint-dynamic-complete)))
980 ;;; H A C K A T T A C K ! X E M A C S / E M A C S K E Y S
983 (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)
984 ;; LUCID (19.10) or later...
985 (define-key sml-mode-map '(meta shift button1) 'sml-drag-region))
987 ;; GNU, post circa 19.19
988 (define-key sml-mode-map [M-S-down-mouse-1] 'sml-drag-region))))
990 ;;; ...and do the user's customisations.
992 (run-hooks 'inferior-sml-load-hook)
994 ;;; Here is where sml-proc.el ends