Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/sml-mode/sml-proc.el
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 319 - (view) (download)

1 : monnier 32 ;;; sml-proc.el. Comint based interaction mode for Standard ML.
2 :    
3 :     ;; Copyright (C) 1989, Lars Bo Nielsen, 1994,1997 Matthew J. Morley
4 :    
5 :     ;; $Revision$
6 :     ;; $Date$
7 :    
8 :     ;; ====================================================================
9 :    
10 :     ;; This file is not part of GNU Emacs, but it is distributed under the
11 :     ;; same conditions.
12 :    
13 :     ;; This program is free software; you can redistribute it and/or
14 :     ;; modify it under the terms of the GNU General Public License as
15 :     ;; published by the Free Software Foundation; either version 2, or (at
16 :     ;; your option) any later version.
17 :    
18 :     ;; This program is distributed in the hope that it will be useful, but
19 :     ;; WITHOUT ANY WARRANTY; without even the implied warranty of
20 :     ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 :     ;; General Public License for more details.
22 :    
23 :     ;; You should have received a copy of the GNU General Public License
24 :     ;; along with GNU Emacs; see the file COPYING. If not, write to the
25 :     ;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 0139, USA.
26 :     ;; (See sml-mode.el for HISTORY.)
27 :    
28 :     ;; ====================================================================
29 :    
30 :     ;; [MJM 10/94] Separating this from sml-mode means sml-mode will run
31 :     ;; under 18.59 (or anywhere without comint, if there are such places).
32 :     ;; See sml-mode.el for further information.
33 :    
34 :     ;;; DESCRIPTION
35 :    
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:
41 :    
42 :     ;; (autoload 'sml "sml-proc" "Run an inferior ML process." t)
43 :    
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).
51 :    
52 :     ;; NOTE: inferior-sml-mode-hook is run AFTER the ML program has been
53 :     ;; launched. inferior-sml-load-hook is run only when sml-proc.el is
54 :     ;; loaded into Emacs.
55 :    
56 :     ;; When running an ML process some further key-bindings are effective
57 :     ;; in sml-mode buffer(s). C-c C-s (switch-to-sml) will split the
58 :     ;; screen into two windows if necessary and place you in the ML
59 :     ;; process buffer. In the interaction buffer, C-c C-s is bound to the
60 :     ;; `sml' command by default (in case you need to restart).
61 :    
62 :     ;; C-c C-l (sml-load-file) will load an SML source file into the
63 :     ;; inferior process, C-c C-r (sml-send-region) will send the current
64 :     ;; region of text to the ML process, etc. Given a prefix argument to
65 :     ;; these commands will switch you from the SML buffer to the ML
66 :     ;; process buffer as well as sending the text. If you get errors
67 :     ;; reported by the compiler, C-c ` (sml-next-error) will step through
68 :     ;; the errors with you.
69 :    
70 :     ;; NOTE. There is only limited support for this as it obviously
71 :     ;; depends on the compiler's error messages being recognised by the
72 :     ;; mode. Error reporting is currently only geared up for SML/NJ,
73 :     ;; 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.
77 :    
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.
81 :    
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.
85 :    
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
89 :     ;; compiler.
90 :    
91 :     ;;; FOR YOUR .EMACS
92 :    
93 :     ;; Here are some ideas for inferior-sml-*-hooks:
94 :    
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
101 :    
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)))
107 :    
108 :     ;; ===================================================================
109 :    
110 :     ;;; INFERIOR ML MODE VARIABLES
111 :    
112 :     (require 'sml-mode)
113 :     (require 'comint)
114 :     (provide 'sml-proc)
115 :    
116 :     (defvar sml-program-name "sml"
117 :     "*Program to run as ML.")
118 :    
119 :     (defvar sml-default-arg ""
120 :     "*Default command line option to pass, if any.")
121 :    
122 : monnier 33 (defvar sml-make-command "CM.make()"
123 :     "The command used by default by `sml-make'.")
124 : monnier 32
125 : monnier 33 (defvar sml-make-file-name "sources.cm"
126 :     "The name of the makefile that `sml-make' will look for (if non-nil).")
127 : monnier 32
128 :     ;;(defvar sml-raise-on-error nil
129 :     ;; "*When non-nil, `sml-next-error' will raise the ML process's frame.")
130 :    
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'.
138 :    
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.")
142 :    
143 : monnier 33 (defvar sml-temp-file
144 :     (make-temp-name
145 :     (concat (file-name-as-directory (or (getenv "TMPDIR") "/tmp")) "/ml"))
146 : monnier 32 "*Temp file that emacs uses to communicate with the ML process.
147 :     See `sml-temp-threshold'. Defaults to \(make-temp-name \"/tmp/ml\"\)")
148 :    
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.")
152 :    
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.")
156 :    
157 :     (defvar sml-buffer nil
158 :     "*The current ML process buffer.
159 :    
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].
168 :    
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*,...
171 :    
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:
177 :     Buffer Process
178 :     sml #<process sml>
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?
183 :    
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'.
188 :    
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
191 :     a string \(or nil\).
192 :    
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.")
198 :    
199 :    
200 :     ;;; ALL STUFF THAT DEFAULTS TO THE SML/NJ COMPILER (0.93)
201 :    
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.")
206 :    
207 : monnier 33 (defvar sml-cd-command "OS.FileSys.chDir \"%s\""
208 : monnier 32 "*Command template for changing working directories under ML.
209 :     Set this to nil if your compiler can't change directories.
210 :    
211 :     The format specifier \"%s\" will be converted into the directory name
212 :     specified when running the command \\[sml-cd].")
213 :    
214 :     (defvar sml-prompt-regexp "^[\-=] *"
215 :     "*Regexp used to recognise prompts in the inferior ML process.")
216 :    
217 :     (defvar sml-error-parser 'sml-smlnj-error-parser
218 :     "*This function parses an error message into a 3-5 element list:
219 :    
220 :     \(file start-line start-col end-line-col err-msg\).
221 :    
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
225 :    
226 :     \(\"std_in\" start-line start-col\).
227 :    
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'.
231 :    
232 :     In a step towards greater sml-mode modularity END-LINE-COL can be either
233 :    
234 :     - the symbol nil \(in which case it is ignored\)
235 :    
236 :     or
237 :    
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.
240 :    
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.")
244 :    
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)
247 :    
248 :     (defconst sml-smlnj-error-regexp
249 :     (concat
250 :     "^[-= ]*\\(.+\\):" ;file name
251 :     "\\([0-9]+\\)\\.\\([0-9]+\\)" ;start line.column
252 :     "\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)?" ;end line.colum
253 :     ".+\\(\\(Error\\|Warning\\): .*\\)") ;the message
254 :    
255 :     "Default regexp matching SML/NJ error and warning messages.
256 :    
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.
260 :    
261 :     If you do customise `sml-smlnj-error-regexp' you may need to modify
262 :     the function `sml-smlnj-error-parser' (qv).")
263 :    
264 :     (defvar sml-error-regexp sml-smlnj-error-regexp
265 :     "*Regexp for matching \(the start of\) an error message.")
266 :    
267 : monnier 33 ;; font-lock support
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 : monnier 39 ("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face)
274 :     ("^GC #.*" . font-lock-comment-face)))
275 : monnier 33
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))
285 :    
286 :     (defvar inferior-sml-font-lock-defaults
287 :     '(inferior-sml-font-lock-keywords nil nil nil nil))
288 :    
289 : monnier 32 (defun sml-smlnj-error-parser (pt)
290 :     "This parses the SML/NJ error message at PT into a 5 element list
291 :    
292 :     \(file start-line start-col end-of-err msg\)
293 :    
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.
297 :    
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."
302 :    
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.
307 :    
308 :     (save-excursion
309 :     (goto-char pt)
310 :     (if (not (looking-at sml-smlnj-error-regexp))
311 :     ;; the user loses big time.
312 :     (list nil nil nil)
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
328 :     `(progn
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))))))))
334 :    
335 :     (defun sml-smlnj (pfx)
336 :     "Set up and run Standard ML of New Jersey.
337 :     Prefix argument means accept the defaults below.
338 :    
339 :     Note: defaults set here will be clobbered if you setq them in the
340 :     inferior-sml-mode-hook.
341 :    
342 :     sml-program-name <option> \(default \"sml\"\)
343 :     sml-default-arg <option> \(default \"\"\)
344 :     sml-use-command \"use \\\"%s\\\"\"
345 : monnier 33 sml-cd-command \"OS.FileSys.chDir \\\"%s\\\"\"
346 : monnier 32 sml-prompt-regexp \"^[\\-=] *\"
347 :     sml-error-regexp sml-sml-nj-error-regexp
348 :     sml-error-parser 'sml-sml-nj-error-parser"
349 :     (interactive "P")
350 :     (let ((cmd (if pfx "sml"
351 :     (read-string "Command name: " sml-program-name)))
352 :     (arg (if pfx ""
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 : monnier 33 sml-cd-command "OS.FileSys.chDir \"%s\""
360 : monnier 32 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)))
364 :    
365 :    
366 :     ;;; CODE
367 :    
368 : monnier 319 (defmap inferior-sml-mode-map
369 :     '(("\C-c\C-s" . run-sml)
370 :     ("\t" . comint-dynamic-complete))
371 :     "Keymap for inferior-sml mode"
372 :     :inherit (list sml-bindings comint-mode-map))
373 : monnier 32
374 : monnier 319
375 : monnier 32 ;; buffer-local
376 :    
377 :     (defvar sml-error-file nil) ; file from which the last error came
378 :     (defvar sml-real-file nil) ; used for finding source errors
379 :     (defvar sml-error-cursor nil) ; ditto
380 :    
381 :     (defun sml-proc-buffer ()
382 :     "Returns the current ML process buffer,
383 :     or the current buffer if it is in `inferior-sml-mode'. Raises an error
384 :     if the variable `sml-buffer' does not appear to point to an existing
385 :     buffer."
386 :     (let ((buffer
387 :     (cond ((eq major-mode 'inferior-sml-mode)
388 :     ;; default to current buffer if it's in inferior-sml-mode
389 :     (current-buffer))
390 :     ((bufferp sml-buffer)
391 :     ;; buffer-name returns nil if the buffer has been killed
392 :     (buffer-name sml-buffer))
393 :     ((stringp sml-buffer)
394 :     ;; get-buffer returns nil if there's no buffer of that name
395 :     (get-buffer sml-buffer)))))
396 :     (or buffer
397 :     (error "No current process buffer. See variable sml-buffer"))))
398 :    
399 :     (defun sml-proc ()
400 :     "Returns the current ML process. See variable `sml-buffer'."
401 :     (let ((proc (get-buffer-process (sml-proc-buffer))))
402 :     (or proc
403 :     (error "No current process. See variable sml-buffer"))))
404 :    
405 :     (defun sml-buffer (echo)
406 :     "Make the current buffer the current `sml-buffer' if that is sensible.
407 :     Lookup variable `sml-buffer' to see why this might be useful."
408 :     (interactive "P")
409 :     (let ((current
410 :     (cond ((bufferp sml-buffer) (or (buffer-name sml-buffer) "undefined"))
411 :     ((stringp sml-buffer) sml-buffer)
412 :     (t "undefined"))))
413 :     (if echo (message (format "ML process buffer is %s." current))
414 :     (let ((buffer (if (eq major-mode 'inferior-sml-mode) (current-buffer))))
415 :     (if (not buffer) (message (format "ML process buffer is %s." current))
416 :     (setq sml-buffer buffer)
417 :     (message (format "ML process buffer is %s." (buffer-name buffer))))))))
418 :    
419 :     (defun sml-noproc ()
420 :     "Nil iff `sml-proc' returns a process."
421 :     (condition-case nil (progn (sml-proc) nil) (error t)))
422 :    
423 :     (defun sml-proc-tidy ()
424 :     "Something to add to `kill-emacs-hook' to tidy up tmp files on exit."
425 :     (if (file-readable-p sml-temp-file)
426 :     (delete-file sml-temp-file)))
427 :    
428 :     (defun inferior-sml-mode ()
429 :     "Major mode for interacting with an inferior ML process.
430 :    
431 :     The following commands are available:
432 :     \\{inferior-sml-mode-map}
433 :    
434 :     An ML process can be fired up (again) with \\[sml].
435 :    
436 :     Customisation: Entry to this mode runs the hooks on `comint-mode-hook'
437 :     and `inferior-sml-mode-hook' (in that order).
438 :    
439 :     Variables controlling behaviour of this mode are
440 :    
441 :     `sml-program-name' (default \"sml\")
442 :     Program to run as ML.
443 :    
444 :     `sml-use-command' (default \"use \\\"%s\\\"\")
445 :     Template for loading a file into the inferior ML process.
446 :    
447 :     `sml-cd-command' (default \"System.Directory.cd \\\"%s\\\"\")
448 :     ML command for changing directories in ML process (if possible).
449 :    
450 :     `sml-prompt-regexp' (default \"^[\\-=] *\")
451 :     Regexp used to recognise prompts in the inferior ML process.
452 :    
453 :     `sml-temp-threshold' (default 0)
454 :     Controls when emacs uses temporary files to communicate with ML.
455 :     If an integer N, then emacs uses a temporary file whenever the
456 :     text is longer than N chars.
457 :    
458 :     `sml-temp-file' (default (make-temp-name \"/tmp/ml\"))
459 :     Temp file that emacs uses to communicate with the ML process.
460 :    
461 :     `sml-error-regexp'
462 :     (default -- complicated)
463 :     Regexp for matching error messages from the compiler.
464 :    
465 :     `sml-error-parser' (default 'sml-smlnj-error-parser)
466 :     This function parses a error messages into a 3, 4 or 5 element list:
467 :     (file start-line start-col (end-line end-col) err-msg).
468 :    
469 :     You can send text to the inferior ML process from other buffers containing
470 :     ML source.
471 :     `switch-to-sml' switches the current buffer to the ML process buffer.
472 :     `sml-send-function' sends the current *paragraph* to the ML process.
473 :     `sml-send-region' sends the current region to the ML process.
474 :    
475 :     Prefixing the sml-send-<whatever> commands with \\[universal-argument]
476 :     causes a switch to the ML process buffer after sending the text.
477 :    
478 :     For information on running multiple processes in multiple buffers, see
479 :     documentation for variable `sml-buffer'.
480 :    
481 :     Commands:
482 :     RET after the end of the process' output sends the text from the
483 :     end of process to point.
484 :     RET before the end of the process' output copies the current line
485 :     to the end of the process' output, and sends it.
486 :     DEL converts tabs to spaces as it moves back.
487 :     TAB file name completion, as in shell-mode, etc.."
488 :     (interactive)
489 :     (kill-all-local-variables)
490 :     (comint-mode)
491 :     (setq comint-prompt-regexp sml-prompt-regexp)
492 :     (sml-mode-variables)
493 :    
494 :     ;; For sequencing through error messages:
495 : monnier 33
496 : monnier 300 (set (make-local-variable 'sml-error-cursor) (point-max-marker))
497 :     (set (make-local-variable 'sml-real-file) nil)
498 : monnier 33 (set (make-local-variable 'font-lock-defaults)
499 :     inferior-sml-font-lock-defaults)
500 : monnier 32
501 :     (make-local-variable 'sml-use-command)
502 :     (make-local-variable 'sml-cd-command)
503 :     (make-local-variable 'sml-prompt-regexp)
504 :     (make-local-variable 'sml-error-parser)
505 :     (make-local-variable 'sml-error-regexp)
506 :    
507 :     (setq major-mode 'inferior-sml-mode)
508 :     (setq mode-name "Inferior ML")
509 :     (setq mode-line-process '(": %s"))
510 :     (use-local-map inferior-sml-mode-map)
511 :     (add-hook 'kill-emacs-hook 'sml-proc-tidy)
512 :    
513 :     (run-hooks 'inferior-sml-mode-hook))
514 :    
515 :     ;;; FOR RUNNING ML FROM EMACS
516 :    
517 : monnier 33 ;;;###autoload
518 :     (defun run-sml (&optional pfx)
519 : monnier 32 "Run an inferior ML process, input and output via buffer *sml*.
520 :     With a prefix argument, this command allows you to specify any command
521 :     line options to pass to the complier. The command runs hook functions
522 :     on `comint-mode-hook' and `inferior-sml-mode-hook' in that order.
523 :    
524 :     If there is a process already running in *sml*, just switch to that
525 :     buffer instead.
526 :    
527 :     In fact the name of the buffer created is chosen to reflect the name
528 :     of the program name specified by `sml-program-name', or entered at the
529 :     prompt. You can have several inferior ML process running, but only one
530 :     current one -- given by `sml-buffer' (qv).
531 :    
532 :     \(Type \\[describe-mode] in the process buffer for a list of commands.)"
533 :     (interactive "P")
534 :     (let ((cmd (if pfx
535 :     (read-string "ML command: " sml-program-name)
536 :     sml-program-name))
537 :     (args (if pfx
538 :     (read-string "Any args: " sml-default-arg)
539 :     sml-default-arg)))
540 :     (sml-run cmd args)))
541 :    
542 :     (defun sml-run (cmd arg)
543 :     "Run the ML program CMD with given arguments ARGS.
544 :     This usually updates `sml-buffer' to a buffer named *CMD*."
545 :     (let* ((pname (file-name-nondirectory cmd))
546 :     (bname (format "*%s*" pname))
547 :     (args (if (equal arg "") () (sml-args-to-list arg))))
548 :     (if (comint-check-proc bname)
549 : monnier 33 (pop-to-buffer (sml-proc-buffer)) ;do nothing but switch buffer
550 : monnier 32 (setq sml-buffer
551 :     (if (null args)
552 :     ;; there is a good reason for this; to ensure
553 :     ;; *no* argument is sent, not even a "".
554 :     (set-buffer (apply 'make-comint pname cmd nil))
555 :     (set-buffer (apply 'make-comint pname cmd nil args))))
556 :     (message (format "Starting \"%s\" in background." pname))
557 :     (inferior-sml-mode)
558 :     (goto-char (point-max))
559 :     ;; and this -- to keep these as defaults even if
560 :     ;; they're set in the mode hooks.
561 :     (setq sml-program-name cmd)
562 :     (setq sml-default-arg arg))))
563 :    
564 :     (defun sml-args-to-list (string)
565 :     (let ((where (string-match "[ \t]" string)))
566 :     (cond ((null where) (list string))
567 :     ((not (= where 0))
568 :     (cons (substring string 0 where)
569 :     (sml-args-to-list (substring string (+ 1 where)
570 :     (length string)))))
571 :     (t (let ((pos (string-match "[^ \t]" string)))
572 :     (if (null pos)
573 :     nil
574 :     (sml-args-to-list (substring string pos
575 :     (length string)))))))))
576 :    
577 :     (defun sml-temp-threshold (&optional thold)
578 :     "Set the variable to the given prefix (nil, if no prefix given).
579 :     This is really mainly here to help debugging sml-mode!"
580 :     (interactive "P")
581 :     (setq sml-temp-threshold
582 :     (if current-prefix-arg (prefix-numeric-value thold)))
583 :     (message "%s" sml-temp-threshold))
584 :    
585 :     ;;;###autoload
586 :     (defun switch-to-sml (eob-p)
587 :     "Switch to the ML process buffer.
588 :     With prefix argument, positions cursor at point, otherwise at end of buffer."
589 :     (interactive "P")
590 : monnier 33 (if (sml-noproc) (save-excursion (run-sml t)))
591 :     (pop-to-buffer (sml-proc-buffer))
592 : monnier 32 (cond ((not eob-p)
593 :     (push-mark (point) t)
594 :     (goto-char (point-max)))))
595 :    
596 :     ;; Fakes it with a "use <temp-file>;" if necessary.
597 :    
598 :     ;;;###autoload
599 :     (defun sml-send-region (start end &optional and-go)
600 :     "Send current region to the inferior ML process.
601 :     Prefix argument means switch-to-sml afterwards.
602 :    
603 :     If the region is longer than `sml-temp-threshold' and the variable
604 :     `sml-use-command' is defined, the region is written out to a temporary file
605 :     and a \"use <temp-file>\" command is sent to the compiler\; otherwise the
606 :     text in the region is sent directly to the compiler. In either case a
607 :     trailing \"\;\\n\" will be added automatically.
608 :    
609 :     See variables `sml-temp-threshold', `sml-temp-file' and `sml-use-command'."
610 :     (interactive "r\nP")
611 : monnier 33 (if (sml-noproc) (save-excursion (run-sml t)))
612 : monnier 32 (cond ((equal start end)
613 :     (message "The region is zero (ignored)"))
614 :     ((and sml-use-command
615 :     (numberp sml-temp-threshold)
616 :     (< sml-temp-threshold (- end start)))
617 :     ;; Just in case someone is still reading from sml-temp-file:
618 :     (if (file-exists-p sml-temp-file)
619 :     (delete-file sml-temp-file))
620 :     (write-region start end sml-temp-file nil 'silently)
621 :     (sml-update-barrier (buffer-file-name (current-buffer)) start)
622 :     (sml-update-cursor (sml-proc-buffer))
623 :     (comint-send-string (sml-proc)
624 :     (concat (format sml-use-command sml-temp-file) ";\n")))
625 :     (t
626 :     (comint-send-region (sml-proc) start end)
627 :     (comint-send-string (sml-proc) ";\n")))
628 :     (if and-go (switch-to-sml nil)))
629 :    
630 : monnier 300 ;; Update the buffer-local variables sml-real-file
631 : monnier 32 ;; in the process buffer:
632 :    
633 : monnier 300 (defun sml-update-barrier (&optional file pos)
634 : monnier 32 (let ((buf (current-buffer)))
635 :     (unwind-protect
636 :     (let* ((proc (sml-proc))
637 :     (pmark (marker-position (process-mark proc))))
638 :     (set-buffer (process-buffer proc))
639 :     ;; update buffer local variables
640 : monnier 300 (setq sml-real-file (and file (cons file pos))))
641 : monnier 32 (set-buffer buf))))
642 :    
643 :     ;; Update the buffer-local error-cursor in proc-buffer to be its
644 :     ;; current proc mark.
645 :    
646 :     (defun sml-update-cursor (proc-buffer) ;always= sml-proc-buffer
647 :     (let ((buf (current-buffer)))
648 :     (unwind-protect
649 :     (let* ((proc (sml-proc)) ;just in case?
650 :     (pmark (marker-position (process-mark proc))))
651 :     (set-buffer proc-buffer)
652 :     ;; update buffer local variable
653 : monnier 300 (set-marker sml-error-cursor pmark))
654 : monnier 32 (set-buffer buf))))
655 :    
656 :     ;; This is quite bogus, so it isn't bound to a key by default.
657 :     ;; Anyone coming up with an algorithm to recognise fun & local
658 :     ;; declarations surrounding point will do everyone a favour!
659 :    
660 :     (defun sml-send-function (&optional and-go)
661 :     "Send current paragraph to the inferior ML process.
662 :     With a prefix argument switch to the sml buffer as well
663 :     \(cf. `sml-send-region'\)."
664 :     (interactive "P")
665 :     (save-excursion
666 :     (sml-mark-function)
667 :     (sml-send-region (point) (mark)))
668 :     (if and-go (switch-to-sml nil)))
669 :    
670 : monnier 319 (defvar sml-source-modes '(sml-mode)
671 :     "*Used to determine if a buffer contains ML source code.
672 :     If it's loaded into a buffer that is in one of these major modes, it's
673 :     considered an ML source file by `sml-load-file'. Used by these commands
674 :     to determine defaults.")
675 :    
676 : monnier 32 ;;;###autoload
677 :     (defun sml-send-buffer (&optional and-go)
678 :     "Send buffer to inferior shell running ML process.
679 :     With a prefix argument switch to the sml buffer as well
680 :     \(cf. `sml-send-region'\)."
681 :     (interactive "P")
682 :     (if (memq major-mode sml-source-modes)
683 :     (sml-send-region (point-min) (point-max) and-go)))
684 :    
685 :     ;; Since sml-send-function/region take an optional prefix arg, these
686 :     ;; commands are redundant. But they are kept around for the user to
687 :     ;; bind if she wishes, since its easier to type C-c r than C-u C-c C-r.
688 :    
689 :     (defun sml-send-region-and-go (start end)
690 :     "Send current region to the inferior ML process, and go there."
691 :     (interactive "r")
692 :     (sml-send-region start end t))
693 :    
694 :     (defun sml-send-function-and-go ()
695 :     "Send current paragraph to the inferior ML process, and go there."
696 :     (interactive)
697 :     (sml-send-function t))
698 :    
699 :    
700 :     ;;; Mouse control and handling dedicated frames for Inferior ML
701 :    
702 :     ;; simplified from frame.el in Emacs: special-display-popup-frame...
703 :    
704 :     (defun sml-proc-frame ()
705 :     "Returns the current ML process buffer's frame, or creates one first."
706 :     (let ((buffer (sml-proc-buffer)))
707 : monnier 33 (window-frame (display-buffer buffer))))
708 : monnier 32
709 :     ;;; 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
710 :    
711 :     ;; Only these two functions have to dance around the inane differences
712 :     ;; between Emacs and XEmacs (fortunately)
713 :    
714 :     (defun sml-warp-mouse (frame)
715 :     "Warp the pointer across the screen to upper right corner of FRAME."
716 :     (raise-frame frame)
717 :     (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)
718 :     ;; LUCID (19.10) or later... set-m-pos needs a WINDOW
719 :     (set-mouse-position (frame-root-window frame) (1- (frame-width)) 0))
720 :     (t
721 :     ;; GNU, post circa 19.19... set-m-pos needs a FRAME
722 :     (set-mouse-position frame (1- (frame-width)) 0)
723 :     ;; probably not needed post 19.29
724 :     (if (fboundp 'unfocus-frame) (unfocus-frame)))))
725 :    
726 :     (defun sml-drag-region (event)
727 :     "Highlight the text the mouse is dragged over, and send it to ML.
728 :     This must be bound to a button-down mouse event, currently \\[sml-drag-region].
729 :    
730 :     If you drag the mouse (ie, keep the mouse button depressed) the
731 :     program text sent to the complier is delimited by where you started
732 :     dragging the mouse, and where you release the mouse button.
733 :    
734 :     If you only click the mouse, the program text sent to the compiler is
735 :     delimited by the current position of point and the place where you
736 :     click the mouse.
737 :    
738 :     In either event, the values of both point and mark are left
739 :     undisturbed once this operation is completed."
740 :     (interactive "e")
741 :     (let ((mark-ring) ;BAD: selection start gets cons'd
742 :     (pmark (point))) ;where point is now
743 :     (if (fboundp 'mouse-track-default)
744 :     ;; Assume this is XEmacs, otherwise assume its Emacs
745 :     (save-excursion
746 :     (let ((zmacs-regions))
747 :     (set-marker (mark-marker) nil)
748 :     (mouse-track-default event)
749 :     (if (not (region-exists-p)) (push-mark pmark nil t))
750 :     (call-interactively 'sml-send-region)))
751 :     ;; Emacs: making this buffer-local ought to happen in sml-mode
752 :     (make-local-variable 'transient-mark-mode)
753 :     (save-excursion
754 :     (let ((transient-mark-mode 1))
755 :     (mouse-drag-region event)
756 :     (if (not mark-active) (push-mark pmark nil t))
757 :     (call-interactively 'sml-send-region))))))
758 :    
759 :    
760 :     ;;; LOADING AND IMPORTING SOURCE FILES:
761 :    
762 :     (defvar sml-prev-l/c-dir/file nil
763 :     "Caches the (directory . file) pair used in the last `sml-load-file'
764 :     or `sml-cd' command. Used for determining the default in the next one.")
765 :    
766 :     ;;;###autoload
767 :     (defun sml-load-file (&optional and-go)
768 :     "Load an ML file into the current inferior ML process.
769 :     With a prefix argument switch to sml buffer as well.
770 :    
771 :     This command uses the ML command template `sml-use-command' to construct
772 :     the command to send to the ML process\; a trailing \"\;\\n\" will be added
773 :     automatically."
774 :     (interactive "P")
775 : monnier 33 (if (sml-noproc) (save-excursion (run-sml t)))
776 : monnier 32 (if sml-use-command
777 :     (let ((file
778 :     (car (comint-get-source "Load ML file: " sml-prev-l/c-dir/file
779 :     sml-source-modes t))))
780 :     ;; Check if buffer needs saved. Should (save-some-buffers) instead?
781 :     (comint-check-source file)
782 :     (setq sml-prev-l/c-dir/file
783 :     (cons (file-name-directory file) (file-name-nondirectory file)))
784 :     (sml-update-cursor (sml-proc-buffer))
785 :     (comint-send-string
786 :     (sml-proc) (concat (format sml-use-command file) ";\n")))
787 :     (message "Can't load files if `sml-use-command' is undefined!"))
788 :     (if and-go (switch-to-sml nil)))
789 :    
790 :     (defun sml-cd (dir)
791 :     "Change the working directory of the inferior ML process.
792 :     The default directory of the process buffer is changed to DIR. If the
793 :     variable `sml-cd-command' is non-nil it should be an ML command that will
794 :     be executed to change the compiler's working directory\; a trailing
795 :     \"\;\\n\" will be added automatically."
796 :     (interactive "DSML Directory: ")
797 :     (let* ((buf (sml-proc-buffer))
798 :     (proc (get-buffer-process buf))
799 : monnier 33 (dir (expand-file-name dir))
800 :     (string (concat (format sml-cd-command dir) ";\n")))
801 : monnier 32 (save-excursion
802 :     (set-buffer buf)
803 : monnier 33 (goto-char (point-max))
804 :     (insert string)
805 :     (set-marker (process-mark proc) (point))
806 :     (if sml-cd-command (process-send-string proc string))
807 : monnier 32 (cd dir))
808 :     (setq sml-prev-l/c-dir/file (cons dir nil))))
809 :    
810 : monnier 300 (defun sml-send-command (cmd &optional dir print)
811 : monnier 33 "Send string to ML process, display this string in ML's buffer"
812 :     (if (sml-noproc) (save-excursion (run-sml t)))
813 :     (let* ((my-dir (or dir (expand-file-name default-directory)))
814 : monnier 300 (cd-cmd (if my-dir (concat (format sml-cd-command my-dir) "; ") ""))
815 : monnier 33 (buf (sml-proc-buffer))
816 : monnier 300 (win (get-buffer-window buf 'visible))
817 : monnier 33 (proc (get-buffer-process buf))
818 :     (string (concat cd-cmd cmd ";\n")))
819 :     (save-some-buffers t)
820 :     (save-excursion
821 :     (set-buffer buf)
822 : monnier 300 (when win (select-window win))
823 : monnier 33 (goto-char (point-max))
824 : monnier 300 (when print (insert string))
825 :     (when my-dir (cd my-dir))
826 :     (sml-update-cursor buf)
827 :     (sml-update-barrier)
828 :     (set-marker (process-mark proc) (point-max))
829 :     (comint-send-string proc string))
830 : monnier 33 (switch-to-sml t)))
831 : monnier 32
832 : monnier 33 (defun sml-make (command)
833 :     "re-make a system using (by default) CM.
834 :     The exact command used can be specified by providing a prefix argument."
835 :     (interactive
836 :     ;; code taken straight from compile.el
837 :     (if (or current-prefix-arg (not sml-make-command))
838 :     (list (read-from-minibuffer "Compile command: "
839 :     sml-make-command nil nil
840 :     '(compile-history . 1)))
841 :     (list sml-make-command)))
842 :     (setq sml-make-command command)
843 :     ;; try to find a makefile up the sirectory tree
844 :     (let ((dir (and sml-make-file-name (expand-file-name default-directory))))
845 :     (while (and dir (not (file-exists-p (concat dir sml-make-file-name))))
846 :     (let ((newdir (file-name-directory (directory-file-name dir))))
847 :     (setq dir (if (equal newdir dir) nil newdir))))
848 : monnier 300 (sml-send-command command dir t)))
849 : monnier 32
850 : monnier 33 ;;; PARSING ERROR MESSAGES
851 : monnier 32
852 :     ;; This should need no modification to support other compilers.
853 :    
854 :     ;;;###autoload
855 :     (defun sml-next-error (skip)
856 :     "Find the next error by parsing the inferior ML buffer.
857 :     A prefix argument means `sml-skip-errors' (qv) instead.
858 :    
859 :     Move the error message on the top line of the window\; put the cursor
860 :     \(point\) at the beginning of the error source.
861 :    
862 :     If the error message specifies a range, and `sml-error-parser' returns
863 :     the range, the mark is placed at the end of the range. If the variable
864 :     `sml-error-overlay' is non-nil, the region will also be highlighted.
865 :    
866 :     If `sml-error-parser' returns a fifth component this is assumed to be
867 :     a string to indicate the nature of the error: this will be echoed in
868 :     the minibuffer.
869 :    
870 :     Error interaction only works if there is a real file associated with
871 :     the input -- though of course it also depends on the compiler's error
872 :     messages \(also see documantation for `sml-error-parser'\).
873 :    
874 :     However: if the last text sent went via `sml-load-file' (or the temp
875 :     file mechanism), the next error reported will be relative to the start
876 :     of the region sent, any error reports in the previous output being
877 :     forgotten. If the text went directly to the compiler the succeeding
878 :     error reported will be the next error relative to the location \(in
879 :     the output\) of the last error. This odd behaviour may have a use...?"
880 :     (interactive "P")
881 :     (if skip (sml-skip-errors) (sml-do-next-error)))
882 :    
883 :     (defun sml-bottle (msg)
884 :     "Function to let `sml-next-error' give up gracefully."
885 :     (sml-warp-mouse (selected-frame))
886 :     (error msg))
887 :    
888 :     (defun sml-do-next-error ()
889 : monnier 319 "The business end of `sml-next-error' (qv)"
890 : monnier 32 (let ((case-fold-search nil)
891 :     ;; set this variable iff we called sml-next-error in a SML buffer
892 :     (sml-window (if (memq major-mode sml-source-modes) (selected-window)))
893 :     (proc-buffer (sml-proc-buffer)))
894 :     ;; undo (don't destroy) the previous overlay to be tidy
895 :     (sml-error-overlay 'undo 1 1
896 :     (and sml-error-file (get-file-buffer sml-error-file)))
897 :     ;; go to interaction buffer but don't raise it's frame
898 : monnier 33 (pop-to-buffer (sml-proc-buffer))
899 : monnier 32 ;; go to the last remembered error, and search for the next one.
900 : monnier 300 (goto-char (marker-position sml-error-cursor))
901 : monnier 32 (if (not (re-search-forward sml-error-regexp (point-max) t))
902 :     ;; no more errors -- move point to the sml prompt at the end
903 :     (progn
904 :     (goto-char (point-max))
905 :     (if sml-window (select-window sml-window)) ;return there, perhaps
906 :     (message "No error message(s) found."))
907 :     ;; error found: point is at end of last match; set the cursor posn.
908 : monnier 300 (set-marker sml-error-cursor (point))
909 : monnier 32 ;; move the SML window's text up to this line
910 :     (set-window-start (get-buffer-window proc-buffer) (match-beginning 0))
911 :     (let* ((pos)
912 :     (parse (funcall sml-error-parser (match-beginning 0)))
913 :     (file (nth 0 parse))
914 :     (line0 (nth 1 parse))
915 :     (col0 (nth 2 parse))
916 :     (line/col1 (nth 3 parse))
917 :     (msg (nth 4 parse)))
918 :     ;; Give up immediately if the error report is scribble
919 :     (if (or (null file) (null line0))
920 :     (sml-bottle "Failed to parse/locate this error properly!"))
921 :     ;; decide what to do depending on the file returned
922 :     (if (string= file "std_in")
923 :     ;; presently a fundamental limitation i'm afraid.
924 :     (sml-bottle "Sorry, can't locate errors on std_in.")
925 :     (if (string= file sml-temp-file)
926 :     ;; errors found in tmp file; seek the real file
927 : monnier 300 (if (not (car sml-real-file))
928 :     ;; sent from a buffer w/o a file attached.
929 :     ;; DEAL WITH THIS EVENTUALLY.
930 :     (sml-bottle "No real file associated with the temp file.")
931 :     ;; real file and error-barrier
932 :     (setq file (car sml-real-file))
933 :     (setq pos (cdr sml-real-file)))))
934 : monnier 32 (if (not (file-readable-p file))
935 :     (sml-bottle (concat "Can't read " file))
936 :     ;; instead of (find-file-other-window file) to lookup the file
937 : monnier 33 (find-file-other-window file)
938 : monnier 32 ;; no good if the buffer's narrowed, still...
939 :     (goto-char (or pos 1)) ; line 1 if no tmp file
940 :     (forward-line (1- line0))
941 :     (forward-char (1- col0))
942 :     ;; point is at start of error text; seek the end.
943 :     (let ((start (point))
944 :     (end (and line/col1
945 :     (condition-case nil
946 :     (progn (eval line/col1) (point))
947 :     (error nil)))))
948 :     ;; return to start anyway
949 :     (goto-char start)
950 :     ;; if point went to end, put mark there, and maybe highlight
951 :     (if end (progn (push-mark end t)
952 :     (sml-error-overlay nil start end)))
953 :     (setq sml-error-file file) ; remember this for next time
954 :     (if msg (message msg)))))))) ; echo the error/warning message
955 :    
956 :     (defun sml-skip-errors ()
957 :     "Skip past the rest of the errors."
958 :     (interactive)
959 :     (if (memq major-mode sml-source-modes) (sml-error-overlay 'undo))
960 :     (sml-update-cursor (sml-proc-buffer))
961 :     (if (eq major-mode 'sml-inferior-mode) (goto-char (point-max))))
962 :    
963 :     ;;; 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
964 :    
965 :     (if window-system
966 :     (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)
967 :     ;; LUCID (19.10) or later...
968 :     (define-key sml-mode-map '(meta shift button1) 'sml-drag-region))
969 :     (t
970 :     ;; GNU, post circa 19.19
971 :     (define-key sml-mode-map [M-S-down-mouse-1] 'sml-drag-region))))
972 :    
973 :     ;;; ...and do the user's customisations.
974 :    
975 :     (run-hooks 'inferior-sml-load-hook)
976 :    
977 :     ;;; Here is where sml-proc.el ends

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