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 332 - (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 :     ;; SML/NJ
238 :     ("[-= ]*\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warning\\): .*" 1 sml-make-error 2 3 5 6)
239 :     ;; SML/NJ's exceptions
240 :     (" +\\(raised at: \\)?\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2 sml-make-error 3 4 6 7)))
241 : monnier 32
242 : monnier 332 (defvar sml-error-regexp nil
243 : monnier 32 "*Regexp for matching \(the start of\) an error message.")
244 :    
245 : monnier 33 ;; font-lock support
246 : monnier 332 (defconst inferior-sml-font-lock-keywords
247 :     `(;; prompt and following interactive command
248 :     (,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
249 : monnier 33 (1 font-lock-prompt-face)
250 :     (2 font-lock-command-face keep))
251 : monnier 332 ;; CM's messages
252 : monnier 39 ("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face)
253 : monnier 332 ;; SML/NJ's irritating GC messages
254 :     ("^GC #.*" . font-lock-comment-face)
255 :     ;; error messages
256 :     ,@(mapcar (lambda (ra) (cons (car ra) 'font-lock-warning-face))
257 :     sml-error-regexp-alist))
258 :     "Font-locking specification for inferior SML mode.")
259 : monnier 33
260 :     ;; default faces values
261 :     (defvar font-lock-prompt-face
262 :     (if (facep 'font-lock-prompt-face)
263 :     'font-lock-prompt-face
264 :     'font-lock-keyword-face))
265 :     (defvar font-lock-command-face
266 :     (if (facep 'font-lock-command-face)
267 :     'font-lock-command-face
268 :     'font-lock-function-name-face))
269 :    
270 :     (defvar inferior-sml-font-lock-defaults
271 :     '(inferior-sml-font-lock-keywords nil nil nil nil))
272 :    
273 : monnier 32 ;;; CODE
274 :    
275 : monnier 319 (defmap inferior-sml-mode-map
276 :     '(("\C-c\C-s" . run-sml)
277 :     ("\t" . comint-dynamic-complete))
278 :     "Keymap for inferior-sml mode"
279 :     :inherit (list sml-bindings comint-mode-map))
280 : monnier 32
281 : monnier 319
282 : monnier 32 ;; buffer-local
283 :    
284 : monnier 332 (defvar sml-temp-file nil)
285 : monnier 32 (defvar sml-error-file nil) ; file from which the last error came
286 :     (defvar sml-error-cursor nil) ; ditto
287 :    
288 :     (defun sml-proc-buffer ()
289 :     "Returns the current ML process buffer,
290 :     or the current buffer if it is in `inferior-sml-mode'. Raises an error
291 :     if the variable `sml-buffer' does not appear to point to an existing
292 :     buffer."
293 : monnier 332 (or (and (eq major-mode 'inferior-sml-mode) (current-buffer))
294 :     (and sml-buffer
295 :     (let ((buf (get-buffer sml-buffer)))
296 :     ;; buffer-name returns nil if the buffer has been killed
297 :     (and buf (buffer-name buf) buf)))
298 :     ;; no buffer found, make a new one
299 :     (run-sml t)))
300 : monnier 32
301 :     (defun sml-proc ()
302 :     "Returns the current ML process. See variable `sml-buffer'."
303 : monnier 332 (assert (eq major-mode 'inferior-sml-mode))
304 :     (or (get-buffer-process (current-buffer))
305 :     (progn (run-sml t) (get-buffer-process (current-buffer)))))
306 : monnier 32
307 :     (defun sml-buffer (echo)
308 :     "Make the current buffer the current `sml-buffer' if that is sensible.
309 :     Lookup variable `sml-buffer' to see why this might be useful."
310 :     (interactive "P")
311 : monnier 332 (when (and (not echo) (eq major-mode 'inferior-sml-mode))
312 :     (setq sml-buffer (current-buffer)))
313 :     (message "ML process buffer is %s."
314 :     (or (ignore-errors (buffer-name (get-buffer sml-buffer)))
315 :     "undefined")))
316 : monnier 32
317 :     (defun inferior-sml-mode ()
318 :     "Major mode for interacting with an inferior ML process.
319 :    
320 :     The following commands are available:
321 :     \\{inferior-sml-mode-map}
322 :    
323 :     An ML process can be fired up (again) with \\[sml].
324 :    
325 :     Customisation: Entry to this mode runs the hooks on `comint-mode-hook'
326 :     and `inferior-sml-mode-hook' (in that order).
327 :    
328 :     Variables controlling behaviour of this mode are
329 :    
330 :     `sml-program-name' (default \"sml\")
331 :     Program to run as ML.
332 :    
333 :     `sml-use-command' (default \"use \\\"%s\\\"\")
334 :     Template for loading a file into the inferior ML process.
335 :    
336 :     `sml-cd-command' (default \"System.Directory.cd \\\"%s\\\"\")
337 :     ML command for changing directories in ML process (if possible).
338 :    
339 :     `sml-prompt-regexp' (default \"^[\\-=] *\")
340 :     Regexp used to recognise prompts in the inferior ML process.
341 :    
342 :     `sml-error-regexp'
343 :     (default -- complicated)
344 :     Regexp for matching error messages from the compiler.
345 :    
346 :     `sml-error-parser' (default 'sml-smlnj-error-parser)
347 :     This function parses a error messages into a 3, 4 or 5 element list:
348 :     (file start-line start-col (end-line end-col) err-msg).
349 :    
350 :     You can send text to the inferior ML process from other buffers containing
351 :     ML source.
352 :     `switch-to-sml' switches the current buffer to the ML process buffer.
353 :     `sml-send-function' sends the current *paragraph* to the ML process.
354 :     `sml-send-region' sends the current region to the ML process.
355 :    
356 :     Prefixing the sml-send-<whatever> commands with \\[universal-argument]
357 :     causes a switch to the ML process buffer after sending the text.
358 :    
359 :     For information on running multiple processes in multiple buffers, see
360 :     documentation for variable `sml-buffer'.
361 :    
362 :     Commands:
363 :     RET after the end of the process' output sends the text from the
364 :     end of process to point.
365 :     RET before the end of the process' output copies the current line
366 :     to the end of the process' output, and sends it.
367 :     DEL converts tabs to spaces as it moves back.
368 :     TAB file name completion, as in shell-mode, etc.."
369 :     (interactive)
370 :     (kill-all-local-variables)
371 :     (comint-mode)
372 :     (setq comint-prompt-regexp sml-prompt-regexp)
373 :     (sml-mode-variables)
374 :    
375 :     ;; For sequencing through error messages:
376 : monnier 300 (set (make-local-variable 'sml-error-cursor) (point-max-marker))
377 : monnier 332 (set-marker-insertion-type sml-error-cursor nil)
378 : monnier 33 (set (make-local-variable 'font-lock-defaults)
379 :     inferior-sml-font-lock-defaults)
380 : monnier 32
381 : monnier 332 ;; compilation support (used for next-error)
382 :     (set (make-local-variable 'compilation-error-regexp-alist)
383 :     sml-error-regexp-alist)
384 :     (compilation-shell-minor-mode 1)
385 :     ;; I'm sure people might kill me for that
386 :     (setq compilation-error-screen-columns nil)
387 :     (make-local-variable 'sml-endof-error-alist)
388 :     ;;(make-local-variable 'sml-error-overlay)
389 : monnier 32
390 :     (setq major-mode 'inferior-sml-mode)
391 :     (setq mode-name "Inferior ML")
392 :     (setq mode-line-process '(": %s"))
393 :     (use-local-map inferior-sml-mode-map)
394 : monnier 332 ;;(add-hook 'kill-emacs-hook 'sml-temp-tidy)
395 : monnier 32
396 :     (run-hooks 'inferior-sml-mode-hook))
397 :    
398 :     ;;; FOR RUNNING ML FROM EMACS
399 :    
400 : monnier 33 ;;;###autoload
401 :     (defun run-sml (&optional pfx)
402 : monnier 32 "Run an inferior ML process, input and output via buffer *sml*.
403 :     With a prefix argument, this command allows you to specify any command
404 :     line options to pass to the complier. The command runs hook functions
405 :     on `comint-mode-hook' and `inferior-sml-mode-hook' in that order.
406 :    
407 :     If there is a process already running in *sml*, just switch to that
408 :     buffer instead.
409 :    
410 :     In fact the name of the buffer created is chosen to reflect the name
411 :     of the program name specified by `sml-program-name', or entered at the
412 :     prompt. You can have several inferior ML process running, but only one
413 :     current one -- given by `sml-buffer' (qv).
414 :    
415 :     \(Type \\[describe-mode] in the process buffer for a list of commands.)"
416 :     (interactive "P")
417 :     (let ((cmd (if pfx
418 :     (read-string "ML command: " sml-program-name)
419 :     sml-program-name))
420 :     (args (if pfx
421 :     (read-string "Any args: " sml-default-arg)
422 :     sml-default-arg)))
423 :     (sml-run cmd args)))
424 :    
425 :     (defun sml-run (cmd arg)
426 :     "Run the ML program CMD with given arguments ARGS.
427 :     This usually updates `sml-buffer' to a buffer named *CMD*."
428 :     (let* ((pname (file-name-nondirectory cmd))
429 :     (args (if (equal arg "") () (sml-args-to-list arg))))
430 : monnier 332 ;; and this -- to keep these as defaults even if
431 :     ;; they're set in the mode hooks.
432 :     (setq sml-program-name cmd)
433 :     (setq sml-default-arg arg)
434 :     (setq sml-buffer (apply 'make-comint pname cmd nil args))
435 : monnier 32
436 : monnier 332 (set-buffer sml-buffer)
437 :     (message (format "Starting \"%s\" in background." pname))
438 :     (inferior-sml-mode)
439 :     (goto-char (point-max))
440 :     sml-buffer))
441 :    
442 : monnier 32 (defun sml-args-to-list (string)
443 :     (let ((where (string-match "[ \t]" string)))
444 :     (cond ((null where) (list string))
445 :     ((not (= where 0))
446 :     (cons (substring string 0 where)
447 :     (sml-args-to-list (substring string (+ 1 where)
448 :     (length string)))))
449 :     (t (let ((pos (string-match "[^ \t]" string)))
450 :     (if (null pos)
451 :     nil
452 :     (sml-args-to-list (substring string pos
453 :     (length string)))))))))
454 :    
455 :     ;;;###autoload
456 :     (defun switch-to-sml (eob-p)
457 :     "Switch to the ML process buffer.
458 :     With prefix argument, positions cursor at point, otherwise at end of buffer."
459 :     (interactive "P")
460 : monnier 33 (pop-to-buffer (sml-proc-buffer))
461 : monnier 32 (cond ((not eob-p)
462 :     (push-mark (point) t)
463 :     (goto-char (point-max)))))
464 :    
465 :     ;; Fakes it with a "use <temp-file>;" if necessary.
466 :    
467 :     ;;;###autoload
468 :     (defun sml-send-region (start end &optional and-go)
469 :     "Send current region to the inferior ML process.
470 :     Prefix argument means switch-to-sml afterwards.
471 :    
472 : monnier 332 The region is written out to a temporary file and a \"use <temp-file>\" command
473 :     is sent to the compiler.
474 :     See variables `sml-use-command'."
475 : monnier 32 (interactive "r\nP")
476 : monnier 332 (if (= start end)
477 :     (message "The region is zero (ignored)")
478 :     (let* ((buf (sml-proc-buffer))
479 :     (file (buffer-file-name))
480 :     (marker (copy-marker start))
481 :     (tmp (make-temp-file "sml")))
482 :     (write-region start end tmp nil 'silently)
483 :     (with-current-buffer buf
484 :     (when sml-temp-file
485 :     (ignore-errors (delete-file (car sml-temp-file)))
486 :     (set-marker (cdr sml-temp-file) nil))
487 :     (setq sml-temp-file (cons tmp marker))
488 :     (sml-send-string (format sml-use-command tmp) nil and-go)))))
489 : monnier 32
490 :     ;; This is quite bogus, so it isn't bound to a key by default.
491 :     ;; Anyone coming up with an algorithm to recognise fun & local
492 :     ;; declarations surrounding point will do everyone a favour!
493 :    
494 :     (defun sml-send-function (&optional and-go)
495 :     "Send current paragraph to the inferior ML process.
496 :     With a prefix argument switch to the sml buffer as well
497 :     \(cf. `sml-send-region'\)."
498 :     (interactive "P")
499 :     (save-excursion
500 :     (sml-mark-function)
501 :     (sml-send-region (point) (mark)))
502 :     (if and-go (switch-to-sml nil)))
503 :    
504 : monnier 332 (defvar sml-source-modes '(sml-mode)
505 :     "*Used to determine if a buffer contains ML source code.
506 : monnier 319 If it's loaded into a buffer that is in one of these major modes, it's
507 :     considered an ML source file by `sml-load-file'. Used by these commands
508 :     to determine defaults.")
509 :    
510 : monnier 32 ;;;###autoload
511 :     (defun sml-send-buffer (&optional and-go)
512 :     "Send buffer to inferior shell running ML process.
513 :     With a prefix argument switch to the sml buffer as well
514 :     \(cf. `sml-send-region'\)."
515 :     (interactive "P")
516 :     (if (memq major-mode sml-source-modes)
517 :     (sml-send-region (point-min) (point-max) and-go)))
518 :    
519 :     ;; Since sml-send-function/region take an optional prefix arg, these
520 :     ;; commands are redundant. But they are kept around for the user to
521 :     ;; bind if she wishes, since its easier to type C-c r than C-u C-c C-r.
522 :    
523 :     (defun sml-send-region-and-go (start end)
524 :     "Send current region to the inferior ML process, and go there."
525 :     (interactive "r")
526 :     (sml-send-region start end t))
527 :    
528 :     (defun sml-send-function-and-go ()
529 :     "Send current paragraph to the inferior ML process, and go there."
530 :     (interactive)
531 :     (sml-send-function t))
532 :    
533 :    
534 :     ;;; Mouse control and handling dedicated frames for Inferior ML
535 :    
536 :     ;; simplified from frame.el in Emacs: special-display-popup-frame...
537 :    
538 : monnier 332 ;; (defun sml-proc-frame ()
539 :     ;; "Returns the current ML process buffer's frame, or creates one first."
540 :     ;; (let ((buffer (sml-proc-buffer)))
541 :     ;; (window-frame (display-buffer buffer))))
542 : monnier 32
543 :     ;;; 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
544 :    
545 :     ;; Only these two functions have to dance around the inane differences
546 :     ;; between Emacs and XEmacs (fortunately)
547 :    
548 : monnier 332 ;; (defun sml-warp-mouse (frame)
549 :     ;; "Warp the pointer across the screen to upper right corner of FRAME."
550 :     ;; (raise-frame frame)
551 :     ;; (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)
552 :     ;; ;; LUCID (19.10) or later... set-m-pos needs a WINDOW
553 :     ;; (set-mouse-position (frame-root-window frame) (1- (frame-width)) 0))
554 :     ;; (t
555 :     ;; ;; GNU, post circa 19.19... set-m-pos needs a FRAME
556 :     ;; (set-mouse-position frame (1- (frame-width)) 0)
557 :     ;; ;; probably not needed post 19.29
558 :     ;; (if (fboundp 'unfocus-frame) (unfocus-frame)))))
559 : monnier 32
560 :     (defun sml-drag-region (event)
561 :     "Highlight the text the mouse is dragged over, and send it to ML.
562 :     This must be bound to a button-down mouse event, currently \\[sml-drag-region].
563 :    
564 :     If you drag the mouse (ie, keep the mouse button depressed) the
565 :     program text sent to the complier is delimited by where you started
566 :     dragging the mouse, and where you release the mouse button.
567 :    
568 :     If you only click the mouse, the program text sent to the compiler is
569 :     delimited by the current position of point and the place where you
570 :     click the mouse.
571 :    
572 :     In either event, the values of both point and mark are left
573 :     undisturbed once this operation is completed."
574 :     (interactive "e")
575 :     (let ((mark-ring) ;BAD: selection start gets cons'd
576 :     (pmark (point))) ;where point is now
577 :     (if (fboundp 'mouse-track-default)
578 :     ;; Assume this is XEmacs, otherwise assume its Emacs
579 :     (save-excursion
580 :     (let ((zmacs-regions))
581 :     (set-marker (mark-marker) nil)
582 :     (mouse-track-default event)
583 :     (if (not (region-exists-p)) (push-mark pmark nil t))
584 :     (call-interactively 'sml-send-region)))
585 :     ;; Emacs: making this buffer-local ought to happen in sml-mode
586 :     (make-local-variable 'transient-mark-mode)
587 :     (save-excursion
588 :     (let ((transient-mark-mode 1))
589 :     (mouse-drag-region event)
590 :     (if (not mark-active) (push-mark pmark nil t))
591 :     (call-interactively 'sml-send-region))))))
592 :    
593 :    
594 :     ;;; LOADING AND IMPORTING SOURCE FILES:
595 :    
596 : monnier 332 (defvar sml-prev-dir/file nil
597 : monnier 32 "Caches the (directory . file) pair used in the last `sml-load-file'
598 :     or `sml-cd' command. Used for determining the default in the next one.")
599 :    
600 :     ;;;###autoload
601 :     (defun sml-load-file (&optional and-go)
602 :     "Load an ML file into the current inferior ML process.
603 :     With a prefix argument switch to sml buffer as well.
604 :    
605 :     This command uses the ML command template `sml-use-command' to construct
606 :     the command to send to the ML process\; a trailing \"\;\\n\" will be added
607 :     automatically."
608 :     (interactive "P")
609 : monnier 332 (let ((file (car (comint-get-source
610 :     "Load ML file: " sml-prev-dir/file sml-source-modes t))))
611 :     (with-current-buffer (sml-proc-buffer)
612 :     ;; Check if buffer needs saved. Should (save-some-buffers) instead?
613 :     (comint-check-source file)
614 :     (setq sml-prev-dir/file
615 :     (cons (file-name-directory file) (file-name-nondirectory file)))
616 :     (sml-send-string (format sml-use-command file) nil and-go))))
617 : monnier 32
618 :     (defun sml-cd (dir)
619 :     "Change the working directory of the inferior ML process.
620 :     The default directory of the process buffer is changed to DIR. If the
621 :     variable `sml-cd-command' is non-nil it should be an ML command that will
622 :     be executed to change the compiler's working directory\; a trailing
623 :     \"\;\\n\" will be added automatically."
624 :     (interactive "DSML Directory: ")
625 : monnier 332 (let ((dir (expand-file-name dir)))
626 :     (with-current-buffer (sml-proc-buffer)
627 :     (sml-send-string (format sml-cd-command dir) t)
628 :     (setq default-directory dir))
629 :     (setq sml-prev-dir/file (cons dir nil))))
630 : monnier 32
631 : monnier 332 (defun sml-send-string (str &optional print and-go)
632 :     (let ((proc (sml-proc))
633 :     (str (concat str ";\n"))
634 :     (win (get-buffer-window (current-buffer) 'visible)))
635 :     (when win (select-window win))
636 :     (goto-char (point-max))
637 :     (when print (insert str))
638 :     (sml-update-cursor)
639 :     (set-marker (process-mark proc) (point-max))
640 :     (setq compilation-last-buffer (current-buffer))
641 :     (comint-send-string proc str)
642 :     (when and-go (switch-to-sml nil))))
643 : monnier 32
644 : monnier 332 (defun sml-compile (command)
645 : monnier 33 "re-make a system using (by default) CM.
646 :     The exact command used can be specified by providing a prefix argument."
647 :     (interactive
648 :     ;; code taken straight from compile.el
649 : monnier 332 (if (or compilation-read-command current-prefix-arg)
650 : monnier 33 (list (read-from-minibuffer "Compile command: "
651 : monnier 332 sml-compile-command nil nil
652 : monnier 33 '(compile-history . 1)))
653 : monnier 332 (list sml-compile-command)))
654 :     (setq sml-compile-command command)
655 :     (save-some-buffers (not compilation-ask-about-save) nil)
656 :     ;; try to find a makefile up the directory tree
657 :     (let ((dir (when sml-make-file-name default-directory)))
658 : monnier 33 (while (and dir (not (file-exists-p (concat dir sml-make-file-name))))
659 :     (let ((newdir (file-name-directory (directory-file-name dir))))
660 : monnier 332 (setq dir (unless (equal newdir dir) newdir))))
661 :     (unless dir (setq dir default-directory))
662 :     (with-current-buffer (sml-proc-buffer)
663 :     (setq default-directory dir)
664 :     (sml-send-string (concat (format sml-cd-command dir) "; " command) t t))))
665 : monnier 32
666 : monnier 33 ;;; PARSING ERROR MESSAGES
667 : monnier 32
668 :     ;; This should need no modification to support other compilers.
669 :    
670 : monnier 332 ;; Update the buffer-local error-cursor in proc-buffer to be its
671 :     ;; current proc mark.
672 : monnier 32
673 : monnier 332 (defvar sml-endof-error-alist nil)
674 : monnier 32
675 : monnier 332 (defun sml-update-cursor ()
676 :     ;; update buffer local variable
677 :     (set-marker sml-error-cursor (1- (process-mark (sml-proc))))
678 :     (setq sml-endof-error-alist nil)
679 :     (compilation-forget-errors)
680 :     (setq compilation-parsing-end sml-error-cursor))
681 : monnier 32
682 : monnier 332 (defun sml-make-error (f c)
683 :     (let ((err (point-marker))
684 :     (linenum (string-to-number c))
685 :     (filename (list (first f) (second f)))
686 :     (column (string-to-number (compile-buffer-substring (third f)))))
687 :     ;; record the end of error, if any
688 :     (when (fourth f)
689 :     (let* ((endline (string-to-number (compile-buffer-substring (fourth f))))
690 :     (endcol (string-to-number (compile-buffer-substring (fifth f))))
691 :     (linediff (- endline linenum)))
692 :     (push (list err linediff (if (= 0 linediff) (- endcol column) endcol))
693 :     sml-endof-error-alist)))
694 :     ;; build the error descriptor
695 :     (if (string= (car sml-temp-file) (first f))
696 :     ;; special case for code sent via sml-send-region
697 :     (let ((marker (cdr sml-temp-file)))
698 :     (with-current-buffer (marker-buffer marker)
699 :     (goto-char marker)
700 :     (forward-line (1- linenum))
701 :     (forward-char (1- column))
702 :     (cons err (point-marker))))
703 :     ;; taken from compile.el
704 :     (list err filename linenum column))))
705 : monnier 32
706 : monnier 332 (defadvice compilation-goto-locus (after sml-endof-error activate)
707 :     (let* ((next-error (ad-get-arg 0))
708 :     (err (car next-error))
709 :     (pos (cdr next-error))
710 :     (endof (with-current-buffer (marker-buffer err)
711 :     (assq err sml-endof-error-alist))))
712 :     (if (not endof) (sml-error-overlay 'undo)
713 :     (with-current-buffer (marker-buffer pos)
714 :     (goto-char pos)
715 :     (let ((linediff (second endof))
716 :     (coldiff (third endof)))
717 :     (when (> 0 linediff) (forward-line linediff))
718 :     (forward-char coldiff))
719 :     (sml-error-overlay nil pos (point))
720 :     (push-mark nil t (not sml-error-overlay))
721 :     (goto-char pos)))))
722 : monnier 32
723 : monnier 332 (defun sml-error-overlay (undo &optional beg end)
724 :     "Move `sml-error-overlay' so it surrounds the text region in the
725 :     current buffer. If the buffer-local variable `sml-error-overlay' is
726 :     non-nil it should be an overlay \(or extent, in XEmacs speak\)\; this
727 :     function moves the overlay over the current region. If the optional
728 :     BUFFER argument is given, move the overlay in that buffer instead of
729 :     the current buffer.
730 :    
731 :     Called interactively, the optional prefix argument UNDO indicates that
732 :     the overlay should simply be removed: \\[universal-argument] \
733 :     \\[sml-error-overlay]."
734 : monnier 32 (interactive "P")
735 : monnier 332 (when sml-error-overlay
736 :     (unless (overlayp sml-error-overlay)
737 :     (let ((ol sml-error-overlay))
738 :     (setq sml-error-overlay (make-overlay 0 0))
739 :     (overlay-put sml-error-overlay 'face (if (symbolp ol) ol 'region))))
740 :     (if undo
741 :     (move-overlay sml-error-overlay 1 1 (current-buffer))
742 :     ;; if active regions, signals mark not active if no region set
743 :     (let ((beg (or beg (region-beginning)))
744 :     (end (or end (region-end))))
745 :     (move-overlay sml-error-overlay beg end (current-buffer))))))
746 : monnier 32
747 : monnier 332 ;; ;;;###autoload
748 :     ;; (defun sml-next-error (skip)
749 :     ;; "Find the next error by parsing the inferior ML buffer.
750 :     ;; A prefix argument means `sml-skip-errors' (qv) instead.
751 : monnier 32
752 : monnier 332 ;; Move the error message on the top line of the window\; put the cursor
753 :     ;; \(point\) at the beginning of the error source.
754 : monnier 32
755 : monnier 332 ;; If the error message specifies a range, and `sml-error-parser' returns
756 :     ;; the range, the mark is placed at the end of the range. If the variable
757 :     ;; `sml-error-overlay' is non-nil, the region will also be highlighted.
758 : monnier 32
759 : monnier 332 ;; If `sml-error-parser' returns a fifth component this is assumed to be
760 :     ;; a string to indicate the nature of the error: this will be echoed in
761 :     ;; the minibuffer.
762 :    
763 :     ;; Error interaction only works if there is a real file associated with
764 :     ;; the input -- though of course it also depends on the compiler's error
765 :     ;; messages \(also see documantation for `sml-error-parser'\).
766 :    
767 :     ;; However: if the last text sent went via `sml-load-file' (or the temp
768 :     ;; file mechanism), the next error reported will be relative to the start
769 :     ;; of the region sent, any error reports in the previous output being
770 :     ;; forgotten. If the text went directly to the compiler the succeeding
771 :     ;; error reported will be the next error relative to the location \(in
772 :     ;; the output\) of the last error. This odd behaviour may have a use...?"
773 :     ;; (interactive "P")
774 :     ;; (if skip (sml-skip-errors) (sml-do-next-error)))
775 :    
776 :     ;; (defun sml-do-next-error ()
777 :     ;; "The business end of `sml-next-error' (qv)"
778 :     ;; (let ((case-fold-search nil)
779 :     ;; ;; set this variable iff we called sml-next-error in a SML buffer
780 :     ;; (sml-window (if (memq major-mode sml-source-modes) (selected-window)))
781 :     ;; (proc-buffer (sml-proc-buffer)))
782 :     ;; ;; undo (don't destroy) the previous overlay to be tidy
783 :     ;; (sml-error-overlay 'undo 1 1
784 :     ;; (and sml-error-file (get-file-buffer sml-error-file)))
785 :     ;; ;; go to interaction buffer but don't raise it's frame
786 :     ;; (pop-to-buffer (sml-proc-buffer))
787 :     ;; ;; go to the last remembered error, and search for the next one.
788 :     ;; (goto-char sml-error-cursor)
789 :     ;; (if (not (re-search-forward sml-error-regexp (point-max) t))
790 :     ;; ;; no more errors -- move point to the sml prompt at the end
791 :     ;; (progn
792 :     ;; (goto-char (point-max))
793 :     ;; (if sml-window (select-window sml-window)) ;return there, perhaps
794 :     ;; (message "No error message(s) found."))
795 :     ;; ;; error found: point is at end of last match; set the cursor posn.
796 :     ;; (set-marker sml-error-cursor (point))
797 :     ;; ;; move the SML window's text up to this line
798 :     ;; (set-window-start (get-buffer-window proc-buffer) (match-beginning 0))
799 :     ;; (let* ((pos)
800 :     ;; (parse (funcall sml-error-parser (match-beginning 0)))
801 :     ;; (file (nth 0 parse))
802 :     ;; (line0 (nth 1 parse))
803 :     ;; (col0 (nth 2 parse))
804 :     ;; (line/col1 (nth 3 parse))
805 :     ;; (msg (nth 4 parse)))
806 :     ;; ;; Give up immediately if the error report is scribble
807 :     ;; (if (or (null file) (null line0))
808 :     ;; (error "Failed to parse/locate this error properly!"))
809 :     ;; ;; decide what to do depending on the file returned
810 :     ;; (when (string= file "std_in")
811 :     ;; ;; presently a fundamental limitation i'm afraid.
812 :     ;; (error "Sorry, can't locate errors on std_in."))
813 :     ;; ;; jump to the beginning
814 :     ;; (if (string= file (car sml-temp-file))
815 :     ;; (let* ((maker (cdr sml-temp-file))
816 :     ;; (buf (marker-buffer marker)))
817 :     ;; (display-buffer buf)
818 :     ;; (set-buffer buf)
819 :     ;; (goto-char marker))
820 :     ;; (unless (file-readable-p file) (error "Can't read %s" file))
821 :     ;; ;; instead of (find-file-other-window file) to lookup the file
822 :     ;; (find-file-other-window file)
823 :     ;; ;; no good if the buffer's narrowed, still...
824 :     ;; (goto-char (point-min)))
825 :     ;; ;; jump to the error
826 :     ;; (forward-line (1- line0))
827 :     ;; (forward-char (1- col0))
828 :     ;; ;; point is at start of error text; seek the end.
829 :     ;; (let ((start (point))
830 :     ;; (end (and line/col1
831 :     ;; (condition-case nil
832 :     ;; (progn (eval line/col1) (point))
833 :     ;; (error nil)))))
834 :     ;; ;; return to start anyway
835 :     ;; (goto-char start)
836 :     ;; ;; if point went to end, put mark there, and maybe highlight
837 :     ;; (if end (progn (push-mark end t)
838 :     ;; (sml-error-overlay nil start end)))
839 :     ;; (setq sml-error-file file) ; remember this for next time
840 :     ;; (if msg (message msg))))))) ; echo the error/warning message
841 :    
842 :     ;; (defun sml-skip-errors ()
843 :     ;; "Skip past the rest of the errors."
844 :     ;; (interactive)
845 :     ;; (if (memq major-mode sml-source-modes) (sml-error-overlay 'undo))
846 :     ;; (with-current-buffer (sml-proc-buffer) (sml-update-cursor))
847 :     ;; (if (eq major-mode 'sml-inferior-mode) (goto-char (point-max))))
848 :    
849 : 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
850 :    
851 :     (if window-system
852 :     (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)
853 :     ;; LUCID (19.10) or later...
854 :     (define-key sml-mode-map '(meta shift button1) 'sml-drag-region))
855 :     (t
856 :     ;; GNU, post circa 19.19
857 :     (define-key sml-mode-map [M-S-down-mouse-1] 'sml-drag-region))))
858 :    
859 :     ;;; ...and do the user's customisations.
860 :    
861 :     (run-hooks 'inferior-sml-load-hook)
862 :    
863 :     ;;; Here is where sml-proc.el ends
864 : monnier 332 (provide 'sml-proc)

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