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 342 - (view) (download)

1 : monnier 32 ;;; sml-proc.el. Comint based interaction mode for Standard ML.
2 :    
3 : monnier 332 (defconst rcsid-sml-proc "@(#)$Name$:$Id$")
4 :    
5 : monnier 32 ;; Copyright (C) 1989, Lars Bo Nielsen, 1994,1997 Matthew J. Morley
6 :    
7 :     ;; $Revision$
8 :     ;; $Date$
9 :    
10 :     ;; ====================================================================
11 :    
12 :     ;; This file is not part of GNU Emacs, but it is distributed under the
13 :     ;; same conditions.
14 :    
15 :     ;; This program is free software; you can redistribute it and/or
16 :     ;; modify it under the terms of the GNU General Public License as
17 :     ;; published by the Free Software Foundation; either version 2, or (at
18 :     ;; your option) any later version.
19 :    
20 :     ;; This program is distributed in the hope that it will be useful, but
21 :     ;; WITHOUT ANY WARRANTY; without even the implied warranty of
22 :     ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
23 :     ;; General Public License for more details.
24 :    
25 :     ;; You should have received a copy of the GNU General Public License
26 :     ;; along with GNU Emacs; see the file COPYING. If not, write to the
27 :     ;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 0139, USA.
28 :     ;; (See sml-mode.el for HISTORY.)
29 :    
30 :     ;; ====================================================================
31 :    
32 :     ;; [MJM 10/94] Separating this from sml-mode means sml-mode will run
33 :     ;; under 18.59 (or anywhere without comint, if there are such places).
34 :     ;; See sml-mode.el for further information.
35 :    
36 :     ;;; DESCRIPTION
37 :    
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 sml which starts a sub-process under emacs. You may
42 :     ;; need to set this up for autoloading in your .emacs:
43 :    
44 :     ;; (autoload 'sml "sml-proc" "Run an inferior ML process." t)
45 :    
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 :     ;; 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).
53 :    
54 :     ;; NOTE: inferior-sml-mode-hook is run AFTER the ML program has been
55 :     ;; launched. inferior-sml-load-hook is run only when sml-proc.el is
56 :     ;; loaded into Emacs.
57 :    
58 :     ;; When running an ML process some further key-bindings are effective
59 :     ;; in sml-mode buffer(s). C-c C-s (switch-to-sml) will split the
60 :     ;; screen into two windows if necessary and place you in the ML
61 :     ;; process buffer. In the interaction buffer, C-c C-s is bound to the
62 :     ;; `sml' command by default (in case you need to restart).
63 :    
64 :     ;; C-c C-l (sml-load-file) will load an SML source file into the
65 :     ;; inferior process, C-c C-r (sml-send-region) will send the current
66 :     ;; region of text to the ML process, etc. Given a prefix argument to
67 :     ;; these commands will switch you from the SML buffer to the ML
68 :     ;; process buffer as well as sending the text. If you get errors
69 :     ;; reported by the compiler, C-c ` (sml-next-error) will step through
70 :     ;; the errors with you.
71 :    
72 :     ;; NOTE. There is only limited support for this as it obviously
73 :     ;; depends on the compiler's error messages being recognised by the
74 :     ;; mode. Error reporting is currently only geared up for SML/NJ,
75 :     ;; Moscow ML, and Poly/ML (see file sml-{mosml,poly-ml}.el). Look at
76 :     ;; the documentation for sml-error-parser and sml-next-error -- you
77 :     ;; may only need to modify the former to recover this feature for some
78 :     ;; other ML systems, along with sml-error-regexp.
79 :    
80 :     ;; While small pieces of text can be fed quite happily into the ML
81 :     ;; process directly, lager pieces should (probably) be sent via a
82 :     ;; temporary file making use of the compiler's "use" command.
83 : monnier 332 ;; To be safe, we always use a temp file (which also improves error
84 :     ;; reporting).
85 : monnier 32
86 :     ;;; FOR YOUR .EMACS
87 :    
88 :     ;; Here are some ideas for inferior-sml-*-hooks:
89 :    
90 :     ;; (setq inferior-sml-load-hook
91 :     ;; '(lambda() "Set global defaults for inferior-sml-mode"
92 :     ;; (define-key inferior-sml-mode-map "\C-cd" 'sml-cd)
93 :     ;; (define-key sml-mode-map "\C-cd" 'sml-cd)
94 :     ;; (define-key sml-mode-map "\C-c\C-f" 'sml-send-function)
95 :    
96 :     ;; (setq inferior-sml-mode-hook
97 :     ;; '(lambda() "Inferior SML mode defaults"
98 :     ;; (setq comint-scroll-show-maximum-output t
99 :     ;; comint-scroll-to-bottom-on-output t
100 :     ;; comint-input-autoexpand nil)))
101 :    
102 :     ;; ===================================================================
103 :    
104 :     ;;; INFERIOR ML MODE VARIABLES
105 :    
106 :     (require 'sml-mode)
107 : monnier 332 (require 'sml-util)
108 : monnier 32 (require 'comint)
109 : monnier 332 (require 'compile)
110 : monnier 32
111 :     (defvar sml-program-name "sml"
112 :     "*Program to run as ML.")
113 :    
114 :     (defvar sml-default-arg ""
115 :     "*Default command line option to pass, if any.")
116 :    
117 : monnier 332 (defvar sml-compile-command "CM.make()"
118 : monnier 33 "The command used by default by `sml-make'.")
119 : monnier 32
120 : monnier 33 (defvar sml-make-file-name "sources.cm"
121 :     "The name of the makefile that `sml-make' will look for (if non-nil).")
122 : monnier 32
123 :     ;;(defvar sml-raise-on-error nil
124 :     ;; "*When non-nil, `sml-next-error' will raise the ML process's frame.")
125 :    
126 :     (defvar inferior-sml-mode-hook nil
127 :     "*This hook is run when the inferior ML process is started.
128 :     All buffer local customisations for the interaction buffers go here.")
129 :    
130 :     (defvar inferior-sml-load-hook nil
131 :     "*Hook run when inferior-sml-mode (sml-proc.el) is loaded into Emacs.
132 :     This is a good place to put your preferred key bindings.")
133 :    
134 : monnier 332 (defvar sml-error-overlay nil
135 :     "*Non-nil means use an overlay to highlight errorful code in the buffer.
136 :     The actual value is the name of a face to use for the overlay.
137 :     Instead of setting this variable to 'region, you can also simply keep
138 :     it NIL and use (transient-mark-mode) which will provide similar
139 :     benefits (but with several side effects).")
140 :    
141 : monnier 32 (defvar sml-buffer nil
142 :     "*The current ML process buffer.
143 :    
144 :     MULTIPLE PROCESS SUPPORT (Whoever wants multi-process support anyway?)
145 :     =====================================================================
146 :     sml-mode supports, in a fairly simple fashion, running multiple ML
147 :     processes. To run multiple ML processes, you start the first up with
148 :     \\[sml]. It will be in a buffer named *sml*. Rename this buffer with
149 :     \\[rename-buffer]. You may now start up a new process with another
150 :     \\[sml]. It will be in a new buffer, named *sml*. You can switch
151 :     between the different process buffers with \\[switch-to-buffer].
152 :    
153 :     NB *sml* is just the default name for the buffer. It actually gets
154 :     it's name from the value of `sml-program-name' -- *poly*, *smld*,...
155 :    
156 :     If you have more than one ML process around, commands that send text
157 :     from source buffers to ML processes -- like `sml-send-function' or
158 :     `sml-send-region' -- have to choose a process to send it to. This is
159 :     determined by the global variable `sml-buffer'. Suppose you have three
160 :     inferior ML's running:
161 :     Buffer Process
162 :     sml #<process sml>
163 :     mosml #<process mosml>
164 :     *sml* #<process sml<2>>
165 :     If you do a \\[sml-send-function] command on some ML source code,
166 :     what process do you send it to?
167 :    
168 :     - If you're in a process buffer (sml, mosml, or *sml*), you send it to
169 :     that process (usually makes sense only to `sml-load-file').
170 :     - If you're in some other buffer (e.g., a source file), you send it to
171 :     the process attached to buffer `sml-buffer'.
172 :    
173 :     This process selection is performed by function `sml-proc' which looks
174 :     at the value of `sml-buffer' -- which must be a lisp buffer object, or
175 :     a string \(or nil\).
176 :    
177 :     Whenever \\[sml] fires up a new process, it resets `sml-buffer' to be
178 :     the new process's buffer. If you only run one process, this will do
179 :     the right thing. If you run multiple processes, you can change
180 :     `sml-buffer' to another process buffer with \\[set-variable], or
181 :     use the command \\[sml-buffer] in the interaction buffer of choice.")
182 :    
183 :    
184 :     ;;; ALL STUFF THAT DEFAULTS TO THE SML/NJ COMPILER (0.93)
185 :    
186 :     (defvar sml-use-command "use \"%s\""
187 :     "*Template for loading a file into the inferior ML process.
188 :     Set to \"use \\\"%s\\\"\" for SML/NJ or Edinburgh ML;
189 :     set to \"PolyML.use \\\"%s\\\"\" for Poly/ML, etc.")
190 :    
191 : monnier 33 (defvar sml-cd-command "OS.FileSys.chDir \"%s\""
192 : monnier 32 "*Command template for changing working directories under ML.
193 :     Set this to nil if your compiler can't change directories.
194 :    
195 :     The format specifier \"%s\" will be converted into the directory name
196 :     specified when running the command \\[sml-cd].")
197 :    
198 : monnier 332 (defvar sml-prompt-regexp "^[-=>#] *"
199 : monnier 32 "*Regexp used to recognise prompts in the inferior ML process.")
200 :    
201 :     (defvar sml-error-parser 'sml-smlnj-error-parser
202 :     "*This function parses an error message into a 3-5 element list:
203 :    
204 :     \(file start-line start-col end-line-col err-msg\).
205 :    
206 :     The first three components are required by `sml-next-error', but the other
207 :     two are optional. If the file associated with the input is the standard
208 :     input stream, this function should probably return
209 :    
210 :     \(\"std_in\" start-line start-col\).
211 :    
212 :     This function will be called in a context in which the match data \(see
213 :     `match-data'\) are current for `sml-error-regexp'. The mode sets the
214 :     default value to the function `sml-smlnj-error-parser'.
215 :    
216 :     In a step towards greater sml-mode modularity END-LINE-COL can be either
217 :    
218 :     - the symbol nil \(in which case it is ignored\)
219 :    
220 :     or
221 :    
222 :     - an Emacs Lisp expression that when `eval'd at \(start-line,start-col\)
223 :     will move point to the end of the errorful text in the file.
224 :    
225 :     Note that the compiler should return the full path name of the errorful
226 :     file, and that this might require you to fiddle with the compiler's
227 :     prettyprinting switches.")
228 :    
229 :     ;; std_in:2.1-4.3 Error: operator and operand don't agree (tycon mismatch)
230 :     ;; std_in:2.1 Error: operator and operand don't agree (tycon mismatch)
231 :    
232 : monnier 332 (defconst sml-error-regexp-alist
233 :     '(;; Poly/ML messages
234 :     ("\\(Error\\|Warning:\\) in '\\(.+\\)', line \\([0-9]+\\)" 2 3)
235 :     ;; Moscow ML
236 :     ("File \"\\([^\"]+\\)\", line \\([0-9]+\\)\\(-\\([0-9]+\\)\\)?, characters \\([0-9]+\\)-\\([0-9]+\\):" 1 2 5)
237 : monnier 342 ;; SML/NJ: the file-pattern is restricted to no-spaces to avoid
238 :     ;; pathological behavior with very long lines.
239 :     ("^[-= ]*\\([^ ]+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warning\\): .*" 1 sml-make-error 2 3 5 6)
240 :     ;; SML/NJ's exceptions: see above.
241 :     ("^ +\\(raised at: \\)?\\([^ ]+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2 sml-make-error 3 4 6 7)))
242 : monnier 32
243 : monnier 332 (defvar sml-error-regexp nil
244 : monnier 32 "*Regexp for matching \(the start of\) an error message.")
245 :    
246 : monnier 33 ;; font-lock support
247 : monnier 332 (defconst inferior-sml-font-lock-keywords
248 :     `(;; prompt and following interactive command
249 :     (,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
250 : monnier 33 (1 font-lock-prompt-face)
251 :     (2 font-lock-command-face keep))
252 : monnier 332 ;; CM's messages
253 : monnier 39 ("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face)
254 : monnier 332 ;; SML/NJ's irritating GC messages
255 :     ("^GC #.*" . font-lock-comment-face)
256 :     ;; error messages
257 :     ,@(mapcar (lambda (ra) (cons (car ra) 'font-lock-warning-face))
258 :     sml-error-regexp-alist))
259 :     "Font-locking specification for inferior SML mode.")
260 : monnier 33
261 :     ;; default faces values
262 :     (defvar font-lock-prompt-face
263 :     (if (facep 'font-lock-prompt-face)
264 :     'font-lock-prompt-face
265 :     'font-lock-keyword-face))
266 :     (defvar font-lock-command-face
267 :     (if (facep 'font-lock-command-face)
268 :     'font-lock-command-face
269 :     'font-lock-function-name-face))
270 :    
271 :     (defvar inferior-sml-font-lock-defaults
272 :     '(inferior-sml-font-lock-keywords nil nil nil nil))
273 :    
274 : monnier 32 ;;; CODE
275 :    
276 : monnier 319 (defmap inferior-sml-mode-map
277 :     '(("\C-c\C-s" . run-sml)
278 :     ("\t" . comint-dynamic-complete))
279 :     "Keymap for inferior-sml mode"
280 :     :inherit (list sml-bindings comint-mode-map))
281 : monnier 32
282 : monnier 319
283 : monnier 32 ;; buffer-local
284 :    
285 : monnier 332 (defvar sml-temp-file nil)
286 : monnier 32 (defvar sml-error-file nil) ; file from which the last error came
287 :     (defvar sml-error-cursor nil) ; ditto
288 :    
289 :     (defun sml-proc-buffer ()
290 :     "Returns the current ML process buffer,
291 :     or the current buffer if it is in `inferior-sml-mode'. Raises an error
292 :     if the variable `sml-buffer' does not appear to point to an existing
293 :     buffer."
294 : monnier 332 (or (and (eq major-mode 'inferior-sml-mode) (current-buffer))
295 :     (and sml-buffer
296 :     (let ((buf (get-buffer sml-buffer)))
297 :     ;; buffer-name returns nil if the buffer has been killed
298 :     (and buf (buffer-name buf) buf)))
299 :     ;; no buffer found, make a new one
300 :     (run-sml t)))
301 : monnier 32
302 :     (defun sml-proc ()
303 :     "Returns the current ML process. See variable `sml-buffer'."
304 : monnier 332 (assert (eq major-mode 'inferior-sml-mode))
305 :     (or (get-buffer-process (current-buffer))
306 :     (progn (run-sml t) (get-buffer-process (current-buffer)))))
307 : monnier 32
308 :     (defun sml-buffer (echo)
309 :     "Make the current buffer the current `sml-buffer' if that is sensible.
310 :     Lookup variable `sml-buffer' to see why this might be useful."
311 :     (interactive "P")
312 : monnier 332 (when (and (not echo) (eq major-mode 'inferior-sml-mode))
313 :     (setq sml-buffer (current-buffer)))
314 :     (message "ML process buffer is %s."
315 :     (or (ignore-errors (buffer-name (get-buffer sml-buffer)))
316 :     "undefined")))
317 : monnier 32
318 :     (defun inferior-sml-mode ()
319 :     "Major mode for interacting with an inferior ML process.
320 :    
321 :     The following commands are available:
322 :     \\{inferior-sml-mode-map}
323 :    
324 :     An ML process can be fired up (again) with \\[sml].
325 :    
326 :     Customisation: Entry to this mode runs the hooks on `comint-mode-hook'
327 :     and `inferior-sml-mode-hook' (in that order).
328 :    
329 :     Variables controlling behaviour of this mode are
330 :    
331 :     `sml-program-name' (default \"sml\")
332 :     Program to run as ML.
333 :    
334 :     `sml-use-command' (default \"use \\\"%s\\\"\")
335 :     Template for loading a file into the inferior ML process.
336 :    
337 :     `sml-cd-command' (default \"System.Directory.cd \\\"%s\\\"\")
338 :     ML command for changing directories in ML process (if possible).
339 :    
340 :     `sml-prompt-regexp' (default \"^[\\-=] *\")
341 :     Regexp used to recognise prompts in the inferior ML process.
342 :    
343 :     `sml-error-regexp'
344 :     (default -- complicated)
345 :     Regexp for matching error messages from the compiler.
346 :    
347 :     `sml-error-parser' (default 'sml-smlnj-error-parser)
348 :     This function parses a error messages into a 3, 4 or 5 element list:
349 :     (file start-line start-col (end-line end-col) err-msg).
350 :    
351 :     You can send text to the inferior ML process from other buffers containing
352 :     ML source.
353 :     `switch-to-sml' switches the current buffer to the ML process buffer.
354 :     `sml-send-function' sends the current *paragraph* to the ML process.
355 :     `sml-send-region' sends the current region to the ML process.
356 :    
357 :     Prefixing the sml-send-<whatever> commands with \\[universal-argument]
358 :     causes a switch to the ML process buffer after sending the text.
359 :    
360 :     For information on running multiple processes in multiple buffers, see
361 :     documentation for variable `sml-buffer'.
362 :    
363 :     Commands:
364 :     RET after the end of the process' output sends the text from the
365 :     end of process to point.
366 :     RET before the end of the process' output copies the current line
367 :     to the end of the process' output, and sends it.
368 :     DEL converts tabs to spaces as it moves back.
369 :     TAB file name completion, as in shell-mode, etc.."
370 :     (interactive)
371 :     (kill-all-local-variables)
372 :     (comint-mode)
373 :     (setq comint-prompt-regexp sml-prompt-regexp)
374 :     (sml-mode-variables)
375 :    
376 :     ;; For sequencing through error messages:
377 : monnier 300 (set (make-local-variable 'sml-error-cursor) (point-max-marker))
378 : monnier 332 (set-marker-insertion-type sml-error-cursor nil)
379 : monnier 33 (set (make-local-variable 'font-lock-defaults)
380 :     inferior-sml-font-lock-defaults)
381 : monnier 32
382 : monnier 332 ;; compilation support (used for next-error)
383 :     (set (make-local-variable 'compilation-error-regexp-alist)
384 :     sml-error-regexp-alist)
385 :     (compilation-shell-minor-mode 1)
386 :     ;; I'm sure people might kill me for that
387 :     (setq compilation-error-screen-columns nil)
388 :     (make-local-variable 'sml-endof-error-alist)
389 :     ;;(make-local-variable 'sml-error-overlay)
390 : monnier 32
391 :     (setq major-mode 'inferior-sml-mode)
392 :     (setq mode-name "Inferior ML")
393 :     (setq mode-line-process '(": %s"))
394 :     (use-local-map inferior-sml-mode-map)
395 : monnier 332 ;;(add-hook 'kill-emacs-hook 'sml-temp-tidy)
396 : monnier 32
397 :     (run-hooks 'inferior-sml-mode-hook))
398 :    
399 :     ;;; FOR RUNNING ML FROM EMACS
400 :    
401 : monnier 33 ;;;###autoload
402 :     (defun run-sml (&optional pfx)
403 : monnier 32 "Run an inferior ML process, input and output via buffer *sml*.
404 :     With a prefix argument, this command allows you to specify any command
405 :     line options to pass to the complier. The command runs hook functions
406 :     on `comint-mode-hook' and `inferior-sml-mode-hook' in that order.
407 :    
408 :     If there is a process already running in *sml*, just switch to that
409 :     buffer instead.
410 :    
411 :     In fact the name of the buffer created is chosen to reflect the name
412 :     of the program name specified by `sml-program-name', or entered at the
413 :     prompt. You can have several inferior ML process running, but only one
414 :     current one -- given by `sml-buffer' (qv).
415 :    
416 :     \(Type \\[describe-mode] in the process buffer for a list of commands.)"
417 :     (interactive "P")
418 :     (let ((cmd (if pfx
419 :     (read-string "ML command: " sml-program-name)
420 :     sml-program-name))
421 :     (args (if pfx
422 :     (read-string "Any args: " sml-default-arg)
423 :     sml-default-arg)))
424 :     (sml-run cmd args)))
425 :    
426 :     (defun sml-run (cmd arg)
427 :     "Run the ML program CMD with given arguments ARGS.
428 :     This usually updates `sml-buffer' to a buffer named *CMD*."
429 :     (let* ((pname (file-name-nondirectory cmd))
430 :     (args (if (equal arg "") () (sml-args-to-list arg))))
431 : monnier 332 ;; and this -- to keep these as defaults even if
432 :     ;; they're set in the mode hooks.
433 :     (setq sml-program-name cmd)
434 :     (setq sml-default-arg arg)
435 :     (setq sml-buffer (apply 'make-comint pname cmd nil args))
436 : monnier 32
437 : monnier 332 (set-buffer sml-buffer)
438 :     (message (format "Starting \"%s\" in background." pname))
439 :     (inferior-sml-mode)
440 :     (goto-char (point-max))
441 :     sml-buffer))
442 :    
443 : monnier 32 (defun sml-args-to-list (string)
444 :     (let ((where (string-match "[ \t]" string)))
445 :     (cond ((null where) (list string))
446 :     ((not (= where 0))
447 :     (cons (substring string 0 where)
448 :     (sml-args-to-list (substring string (+ 1 where)
449 :     (length string)))))
450 :     (t (let ((pos (string-match "[^ \t]" string)))
451 :     (if (null pos)
452 :     nil
453 :     (sml-args-to-list (substring string pos
454 :     (length string)))))))))
455 :    
456 :     ;;;###autoload
457 :     (defun switch-to-sml (eob-p)
458 :     "Switch to the ML process buffer.
459 :     With prefix argument, positions cursor at point, otherwise at end of buffer."
460 :     (interactive "P")
461 : monnier 33 (pop-to-buffer (sml-proc-buffer))
462 : monnier 32 (cond ((not eob-p)
463 :     (push-mark (point) t)
464 :     (goto-char (point-max)))))
465 :    
466 :     ;; Fakes it with a "use <temp-file>;" if necessary.
467 :    
468 :     ;;;###autoload
469 :     (defun sml-send-region (start end &optional and-go)
470 :     "Send current region to the inferior ML process.
471 :     Prefix argument means switch-to-sml afterwards.
472 :    
473 : monnier 332 The region is written out to a temporary file and a \"use <temp-file>\" command
474 :     is sent to the compiler.
475 :     See variables `sml-use-command'."
476 : monnier 32 (interactive "r\nP")
477 : monnier 332 (if (= start end)
478 :     (message "The region is zero (ignored)")
479 :     (let* ((buf (sml-proc-buffer))
480 :     (file (buffer-file-name))
481 :     (marker (copy-marker start))
482 :     (tmp (make-temp-file "sml")))
483 :     (write-region start end tmp nil 'silently)
484 :     (with-current-buffer buf
485 :     (when sml-temp-file
486 :     (ignore-errors (delete-file (car sml-temp-file)))
487 :     (set-marker (cdr sml-temp-file) nil))
488 :     (setq sml-temp-file (cons tmp marker))
489 :     (sml-send-string (format sml-use-command tmp) nil and-go)))))
490 : monnier 32
491 :     ;; This is quite bogus, so it isn't bound to a key by default.
492 :     ;; Anyone coming up with an algorithm to recognise fun & local
493 :     ;; declarations surrounding point will do everyone a favour!
494 :    
495 :     (defun sml-send-function (&optional and-go)
496 :     "Send current paragraph to the inferior ML process.
497 :     With a prefix argument switch to the sml buffer as well
498 :     \(cf. `sml-send-region'\)."
499 :     (interactive "P")
500 :     (save-excursion
501 :     (sml-mark-function)
502 :     (sml-send-region (point) (mark)))
503 :     (if and-go (switch-to-sml nil)))
504 :    
505 : monnier 332 (defvar sml-source-modes '(sml-mode)
506 :     "*Used to determine if a buffer contains ML source code.
507 : monnier 319 If it's loaded into a buffer that is in one of these major modes, it's
508 :     considered an ML source file by `sml-load-file'. Used by these commands
509 :     to determine defaults.")
510 :    
511 : monnier 32 ;;;###autoload
512 :     (defun sml-send-buffer (&optional and-go)
513 :     "Send buffer to inferior shell running ML process.
514 :     With a prefix argument switch to the sml buffer as well
515 :     \(cf. `sml-send-region'\)."
516 :     (interactive "P")
517 :     (if (memq major-mode sml-source-modes)
518 :     (sml-send-region (point-min) (point-max) and-go)))
519 :    
520 :     ;; Since sml-send-function/region take an optional prefix arg, these
521 :     ;; commands are redundant. But they are kept around for the user to
522 :     ;; bind if she wishes, since its easier to type C-c r than C-u C-c C-r.
523 :    
524 :     (defun sml-send-region-and-go (start end)
525 :     "Send current region to the inferior ML process, and go there."
526 :     (interactive "r")
527 :     (sml-send-region start end t))
528 :    
529 :     (defun sml-send-function-and-go ()
530 :     "Send current paragraph to the inferior ML process, and go there."
531 :     (interactive)
532 :     (sml-send-function t))
533 :    
534 :    
535 :     ;;; Mouse control and handling dedicated frames for Inferior ML
536 :    
537 :     ;; simplified from frame.el in Emacs: special-display-popup-frame...
538 :    
539 : monnier 332 ;; (defun sml-proc-frame ()
540 :     ;; "Returns the current ML process buffer's frame, or creates one first."
541 :     ;; (let ((buffer (sml-proc-buffer)))
542 :     ;; (window-frame (display-buffer buffer))))
543 : monnier 32
544 :     ;;; 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
545 :    
546 :     ;; Only these two functions have to dance around the inane differences
547 :     ;; between Emacs and XEmacs (fortunately)
548 :    
549 : monnier 332 ;; (defun sml-warp-mouse (frame)
550 :     ;; "Warp the pointer across the screen to upper right corner of FRAME."
551 :     ;; (raise-frame frame)
552 :     ;; (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)
553 :     ;; ;; LUCID (19.10) or later... set-m-pos needs a WINDOW
554 :     ;; (set-mouse-position (frame-root-window frame) (1- (frame-width)) 0))
555 :     ;; (t
556 :     ;; ;; GNU, post circa 19.19... set-m-pos needs a FRAME
557 :     ;; (set-mouse-position frame (1- (frame-width)) 0)
558 :     ;; ;; probably not needed post 19.29
559 :     ;; (if (fboundp 'unfocus-frame) (unfocus-frame)))))
560 : monnier 32
561 :     (defun sml-drag-region (event)
562 :     "Highlight the text the mouse is dragged over, and send it to ML.
563 :     This must be bound to a button-down mouse event, currently \\[sml-drag-region].
564 :    
565 :     If you drag the mouse (ie, keep the mouse button depressed) the
566 :     program text sent to the complier is delimited by where you started
567 :     dragging the mouse, and where you release the mouse button.
568 :    
569 :     If you only click the mouse, the program text sent to the compiler is
570 :     delimited by the current position of point and the place where you
571 :     click the mouse.
572 :    
573 :     In either event, the values of both point and mark are left
574 :     undisturbed once this operation is completed."
575 :     (interactive "e")
576 :     (let ((mark-ring) ;BAD: selection start gets cons'd
577 :     (pmark (point))) ;where point is now
578 :     (if (fboundp 'mouse-track-default)
579 :     ;; Assume this is XEmacs, otherwise assume its Emacs
580 :     (save-excursion
581 :     (let ((zmacs-regions))
582 :     (set-marker (mark-marker) nil)
583 :     (mouse-track-default event)
584 :     (if (not (region-exists-p)) (push-mark pmark nil t))
585 :     (call-interactively 'sml-send-region)))
586 :     ;; Emacs: making this buffer-local ought to happen in sml-mode
587 :     (make-local-variable 'transient-mark-mode)
588 :     (save-excursion
589 :     (let ((transient-mark-mode 1))
590 :     (mouse-drag-region event)
591 :     (if (not mark-active) (push-mark pmark nil t))
592 :     (call-interactively 'sml-send-region))))))
593 :    
594 :    
595 :     ;;; LOADING AND IMPORTING SOURCE FILES:
596 :    
597 : monnier 332 (defvar sml-prev-dir/file nil
598 : monnier 32 "Caches the (directory . file) pair used in the last `sml-load-file'
599 :     or `sml-cd' command. Used for determining the default in the next one.")
600 :    
601 :     ;;;###autoload
602 :     (defun sml-load-file (&optional and-go)
603 :     "Load an ML file into the current inferior ML process.
604 :     With a prefix argument switch to sml buffer as well.
605 :    
606 :     This command uses the ML command template `sml-use-command' to construct
607 :     the command to send to the ML process\; a trailing \"\;\\n\" will be added
608 :     automatically."
609 :     (interactive "P")
610 : monnier 332 (let ((file (car (comint-get-source
611 :     "Load ML file: " sml-prev-dir/file sml-source-modes t))))
612 :     (with-current-buffer (sml-proc-buffer)
613 :     ;; Check if buffer needs saved. Should (save-some-buffers) instead?
614 :     (comint-check-source file)
615 :     (setq sml-prev-dir/file
616 :     (cons (file-name-directory file) (file-name-nondirectory file)))
617 :     (sml-send-string (format sml-use-command file) nil and-go))))
618 : monnier 32
619 :     (defun sml-cd (dir)
620 :     "Change the working directory of the inferior ML process.
621 :     The default directory of the process buffer is changed to DIR. If the
622 :     variable `sml-cd-command' is non-nil it should be an ML command that will
623 :     be executed to change the compiler's working directory\; a trailing
624 :     \"\;\\n\" will be added automatically."
625 :     (interactive "DSML Directory: ")
626 : monnier 332 (let ((dir (expand-file-name dir)))
627 :     (with-current-buffer (sml-proc-buffer)
628 :     (sml-send-string (format sml-cd-command dir) t)
629 :     (setq default-directory dir))
630 :     (setq sml-prev-dir/file (cons dir nil))))
631 : monnier 32
632 : monnier 332 (defun sml-send-string (str &optional print and-go)
633 :     (let ((proc (sml-proc))
634 :     (str (concat str ";\n"))
635 :     (win (get-buffer-window (current-buffer) 'visible)))
636 :     (when win (select-window win))
637 :     (goto-char (point-max))
638 :     (when print (insert str))
639 :     (sml-update-cursor)
640 :     (set-marker (process-mark proc) (point-max))
641 :     (setq compilation-last-buffer (current-buffer))
642 :     (comint-send-string proc str)
643 :     (when and-go (switch-to-sml nil))))
644 : monnier 32
645 : monnier 332 (defun sml-compile (command)
646 : monnier 33 "re-make a system using (by default) CM.
647 :     The exact command used can be specified by providing a prefix argument."
648 :     (interactive
649 :     ;; code taken straight from compile.el
650 : monnier 332 (if (or compilation-read-command current-prefix-arg)
651 : monnier 33 (list (read-from-minibuffer "Compile command: "
652 : monnier 332 sml-compile-command nil nil
653 : monnier 33 '(compile-history . 1)))
654 : monnier 332 (list sml-compile-command)))
655 :     (setq sml-compile-command command)
656 :     (save-some-buffers (not compilation-ask-about-save) nil)
657 :     ;; try to find a makefile up the directory tree
658 :     (let ((dir (when sml-make-file-name default-directory)))
659 : monnier 33 (while (and dir (not (file-exists-p (concat dir sml-make-file-name))))
660 :     (let ((newdir (file-name-directory (directory-file-name dir))))
661 : monnier 332 (setq dir (unless (equal newdir dir) newdir))))
662 :     (unless dir (setq dir default-directory))
663 :     (with-current-buffer (sml-proc-buffer)
664 :     (setq default-directory dir)
665 :     (sml-send-string (concat (format sml-cd-command dir) "; " command) t t))))
666 : monnier 32
667 : monnier 33 ;;; PARSING ERROR MESSAGES
668 : monnier 32
669 :     ;; This should need no modification to support other compilers.
670 :    
671 : monnier 332 ;; Update the buffer-local error-cursor in proc-buffer to be its
672 :     ;; current proc mark.
673 : monnier 32
674 : monnier 332 (defvar sml-endof-error-alist nil)
675 : monnier 32
676 : monnier 332 (defun sml-update-cursor ()
677 :     ;; update buffer local variable
678 :     (set-marker sml-error-cursor (1- (process-mark (sml-proc))))
679 :     (setq sml-endof-error-alist nil)
680 :     (compilation-forget-errors)
681 :     (setq compilation-parsing-end sml-error-cursor))
682 : monnier 32
683 : monnier 332 (defun sml-make-error (f c)
684 :     (let ((err (point-marker))
685 :     (linenum (string-to-number c))
686 :     (filename (list (first f) (second f)))
687 :     (column (string-to-number (compile-buffer-substring (third f)))))
688 :     ;; record the end of error, if any
689 :     (when (fourth f)
690 :     (let* ((endline (string-to-number (compile-buffer-substring (fourth f))))
691 :     (endcol (string-to-number (compile-buffer-substring (fifth f))))
692 :     (linediff (- endline linenum)))
693 :     (push (list err linediff (if (= 0 linediff) (- endcol column) endcol))
694 :     sml-endof-error-alist)))
695 :     ;; build the error descriptor
696 :     (if (string= (car sml-temp-file) (first f))
697 :     ;; special case for code sent via sml-send-region
698 :     (let ((marker (cdr sml-temp-file)))
699 :     (with-current-buffer (marker-buffer marker)
700 :     (goto-char marker)
701 :     (forward-line (1- linenum))
702 :     (forward-char (1- column))
703 :     (cons err (point-marker))))
704 :     ;; taken from compile.el
705 :     (list err filename linenum column))))
706 : monnier 32
707 : monnier 332 (defadvice compilation-goto-locus (after sml-endof-error activate)
708 :     (let* ((next-error (ad-get-arg 0))
709 :     (err (car next-error))
710 :     (pos (cdr next-error))
711 :     (endof (with-current-buffer (marker-buffer err)
712 :     (assq err sml-endof-error-alist))))
713 :     (if (not endof) (sml-error-overlay 'undo)
714 :     (with-current-buffer (marker-buffer pos)
715 :     (goto-char pos)
716 :     (let ((linediff (second endof))
717 :     (coldiff (third endof)))
718 :     (when (> 0 linediff) (forward-line linediff))
719 :     (forward-char coldiff))
720 :     (sml-error-overlay nil pos (point))
721 :     (push-mark nil t (not sml-error-overlay))
722 :     (goto-char pos)))))
723 : monnier 32
724 : monnier 332 (defun sml-error-overlay (undo &optional beg end)
725 :     "Move `sml-error-overlay' so it surrounds the text region in the
726 :     current buffer. If the buffer-local variable `sml-error-overlay' is
727 :     non-nil it should be an overlay \(or extent, in XEmacs speak\)\; this
728 :     function moves the overlay over the current region. If the optional
729 :     BUFFER argument is given, move the overlay in that buffer instead of
730 :     the current buffer.
731 :    
732 :     Called interactively, the optional prefix argument UNDO indicates that
733 :     the overlay should simply be removed: \\[universal-argument] \
734 :     \\[sml-error-overlay]."
735 : monnier 32 (interactive "P")
736 : monnier 332 (when sml-error-overlay
737 :     (unless (overlayp sml-error-overlay)
738 :     (let ((ol sml-error-overlay))
739 :     (setq sml-error-overlay (make-overlay 0 0))
740 :     (overlay-put sml-error-overlay 'face (if (symbolp ol) ol 'region))))
741 :     (if undo
742 :     (move-overlay sml-error-overlay 1 1 (current-buffer))
743 :     ;; if active regions, signals mark not active if no region set
744 :     (let ((beg (or beg (region-beginning)))
745 :     (end (or end (region-end))))
746 :     (move-overlay sml-error-overlay beg end (current-buffer))))))
747 : monnier 32
748 : monnier 332 ;; ;;;###autoload
749 :     ;; (defun sml-next-error (skip)
750 :     ;; "Find the next error by parsing the inferior ML buffer.
751 :     ;; A prefix argument means `sml-skip-errors' (qv) instead.
752 : monnier 32
753 : monnier 332 ;; Move the error message on the top line of the window\; put the cursor
754 :     ;; \(point\) at the beginning of the error source.
755 : monnier 32
756 : monnier 332 ;; If the error message specifies a range, and `sml-error-parser' returns
757 :     ;; the range, the mark is placed at the end of the range. If the variable
758 :     ;; `sml-error-overlay' is non-nil, the region will also be highlighted.
759 : monnier 32
760 : monnier 332 ;; If `sml-error-parser' returns a fifth component this is assumed to be
761 :     ;; a string to indicate the nature of the error: this will be echoed in
762 :     ;; the minibuffer.
763 :    
764 :     ;; Error interaction only works if there is a real file associated with
765 :     ;; the input -- though of course it also depends on the compiler's error
766 :     ;; messages \(also see documantation for `sml-error-parser'\).
767 :    
768 :     ;; However: if the last text sent went via `sml-load-file' (or the temp
769 :     ;; file mechanism), the next error reported will be relative to the start
770 :     ;; of the region sent, any error reports in the previous output being
771 :     ;; forgotten. If the text went directly to the compiler the succeeding
772 :     ;; error reported will be the next error relative to the location \(in
773 :     ;; the output\) of the last error. This odd behaviour may have a use...?"
774 :     ;; (interactive "P")
775 :     ;; (if skip (sml-skip-errors) (sml-do-next-error)))
776 :    
777 :     ;; (defun sml-do-next-error ()
778 :     ;; "The business end of `sml-next-error' (qv)"
779 :     ;; (let ((case-fold-search nil)
780 :     ;; ;; set this variable iff we called sml-next-error in a SML buffer
781 :     ;; (sml-window (if (memq major-mode sml-source-modes) (selected-window)))
782 :     ;; (proc-buffer (sml-proc-buffer)))
783 :     ;; ;; undo (don't destroy) the previous overlay to be tidy
784 :     ;; (sml-error-overlay 'undo 1 1
785 :     ;; (and sml-error-file (get-file-buffer sml-error-file)))
786 :     ;; ;; go to interaction buffer but don't raise it's frame
787 :     ;; (pop-to-buffer (sml-proc-buffer))
788 :     ;; ;; go to the last remembered error, and search for the next one.
789 :     ;; (goto-char sml-error-cursor)
790 :     ;; (if (not (re-search-forward sml-error-regexp (point-max) t))
791 :     ;; ;; no more errors -- move point to the sml prompt at the end
792 :     ;; (progn
793 :     ;; (goto-char (point-max))
794 :     ;; (if sml-window (select-window sml-window)) ;return there, perhaps
795 :     ;; (message "No error message(s) found."))
796 :     ;; ;; error found: point is at end of last match; set the cursor posn.
797 :     ;; (set-marker sml-error-cursor (point))
798 :     ;; ;; move the SML window's text up to this line
799 :     ;; (set-window-start (get-buffer-window proc-buffer) (match-beginning 0))
800 :     ;; (let* ((pos)
801 :     ;; (parse (funcall sml-error-parser (match-beginning 0)))
802 :     ;; (file (nth 0 parse))
803 :     ;; (line0 (nth 1 parse))
804 :     ;; (col0 (nth 2 parse))
805 :     ;; (line/col1 (nth 3 parse))
806 :     ;; (msg (nth 4 parse)))
807 :     ;; ;; Give up immediately if the error report is scribble
808 :     ;; (if (or (null file) (null line0))
809 :     ;; (error "Failed to parse/locate this error properly!"))
810 :     ;; ;; decide what to do depending on the file returned
811 :     ;; (when (string= file "std_in")
812 :     ;; ;; presently a fundamental limitation i'm afraid.
813 :     ;; (error "Sorry, can't locate errors on std_in."))
814 :     ;; ;; jump to the beginning
815 :     ;; (if (string= file (car sml-temp-file))
816 :     ;; (let* ((maker (cdr sml-temp-file))
817 :     ;; (buf (marker-buffer marker)))
818 :     ;; (display-buffer buf)
819 :     ;; (set-buffer buf)
820 :     ;; (goto-char marker))
821 :     ;; (unless (file-readable-p file) (error "Can't read %s" file))
822 :     ;; ;; instead of (find-file-other-window file) to lookup the file
823 :     ;; (find-file-other-window file)
824 :     ;; ;; no good if the buffer's narrowed, still...
825 :     ;; (goto-char (point-min)))
826 :     ;; ;; jump to the error
827 :     ;; (forward-line (1- line0))
828 :     ;; (forward-char (1- col0))
829 :     ;; ;; point is at start of error text; seek the end.
830 :     ;; (let ((start (point))
831 :     ;; (end (and line/col1
832 :     ;; (condition-case nil
833 :     ;; (progn (eval line/col1) (point))
834 :     ;; (error nil)))))
835 :     ;; ;; return to start anyway
836 :     ;; (goto-char start)
837 :     ;; ;; if point went to end, put mark there, and maybe highlight
838 :     ;; (if end (progn (push-mark end t)
839 :     ;; (sml-error-overlay nil start end)))
840 :     ;; (setq sml-error-file file) ; remember this for next time
841 :     ;; (if msg (message msg))))))) ; echo the error/warning message
842 :    
843 :     ;; (defun sml-skip-errors ()
844 :     ;; "Skip past the rest of the errors."
845 :     ;; (interactive)
846 :     ;; (if (memq major-mode sml-source-modes) (sml-error-overlay 'undo))
847 :     ;; (with-current-buffer (sml-proc-buffer) (sml-update-cursor))
848 :     ;; (if (eq major-mode 'sml-inferior-mode) (goto-char (point-max))))
849 :    
850 : monnier 32 ;;; 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
851 :    
852 :     (if window-system
853 :     (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)
854 :     ;; LUCID (19.10) or later...
855 :     (define-key sml-mode-map '(meta shift button1) 'sml-drag-region))
856 :     (t
857 :     ;; GNU, post circa 19.19
858 :     (define-key sml-mode-map [M-S-down-mouse-1] 'sml-drag-region))))
859 :    
860 :     ;;; ...and do the user's customisations.
861 :    
862 :     (run-hooks 'inferior-sml-load-hook)
863 :    
864 :     ;;; Here is where sml-proc.el ends
865 : monnier 332 (provide 'sml-proc)

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