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 395 - (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 : monnier 394 ;; achieved by M-x run-sml which starts a sub-process under emacs. You may
42 : monnier 32 ;; need to set this up for autoloading in your .emacs:
43 :    
44 : monnier 394 ;; (autoload 'run-sml "sml-proc" "Run an inferior ML process." t)
45 : monnier 32
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 : monnier 394 ;; run-sml) you will be prompted for a different program to execute from
49 : monnier 32 ;; 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 : monnier 394 ;; reported by the compiler, C-x ` (next-error) will step through
70 : monnier 32 ;; 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 : monnier 394 ;; Moscow ML, and Poly/ML. For other compilers, add the relevant
76 :     ;; regexp to sml-error-regexp-alist and send it to me.
77 : monnier 32
78 : monnier 394 ;; To send pieces of code to the underlying compiler, we never send the text
79 :     ;; directly but use a temporary file instead. This breaks if the compiler
80 :     ;; does not understand `use', but has the benefit of allowing better error
81 :     ;; reporting.
82 : monnier 32
83 :     ;; ===================================================================
84 :    
85 :     ;;; INFERIOR ML MODE VARIABLES
86 :    
87 :     (require 'sml-mode)
88 : monnier 332 (require 'sml-util)
89 : monnier 32 (require 'comint)
90 : monnier 332 (require 'compile)
91 : monnier 32
92 : monnier 394 (defgroup sml-proc ()
93 :     "Interacting with an SML process."
94 :     :group 'sml)
95 : monnier 32
96 : monnier 394 (defcustom sml-program-name "sml"
97 :     "*Program to run as ML."
98 :     :group 'sml-proc
99 :     :type '(string))
100 : monnier 32
101 : monnier 394 (defcustom sml-default-arg ""
102 :     "*Default command line option to pass, if any."
103 :     :group 'sml-proc
104 :     :type '(string))
105 :    
106 : monnier 332 (defvar sml-compile-command "CM.make()"
107 : monnier 33 "The command used by default by `sml-make'.")
108 : monnier 32
109 : monnier 33 (defvar sml-make-file-name "sources.cm"
110 :     "The name of the makefile that `sml-make' will look for (if non-nil).")
111 : monnier 32
112 :     ;;(defvar sml-raise-on-error nil
113 :     ;; "*When non-nil, `sml-next-error' will raise the ML process's frame.")
114 :    
115 :     (defvar inferior-sml-mode-hook nil
116 :     "*This hook is run when the inferior ML process is started.
117 :     All buffer local customisations for the interaction buffers go here.")
118 :    
119 :     (defvar inferior-sml-load-hook nil
120 :     "*Hook run when inferior-sml-mode (sml-proc.el) is loaded into Emacs.
121 :     This is a good place to put your preferred key bindings.")
122 :    
123 : monnier 332 (defvar sml-error-overlay nil
124 :     "*Non-nil means use an overlay to highlight errorful code in the buffer.
125 :     The actual value is the name of a face to use for the overlay.
126 :     Instead of setting this variable to 'region, you can also simply keep
127 :     it NIL and use (transient-mark-mode) which will provide similar
128 :     benefits (but with several side effects).")
129 :    
130 : monnier 32 (defvar sml-buffer nil
131 :     "*The current ML process buffer.
132 :    
133 :     MULTIPLE PROCESS SUPPORT (Whoever wants multi-process support anyway?)
134 :     =====================================================================
135 :     sml-mode supports, in a fairly simple fashion, running multiple ML
136 :     processes. To run multiple ML processes, you start the first up with
137 :     \\[sml]. It will be in a buffer named *sml*. Rename this buffer with
138 :     \\[rename-buffer]. You may now start up a new process with another
139 :     \\[sml]. It will be in a new buffer, named *sml*. You can switch
140 :     between the different process buffers with \\[switch-to-buffer].
141 :    
142 :     NB *sml* is just the default name for the buffer. It actually gets
143 :     it's name from the value of `sml-program-name' -- *poly*, *smld*,...
144 :    
145 :     If you have more than one ML process around, commands that send text
146 :     from source buffers to ML processes -- like `sml-send-function' or
147 :     `sml-send-region' -- have to choose a process to send it to. This is
148 :     determined by the global variable `sml-buffer'. Suppose you have three
149 :     inferior ML's running:
150 :     Buffer Process
151 :     sml #<process sml>
152 :     mosml #<process mosml>
153 :     *sml* #<process sml<2>>
154 :     If you do a \\[sml-send-function] command on some ML source code,
155 :     what process do you send it to?
156 :    
157 :     - If you're in a process buffer (sml, mosml, or *sml*), you send it to
158 :     that process (usually makes sense only to `sml-load-file').
159 :     - If you're in some other buffer (e.g., a source file), you send it to
160 :     the process attached to buffer `sml-buffer'.
161 :    
162 :     This process selection is performed by function `sml-proc' which looks
163 :     at the value of `sml-buffer' -- which must be a lisp buffer object, or
164 :     a string \(or nil\).
165 :    
166 :     Whenever \\[sml] fires up a new process, it resets `sml-buffer' to be
167 :     the new process's buffer. If you only run one process, this will do
168 :     the right thing. If you run multiple processes, you can change
169 :     `sml-buffer' to another process buffer with \\[set-variable], or
170 :     use the command \\[sml-buffer] in the interaction buffer of choice.")
171 :    
172 :    
173 :     ;;; ALL STUFF THAT DEFAULTS TO THE SML/NJ COMPILER (0.93)
174 :    
175 :     (defvar sml-use-command "use \"%s\""
176 :     "*Template for loading a file into the inferior ML process.
177 :     Set to \"use \\\"%s\\\"\" for SML/NJ or Edinburgh ML;
178 :     set to \"PolyML.use \\\"%s\\\"\" for Poly/ML, etc.")
179 :    
180 : monnier 33 (defvar sml-cd-command "OS.FileSys.chDir \"%s\""
181 : monnier 32 "*Command template for changing working directories under ML.
182 :     Set this to nil if your compiler can't change directories.
183 :    
184 :     The format specifier \"%s\" will be converted into the directory name
185 :     specified when running the command \\[sml-cd].")
186 :    
187 : monnier 394 (defcustom sml-prompt-regexp "^[-=>#] *"
188 :     "*Regexp used to recognise prompts in the inferior ML process."
189 :     :group 'sml-proc
190 :     :type '(regexp))
191 : monnier 32
192 : monnier 395 (defvar sml-error-regexp-alist
193 : monnier 332 '(;; Poly/ML messages
194 :     ("\\(Error\\|Warning:\\) in '\\(.+\\)', line \\([0-9]+\\)" 2 3)
195 :     ;; Moscow ML
196 :     ("File \"\\([^\"]+\\)\", line \\([0-9]+\\)\\(-\\([0-9]+\\)\\)?, characters \\([0-9]+\\)-\\([0-9]+\\):" 1 2 5)
197 : monnier 378 ;; SML/NJ: the file-pattern is anchored to avoid
198 : monnier 342 ;; pathological behavior with very long lines.
199 : monnier 378 ("^[-= ]*\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warning\\): .*" 1 sml-make-error 2 3 5 6)
200 : monnier 342 ;; SML/NJ's exceptions: see above.
201 : monnier 395 ("^ +\\(raised at: \\)?\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2 sml-make-error 3 4 6 7))
202 :     "Alist that specifies how to match errors in compiler output.
203 :     See `compilation-error-regexp-alist' for a description of the format.")
204 : monnier 32
205 : monnier 33 ;; font-lock support
206 : monnier 332 (defconst inferior-sml-font-lock-keywords
207 :     `(;; prompt and following interactive command
208 :     (,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
209 : monnier 33 (1 font-lock-prompt-face)
210 :     (2 font-lock-command-face keep))
211 : monnier 332 ;; CM's messages
212 : monnier 39 ("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face)
213 : monnier 332 ;; SML/NJ's irritating GC messages
214 :     ("^GC #.*" . font-lock-comment-face)
215 :     ;; error messages
216 :     ,@(mapcar (lambda (ra) (cons (car ra) 'font-lock-warning-face))
217 :     sml-error-regexp-alist))
218 :     "Font-locking specification for inferior SML mode.")
219 : monnier 33
220 : monnier 394 (defface font-lock-prompt-face
221 :     '((t (:bold t)))
222 :     "Font Lock mode face used to highlight prompts."
223 :     :group 'font-lock-highlighting-faces)
224 :     (defvar font-lock-prompt-face 'font-lock-prompt-face
225 :     "Face name to use for prompts.")
226 : monnier 33
227 : monnier 394 (defface font-lock-command-face
228 :     '((t (:bold t)))
229 :     "Font Lock mode face used to highlight interactive commands."
230 :     :group 'font-lock-highlighting-faces)
231 :     (defvar font-lock-command-face 'font-lock-command-face
232 :     "Face name to use for interactive commands.")
233 :    
234 :     (defconst inferior-sml-font-lock-defaults
235 : monnier 33 '(inferior-sml-font-lock-keywords nil nil nil nil))
236 :    
237 : monnier 32 ;;; CODE
238 :    
239 : monnier 319 (defmap inferior-sml-mode-map
240 :     '(("\C-c\C-s" . run-sml)
241 :     ("\t" . comint-dynamic-complete))
242 :     "Keymap for inferior-sml mode"
243 : monnier 394 :inherit (list sml-bindings comint-mode-map)
244 :     :group 'sml-proc)
245 : monnier 32
246 : monnier 319
247 : monnier 32 ;; buffer-local
248 :    
249 : monnier 332 (defvar sml-temp-file nil)
250 : monnier 378 ;;(defvar sml-error-file nil) ; file from which the last error came
251 : monnier 32 (defvar sml-error-cursor nil) ; ditto
252 :    
253 :     (defun sml-proc-buffer ()
254 :     "Returns the current ML process buffer,
255 :     or the current buffer if it is in `inferior-sml-mode'. Raises an error
256 :     if the variable `sml-buffer' does not appear to point to an existing
257 :     buffer."
258 : monnier 332 (or (and (eq major-mode 'inferior-sml-mode) (current-buffer))
259 :     (and sml-buffer
260 :     (let ((buf (get-buffer sml-buffer)))
261 :     ;; buffer-name returns nil if the buffer has been killed
262 :     (and buf (buffer-name buf) buf)))
263 :     ;; no buffer found, make a new one
264 :     (run-sml t)))
265 : monnier 32
266 :     (defun sml-proc ()
267 :     "Returns the current ML process. See variable `sml-buffer'."
268 : monnier 332 (assert (eq major-mode 'inferior-sml-mode))
269 :     (or (get-buffer-process (current-buffer))
270 :     (progn (run-sml t) (get-buffer-process (current-buffer)))))
271 : monnier 32
272 :     (defun sml-buffer (echo)
273 :     "Make the current buffer the current `sml-buffer' if that is sensible.
274 :     Lookup variable `sml-buffer' to see why this might be useful."
275 :     (interactive "P")
276 : monnier 332 (when (and (not echo) (eq major-mode 'inferior-sml-mode))
277 :     (setq sml-buffer (current-buffer)))
278 :     (message "ML process buffer is %s."
279 :     (or (ignore-errors (buffer-name (get-buffer sml-buffer)))
280 :     "undefined")))
281 : monnier 32
282 :     (defun inferior-sml-mode ()
283 :     "Major mode for interacting with an inferior ML process.
284 :    
285 :     The following commands are available:
286 :     \\{inferior-sml-mode-map}
287 :    
288 :     An ML process can be fired up (again) with \\[sml].
289 :    
290 :     Customisation: Entry to this mode runs the hooks on `comint-mode-hook'
291 :     and `inferior-sml-mode-hook' (in that order).
292 :    
293 :     Variables controlling behaviour of this mode are
294 :    
295 :     `sml-program-name' (default \"sml\")
296 :     Program to run as ML.
297 :    
298 :     `sml-use-command' (default \"use \\\"%s\\\"\")
299 :     Template for loading a file into the inferior ML process.
300 :    
301 :     `sml-cd-command' (default \"System.Directory.cd \\\"%s\\\"\")
302 :     ML command for changing directories in ML process (if possible).
303 :    
304 :     `sml-prompt-regexp' (default \"^[\\-=] *\")
305 :     Regexp used to recognise prompts in the inferior ML process.
306 :    
307 :     You can send text to the inferior ML process from other buffers containing
308 :     ML source.
309 :     `switch-to-sml' switches the current buffer to the ML process buffer.
310 :     `sml-send-function' sends the current *paragraph* to the ML process.
311 :     `sml-send-region' sends the current region to the ML process.
312 :    
313 :     Prefixing the sml-send-<whatever> commands with \\[universal-argument]
314 :     causes a switch to the ML process buffer after sending the text.
315 :    
316 :     For information on running multiple processes in multiple buffers, see
317 :     documentation for variable `sml-buffer'.
318 :    
319 :     Commands:
320 :     RET after the end of the process' output sends the text from the
321 :     end of process to point.
322 :     RET before the end of the process' output copies the current line
323 :     to the end of the process' output, and sends it.
324 :     DEL converts tabs to spaces as it moves back.
325 :     TAB file name completion, as in shell-mode, etc.."
326 :     (interactive)
327 :     (kill-all-local-variables)
328 :     (comint-mode)
329 :     (setq comint-prompt-regexp sml-prompt-regexp)
330 :     (sml-mode-variables)
331 :    
332 :     ;; For sequencing through error messages:
333 : monnier 300 (set (make-local-variable 'sml-error-cursor) (point-max-marker))
334 : monnier 332 (set-marker-insertion-type sml-error-cursor nil)
335 : monnier 33 (set (make-local-variable 'font-lock-defaults)
336 :     inferior-sml-font-lock-defaults)
337 : monnier 32
338 : monnier 332 ;; compilation support (used for next-error)
339 :     (set (make-local-variable 'compilation-error-regexp-alist)
340 :     sml-error-regexp-alist)
341 :     (compilation-shell-minor-mode 1)
342 :     ;; I'm sure people might kill me for that
343 :     (setq compilation-error-screen-columns nil)
344 :     (make-local-variable 'sml-endof-error-alist)
345 :     ;;(make-local-variable 'sml-error-overlay)
346 : monnier 32
347 :     (setq major-mode 'inferior-sml-mode)
348 :     (setq mode-name "Inferior ML")
349 :     (setq mode-line-process '(": %s"))
350 :     (use-local-map inferior-sml-mode-map)
351 : monnier 332 ;;(add-hook 'kill-emacs-hook 'sml-temp-tidy)
352 : monnier 32
353 :     (run-hooks 'inferior-sml-mode-hook))
354 :    
355 :     ;;; FOR RUNNING ML FROM EMACS
356 :    
357 : monnier 33 ;;;###autoload
358 :     (defun run-sml (&optional pfx)
359 : monnier 32 "Run an inferior ML process, input and output via buffer *sml*.
360 :     With a prefix argument, this command allows you to specify any command
361 :     line options to pass to the complier. The command runs hook functions
362 :     on `comint-mode-hook' and `inferior-sml-mode-hook' in that order.
363 :    
364 :     If there is a process already running in *sml*, just switch to that
365 :     buffer instead.
366 :    
367 :     In fact the name of the buffer created is chosen to reflect the name
368 :     of the program name specified by `sml-program-name', or entered at the
369 :     prompt. You can have several inferior ML process running, but only one
370 :     current one -- given by `sml-buffer' (qv).
371 :    
372 :     \(Type \\[describe-mode] in the process buffer for a list of commands.)"
373 :     (interactive "P")
374 :     (let ((cmd (if pfx
375 :     (read-string "ML command: " sml-program-name)
376 :     sml-program-name))
377 :     (args (if pfx
378 :     (read-string "Any args: " sml-default-arg)
379 :     sml-default-arg)))
380 :     (sml-run cmd args)))
381 :    
382 :     (defun sml-run (cmd arg)
383 :     "Run the ML program CMD with given arguments ARGS.
384 :     This usually updates `sml-buffer' to a buffer named *CMD*."
385 :     (let* ((pname (file-name-nondirectory cmd))
386 :     (args (if (equal arg "") () (sml-args-to-list arg))))
387 : monnier 332 ;; and this -- to keep these as defaults even if
388 :     ;; they're set in the mode hooks.
389 :     (setq sml-program-name cmd)
390 :     (setq sml-default-arg arg)
391 :     (setq sml-buffer (apply 'make-comint pname cmd nil args))
392 : monnier 32
393 : monnier 332 (set-buffer sml-buffer)
394 :     (message (format "Starting \"%s\" in background." pname))
395 :     (inferior-sml-mode)
396 :     (goto-char (point-max))
397 :     sml-buffer))
398 :    
399 : monnier 32 (defun sml-args-to-list (string)
400 :     (let ((where (string-match "[ \t]" string)))
401 :     (cond ((null where) (list string))
402 :     ((not (= where 0))
403 :     (cons (substring string 0 where)
404 :     (sml-args-to-list (substring string (+ 1 where)
405 :     (length string)))))
406 :     (t (let ((pos (string-match "[^ \t]" string)))
407 :     (if (null pos)
408 :     nil
409 :     (sml-args-to-list (substring string pos
410 :     (length string)))))))))
411 :    
412 :     (defun switch-to-sml (eob-p)
413 :     "Switch to the ML process buffer.
414 :     With prefix argument, positions cursor at point, otherwise at end of buffer."
415 :     (interactive "P")
416 : monnier 33 (pop-to-buffer (sml-proc-buffer))
417 : monnier 32 (cond ((not eob-p)
418 :     (push-mark (point) t)
419 :     (goto-char (point-max)))))
420 :    
421 :     ;; Fakes it with a "use <temp-file>;" if necessary.
422 :    
423 :     (defun sml-send-region (start end &optional and-go)
424 :     "Send current region to the inferior ML process.
425 :     Prefix argument means switch-to-sml afterwards.
426 :    
427 : monnier 332 The region is written out to a temporary file and a \"use <temp-file>\" command
428 :     is sent to the compiler.
429 :     See variables `sml-use-command'."
430 : monnier 32 (interactive "r\nP")
431 : monnier 332 (if (= start end)
432 :     (message "The region is zero (ignored)")
433 :     (let* ((buf (sml-proc-buffer))
434 :     (file (buffer-file-name))
435 :     (marker (copy-marker start))
436 :     (tmp (make-temp-file "sml")))
437 :     (write-region start end tmp nil 'silently)
438 :     (with-current-buffer buf
439 :     (when sml-temp-file
440 :     (ignore-errors (delete-file (car sml-temp-file)))
441 :     (set-marker (cdr sml-temp-file) nil))
442 :     (setq sml-temp-file (cons tmp marker))
443 :     (sml-send-string (format sml-use-command tmp) nil and-go)))))
444 : monnier 32
445 :     ;; This is quite bogus, so it isn't bound to a key by default.
446 :     ;; Anyone coming up with an algorithm to recognise fun & local
447 :     ;; declarations surrounding point will do everyone a favour!
448 :    
449 :     (defun sml-send-function (&optional and-go)
450 :     "Send current paragraph to the inferior ML process.
451 :     With a prefix argument switch to the sml buffer as well
452 :     \(cf. `sml-send-region'\)."
453 :     (interactive "P")
454 :     (save-excursion
455 :     (sml-mark-function)
456 :     (sml-send-region (point) (mark)))
457 :     (if and-go (switch-to-sml nil)))
458 :    
459 : monnier 332 (defvar sml-source-modes '(sml-mode)
460 :     "*Used to determine if a buffer contains ML source code.
461 : monnier 319 If it's loaded into a buffer that is in one of these major modes, it's
462 :     considered an ML source file by `sml-load-file'. Used by these commands
463 :     to determine defaults.")
464 :    
465 : monnier 32 (defun sml-send-buffer (&optional and-go)
466 :     "Send buffer to inferior shell running ML process.
467 :     With a prefix argument switch to the sml buffer as well
468 :     \(cf. `sml-send-region'\)."
469 :     (interactive "P")
470 :     (if (memq major-mode sml-source-modes)
471 :     (sml-send-region (point-min) (point-max) and-go)))
472 :    
473 :     ;; Since sml-send-function/region take an optional prefix arg, these
474 :     ;; commands are redundant. But they are kept around for the user to
475 :     ;; bind if she wishes, since its easier to type C-c r than C-u C-c C-r.
476 :    
477 :     (defun sml-send-region-and-go (start end)
478 :     "Send current region to the inferior ML process, and go there."
479 :     (interactive "r")
480 :     (sml-send-region start end t))
481 :    
482 :     (defun sml-send-function-and-go ()
483 :     "Send current paragraph to the inferior ML process, and go there."
484 :     (interactive)
485 :     (sml-send-function t))
486 :    
487 :     ;;; 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
488 :    
489 :     (defun sml-drag-region (event)
490 :     "Highlight the text the mouse is dragged over, and send it to ML.
491 :     This must be bound to a button-down mouse event, currently \\[sml-drag-region].
492 :    
493 :     If you drag the mouse (ie, keep the mouse button depressed) the
494 :     program text sent to the complier is delimited by where you started
495 :     dragging the mouse, and where you release the mouse button.
496 :    
497 :     If you only click the mouse, the program text sent to the compiler is
498 :     delimited by the current position of point and the place where you
499 :     click the mouse.
500 :    
501 :     In either event, the values of both point and mark are left
502 :     undisturbed once this operation is completed."
503 :     (interactive "e")
504 :     (let ((mark-ring) ;BAD: selection start gets cons'd
505 :     (pmark (point))) ;where point is now
506 :     (if (fboundp 'mouse-track-default)
507 :     ;; Assume this is XEmacs, otherwise assume its Emacs
508 :     (save-excursion
509 :     (let ((zmacs-regions))
510 :     (set-marker (mark-marker) nil)
511 :     (mouse-track-default event)
512 :     (if (not (region-exists-p)) (push-mark pmark nil t))
513 :     (call-interactively 'sml-send-region)))
514 :     ;; Emacs: making this buffer-local ought to happen in sml-mode
515 :     (make-local-variable 'transient-mark-mode)
516 :     (save-excursion
517 :     (let ((transient-mark-mode 1))
518 :     (mouse-drag-region event)
519 :     (if (not mark-active) (push-mark pmark nil t))
520 :     (call-interactively 'sml-send-region))))))
521 :    
522 :    
523 :     ;;; LOADING AND IMPORTING SOURCE FILES:
524 :    
525 : monnier 332 (defvar sml-prev-dir/file nil
526 : monnier 32 "Caches the (directory . file) pair used in the last `sml-load-file'
527 :     or `sml-cd' command. Used for determining the default in the next one.")
528 :    
529 :     (defun sml-load-file (&optional and-go)
530 :     "Load an ML file into the current inferior ML process.
531 :     With a prefix argument switch to sml buffer as well.
532 :    
533 :     This command uses the ML command template `sml-use-command' to construct
534 :     the command to send to the ML process\; a trailing \"\;\\n\" will be added
535 :     automatically."
536 :     (interactive "P")
537 : monnier 332 (let ((file (car (comint-get-source
538 :     "Load ML file: " sml-prev-dir/file sml-source-modes t))))
539 :     (with-current-buffer (sml-proc-buffer)
540 :     ;; Check if buffer needs saved. Should (save-some-buffers) instead?
541 :     (comint-check-source file)
542 :     (setq sml-prev-dir/file
543 :     (cons (file-name-directory file) (file-name-nondirectory file)))
544 :     (sml-send-string (format sml-use-command file) nil and-go))))
545 : monnier 32
546 :     (defun sml-cd (dir)
547 :     "Change the working directory of the inferior ML process.
548 :     The default directory of the process buffer is changed to DIR. If the
549 :     variable `sml-cd-command' is non-nil it should be an ML command that will
550 :     be executed to change the compiler's working directory\; a trailing
551 :     \"\;\\n\" will be added automatically."
552 :     (interactive "DSML Directory: ")
553 : monnier 332 (let ((dir (expand-file-name dir)))
554 :     (with-current-buffer (sml-proc-buffer)
555 :     (sml-send-string (format sml-cd-command dir) t)
556 :     (setq default-directory dir))
557 :     (setq sml-prev-dir/file (cons dir nil))))
558 : monnier 32
559 : monnier 332 (defun sml-send-string (str &optional print and-go)
560 :     (let ((proc (sml-proc))
561 :     (str (concat str ";\n"))
562 :     (win (get-buffer-window (current-buffer) 'visible)))
563 :     (when win (select-window win))
564 :     (goto-char (point-max))
565 :     (when print (insert str))
566 :     (sml-update-cursor)
567 :     (set-marker (process-mark proc) (point-max))
568 :     (setq compilation-last-buffer (current-buffer))
569 :     (comint-send-string proc str)
570 :     (when and-go (switch-to-sml nil))))
571 : monnier 32
572 : monnier 332 (defun sml-compile (command)
573 : monnier 33 "re-make a system using (by default) CM.
574 :     The exact command used can be specified by providing a prefix argument."
575 :     (interactive
576 :     ;; code taken straight from compile.el
577 : monnier 332 (if (or compilation-read-command current-prefix-arg)
578 : monnier 33 (list (read-from-minibuffer "Compile command: "
579 : monnier 332 sml-compile-command nil nil
580 : monnier 33 '(compile-history . 1)))
581 : monnier 332 (list sml-compile-command)))
582 :     (setq sml-compile-command command)
583 :     (save-some-buffers (not compilation-ask-about-save) nil)
584 :     ;; try to find a makefile up the directory tree
585 :     (let ((dir (when sml-make-file-name default-directory)))
586 : monnier 33 (while (and dir (not (file-exists-p (concat dir sml-make-file-name))))
587 :     (let ((newdir (file-name-directory (directory-file-name dir))))
588 : monnier 332 (setq dir (unless (equal newdir dir) newdir))))
589 :     (unless dir (setq dir default-directory))
590 :     (with-current-buffer (sml-proc-buffer)
591 :     (setq default-directory dir)
592 :     (sml-send-string (concat (format sml-cd-command dir) "; " command) t t))))
593 : monnier 32
594 : monnier 33 ;;; PARSING ERROR MESSAGES
595 : monnier 32
596 :     ;; This should need no modification to support other compilers.
597 :    
598 : monnier 332 ;; Update the buffer-local error-cursor in proc-buffer to be its
599 :     ;; current proc mark.
600 : monnier 32
601 : monnier 332 (defvar sml-endof-error-alist nil)
602 : monnier 32
603 : monnier 332 (defun sml-update-cursor ()
604 :     ;; update buffer local variable
605 :     (set-marker sml-error-cursor (1- (process-mark (sml-proc))))
606 :     (setq sml-endof-error-alist nil)
607 :     (compilation-forget-errors)
608 : monnier 378 (if (markerp compilation-parsing-end)
609 :     (set-marker compilation-parsing-end sml-error-cursor)
610 :     (setq compilation-parsing-end sml-error-cursor)))
611 : monnier 32
612 : monnier 332 (defun sml-make-error (f c)
613 :     (let ((err (point-marker))
614 :     (linenum (string-to-number c))
615 :     (filename (list (first f) (second f)))
616 :     (column (string-to-number (compile-buffer-substring (third f)))))
617 :     ;; record the end of error, if any
618 :     (when (fourth f)
619 :     (let* ((endline (string-to-number (compile-buffer-substring (fourth f))))
620 :     (endcol (string-to-number (compile-buffer-substring (fifth f))))
621 :     (linediff (- endline linenum)))
622 :     (push (list err linediff (if (= 0 linediff) (- endcol column) endcol))
623 :     sml-endof-error-alist)))
624 :     ;; build the error descriptor
625 :     (if (string= (car sml-temp-file) (first f))
626 :     ;; special case for code sent via sml-send-region
627 :     (let ((marker (cdr sml-temp-file)))
628 :     (with-current-buffer (marker-buffer marker)
629 :     (goto-char marker)
630 :     (forward-line (1- linenum))
631 :     (forward-char (1- column))
632 :     (cons err (point-marker))))
633 :     ;; taken from compile.el
634 :     (list err filename linenum column))))
635 : monnier 32
636 : monnier 332 (defadvice compilation-goto-locus (after sml-endof-error activate)
637 :     (let* ((next-error (ad-get-arg 0))
638 :     (err (car next-error))
639 :     (pos (cdr next-error))
640 :     (endof (with-current-buffer (marker-buffer err)
641 :     (assq err sml-endof-error-alist))))
642 :     (if (not endof) (sml-error-overlay 'undo)
643 :     (with-current-buffer (marker-buffer pos)
644 :     (goto-char pos)
645 :     (let ((linediff (second endof))
646 :     (coldiff (third endof)))
647 :     (when (> 0 linediff) (forward-line linediff))
648 :     (forward-char coldiff))
649 :     (sml-error-overlay nil pos (point))
650 :     (push-mark nil t (not sml-error-overlay))
651 :     (goto-char pos)))))
652 : monnier 32
653 : monnier 332 (defun sml-error-overlay (undo &optional beg end)
654 :     "Move `sml-error-overlay' so it surrounds the text region in the
655 :     current buffer. If the buffer-local variable `sml-error-overlay' is
656 :     non-nil it should be an overlay \(or extent, in XEmacs speak\)\; this
657 :     function moves the overlay over the current region. If the optional
658 :     BUFFER argument is given, move the overlay in that buffer instead of
659 :     the current buffer.
660 :    
661 :     Called interactively, the optional prefix argument UNDO indicates that
662 :     the overlay should simply be removed: \\[universal-argument] \
663 :     \\[sml-error-overlay]."
664 : monnier 32 (interactive "P")
665 : monnier 332 (when sml-error-overlay
666 :     (unless (overlayp sml-error-overlay)
667 :     (let ((ol sml-error-overlay))
668 :     (setq sml-error-overlay (make-overlay 0 0))
669 :     (overlay-put sml-error-overlay 'face (if (symbolp ol) ol 'region))))
670 : monnier 394 (if undo (move-overlay sml-error-overlay 1 1 (current-buffer))
671 : monnier 332 ;; if active regions, signals mark not active if no region set
672 :     (let ((beg (or beg (region-beginning)))
673 :     (end (or end (region-end))))
674 :     (move-overlay sml-error-overlay beg end (current-buffer))))))
675 : monnier 32
676 :     ;;; 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
677 :    
678 :     (if window-system
679 :     (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)
680 :     ;; LUCID (19.10) or later...
681 :     (define-key sml-mode-map '(meta shift button1) 'sml-drag-region))
682 :     (t
683 :     ;; GNU, post circa 19.19
684 :     (define-key sml-mode-map [M-S-down-mouse-1] 'sml-drag-region))))
685 :    
686 :     ;;; ...and do the user's customisations.
687 :    
688 :     (run-hooks 'inferior-sml-load-hook)
689 :    
690 :     ;;; Here is where sml-proc.el ends
691 : monnier 332 (provide 'sml-proc)

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