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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

sml/trunk/sml-mode/sml-proc.el revision 394, Mon Aug 9 21:45:51 1999 UTC sml-mode/trunk/sml-proc.el revision 2824, Wed Oct 31 17:51:51 2007 UTC
# Line 1  Line 1 
1  ;;; sml-proc.el. Comint based interaction mode for Standard ML.  ;;; sml-proc.el --- Comint based interaction mode for Standard ML.
2    
3  (defconst rcsid-sml-proc "@(#)$Name$:$Id$")  ;; Copyright (C) 1999, 2000, 2003, 2004, 2005, 2007  Stefan Monnier
4    ;; Copyright (C) 1994-1997  Matthew J. Morley
5  ;; Copyright (C) 1989, Lars Bo Nielsen, 1994,1997 Matthew J. Morley  ;; Copyright (C) 1989       Lars Bo Nielsen
6    
7  ;; $Revision$  ;; $Revision$
8  ;; $Date$  ;; $Date$
# Line 14  Line 14 
14    
15  ;; This program is free software; you can redistribute it and/or  ;; This program is free software; you can redistribute it and/or
16  ;; modify it under the terms of the GNU General Public License as  ;; modify it under the terms of the GNU General Public License as
17  ;; published by the Free Software Foundation; either version 2, or (at  ;; published by the Free Software Foundation; either version 3, or (at
18  ;; your option) any later version.  ;; your option) any later version.
19    
20  ;; This program is distributed in the hope that it will be useful, but  ;; This program is distributed in the hope that it will be useful, but
# Line 33  Line 33 
33  ;; under 18.59 (or anywhere without comint, if there are such places).  ;; under 18.59 (or anywhere without comint, if there are such places).
34  ;; See sml-mode.el for further information.  ;; See sml-mode.el for further information.
35    
36  ;;; DESCRIPTION  ;;; Commentary:
37    
38  ;; Inferior-sml-mode is for interacting with an ML process run under  ;; Inferior-sml-mode is for interacting with an ML process run under
39  ;; emacs. This uses the comint package so you get history, expansion,  ;; emacs. This uses the comint package so you get history, expansion,
# Line 80  Line 80 
80  ;; does not understand `use', but has the benefit of allowing better error  ;; does not understand `use', but has the benefit of allowing better error
81  ;; reporting.  ;; reporting.
82    
83  ;; ===================================================================  ;; Bugs:
84    
85    ;; Todo:
86    
87  ;;; INFERIOR ML MODE VARIABLES  ;; - Keep improving `sml-compile'.
88    ;; - ignore warnings (if requested) for next-error
89    
90    ;;; Code:
91    
92    (eval-when-compile (require 'cl))
93  (require 'sml-mode)  (require 'sml-mode)
94  (require 'sml-util)  (require 'sml-util)
95  (require 'comint)  (require 'comint)
# Line 103  Line 109 
109    :group 'sml-proc    :group 'sml-proc
110    :type '(string))    :type '(string))
111    
112  (defvar sml-compile-command "CM.make()"  (defcustom sml-host-name ""
113    "The command used by default by `sml-make'.")    "*Host on which to run ML."
114      :group 'sml-proc
115      :type '(string))
116    
117  (defvar sml-make-file-name "sources.cm"  (defcustom sml-config-file "~/.smlproc.sml"
118    "The name of the makefile that `sml-make' will look for (if non-nil).")    "*File that should be fed to the ML process when started."
119      :group 'sml-proc
120      :type '(string))
121    
122  ;;(defvar sml-raise-on-error nil  (defcustom sml-compile-command "CM.make()"
123  ;;  "*When non-nil, `sml-next-error' will raise the ML process's frame.")    "The command used by default by `sml-compile'.
124    See also `sml-compile-commands-alist'.")
125    
126    (defcustom sml-compile-commands-alist
127      '(("CMB.make()" . "all-files.cm")
128        ("CMB.make()" . "pathconfig")
129        ("CM.make()" . "sources.cm")
130        ("use \"load-all\"" . "load-all"))
131      "*Commands used by default by `sml-compile'.
132    Each command is associated with its \"main\" file.
133    It is perfectly OK to associate several files with a command or several
134    commands with the same file.")
135    
136  (defvar inferior-sml-mode-hook nil  (defvar inferior-sml-mode-hook nil
137    "*This hook is run when the inferior ML process is started.    "*This hook is run when the inferior ML process is started.
138  All buffer local customisations for the interaction buffers go here.")  All buffer local customisations for the interaction buffers go here.")
139    
 (defvar inferior-sml-load-hook nil  
   "*Hook run when inferior-sml-mode (sml-proc.el) is loaded into Emacs.  
 This is a good place to put your preferred key bindings.")  
   
140  (defvar sml-error-overlay nil  (defvar sml-error-overlay nil
141    "*Non-nil means use an overlay to highlight errorful code in the buffer.    "*Non-nil means use an overlay to highlight errorful code in the buffer.
142  The actual value is the name of a face to use for the overlay.  The actual value is the name of a face to use for the overlay.
# Line 132  Line 149 
149    
150  MULTIPLE PROCESS SUPPORT (Whoever wants multi-process support anyway?)  MULTIPLE PROCESS SUPPORT (Whoever wants multi-process support anyway?)
151  =====================================================================  =====================================================================
152  sml-mode supports, in a fairly simple fashion, running multiple ML  `sml-mode' supports, in a fairly simple fashion, running multiple ML
153  processes. To run multiple ML processes, you start the first up with  processes. To run multiple ML processes, you start the first up with
154  \\[sml]. It will be in a buffer named *sml*. Rename this buffer with  \\[sml]. It will be in a buffer named *sml*. Rename this buffer with
155  \\[rename-buffer]. You may now start up a new process with another  \\[rename-buffer]. You may now start up a new process with another
# Line 160  Line 177 
177    the process attached to buffer `sml-buffer'.    the process attached to buffer `sml-buffer'.
178    
179  This process selection is performed by function `sml-proc' which looks  This process selection is performed by function `sml-proc' which looks
180  at the value of `sml-buffer' -- which must be a lisp buffer object, or  at the value of `sml-buffer' -- which must be a Lisp buffer object, or
181  a string \(or nil\).  a string \(or nil\).
182    
183  Whenever \\[sml] fires up a new process, it resets `sml-buffer' to be  Whenever \\[sml] fires up a new process, it resets `sml-buffer' to be
# Line 189  Line 206 
206    :group 'sml-proc    :group 'sml-proc
207    :type '(regexp))    :type '(regexp))
208    
209  (defconst sml-error-regexp-alist  (defvar sml-error-regexp-alist
210    '(;; Poly/ML messages    `( ;; Poly/ML messages
211      ("\\(Error\\|Warning:\\) in '\\(.+\\)', line \\([0-9]+\\)" 2 3)      ("^\\(Error\\|Warning:\\) in '\\(.+\\)', line \\([0-9]+\\)" 2 3)
212      ;; Moscow ML      ;; Moscow ML
213      ("File \"\\([^\"]+\\)\", line \\([0-9]+\\)\\(-\\([0-9]+\\)\\)?, characters \\([0-9]+\\)-\\([0-9]+\\):" 1 2 5)      ("^File \"\\([^\"]+\\)\", line \\([0-9]+\\)\\(-\\([0-9]+\\)\\)?, characters \\([0-9]+\\)-\\([0-9]+\\):" 1 2 5)
214      ;; SML/NJ:  the file-pattern is anchored to avoid      ;; SML/NJ:  the file-pattern is anchored to avoid
215      ;; pathological behavior with very long lines.      ;; pathological behavior with very long lines.
216      ("^[-= ]*\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warning\\): .*" 1 sml-make-error 2 3 5 6)      ("^[-= ]*\\(.*[^\n)]\\)\\( (.*)\\)?:\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warnin\\(g\\)\\): .*" 1
217         ,@(if (fboundp 'compilation-fake-loc) ;New compile.el.
218               '((3 . 6) (4 . 7) (9))
219             '(sml-make-error 3 4 6 7)))
220      ;; SML/NJ's exceptions:  see above.      ;; SML/NJ's exceptions:  see above.
221      ("^ +\\(raised at: \\)?\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2 sml-make-error 3 4 6 7)))      ("^ +\\(raised at: \\)?\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2
222         ,@(if (fboundp 'compilation-fake-loc) ;New compile.el.
223               '((3 . 6) (4 . 7))
224             '(sml-make-error 3 4 6 7))))
225      "Alist that specifies how to match errors in compiler output.
226    See `compilation-error-regexp-alist' for a description of the format.")
227    
228  ;; font-lock support  ;; font-lock support
229  (defconst inferior-sml-font-lock-keywords  (defconst inferior-sml-font-lock-keywords
230    `(;; prompt and following interactive command    `(;; prompt and following interactive command
231        ;; FIXME: Actually, this should already be taken care of by comint.
232      (,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")      (,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
233       (1 font-lock-prompt-face)       (1 font-lock-prompt-face)
234       (2 font-lock-command-face keep))       (2 font-lock-command-face keep))
# Line 211  Line 237 
237      ;; SML/NJ's irritating GC messages      ;; SML/NJ's irritating GC messages
238      ("^GC #.*" . font-lock-comment-face)      ("^GC #.*" . font-lock-comment-face)
239      ;; error messages      ;; error messages
240      ,@(mapcar (lambda (ra) (cons (car ra) 'font-lock-warning-face))      ,@(unless (fboundp 'compilation-fake-loc)
241                sml-error-regexp-alist))          (mapcar (lambda (ra) (cons (car ra) 'font-lock-warning-face))
242                    sml-error-regexp-alist)))
243    "Font-locking specification for inferior SML mode.")    "Font-locking specification for inferior SML mode.")
244    
245  (defface font-lock-prompt-face  (defface font-lock-prompt-face
# Line 232  Line 259 
259  (defconst inferior-sml-font-lock-defaults  (defconst inferior-sml-font-lock-defaults
260    '(inferior-sml-font-lock-keywords nil nil nil nil))    '(inferior-sml-font-lock-keywords nil nil nil nil))
261    
262    
263  ;;; CODE  ;;; CODE
264    
265  (defmap inferior-sml-mode-map  (defmap inferior-sml-mode-map
266    '(("\C-c\C-s" . run-sml)    '(("\C-c\C-s" . run-sml)
267        ("\C-c\C-l" . sml-load-file)
268      ("\t"       . comint-dynamic-complete))      ("\t"       . comint-dynamic-complete))
269    "Keymap for inferior-sml mode"    "Keymap for inferior-sml mode"
270    :inherit (list sml-bindings comint-mode-map)    :inherit comint-mode-map
271    :group 'sml-proc)    :group 'sml-proc)
272    
273    
# Line 249  Line 278 
278  (defvar sml-error-cursor nil)           ;   ditto  (defvar sml-error-cursor nil)           ;   ditto
279    
280  (defun sml-proc-buffer ()  (defun sml-proc-buffer ()
281    "Returns the current ML process buffer,    "Return the current ML process buffer.
282  or the current buffer if it is in `inferior-sml-mode'. Raises an error  or the current buffer if it is in `inferior-sml-mode'. Raises an error
283  if the variable `sml-buffer' does not appear to point to an existing  if the variable `sml-buffer' does not appear to point to an existing
284  buffer."  buffer."
# Line 259  Line 288 
288               ;; buffer-name returns nil if the buffer has been killed               ;; buffer-name returns nil if the buffer has been killed
289               (and buf (buffer-name buf) buf)))               (and buf (buffer-name buf) buf)))
290        ;; no buffer found, make a new one        ;; no buffer found, make a new one
291        (run-sml t)))        (save-excursion (call-interactively 'run-sml))))
   
 (defun sml-proc ()  
   "Returns the current ML process. See variable `sml-buffer'."  
   (assert (eq major-mode 'inferior-sml-mode))  
   (or (get-buffer-process (current-buffer))  
       (progn (run-sml t) (get-buffer-process (current-buffer)))))  
292    
293  (defun sml-buffer (echo)  (defun sml-buffer (echo)
294    "Make the current buffer the current `sml-buffer' if that is sensible.    "Make the current buffer the current `sml-buffer' if that is sensible.
295  Lookup variable `sml-buffer' to see why this might be useful."  Lookup variable `sml-buffer' to see why this might be useful.
296    If prefix argument ECHO is set, then it only reports on the current state."
297    (interactive "P")    (interactive "P")
298    (when (and (not echo) (eq major-mode 'inferior-sml-mode))    (when (not echo)
299      (setq sml-buffer (current-buffer)))      (setq sml-buffer
300    (message "ML process buffer is %s."            (if (eq major-mode 'inferior-sml-mode) (current-buffer)
301                (read-buffer "Set ML process buffer to: " nil t))))
302      (message "ML process buffer is now %s."
303             (or (ignore-errors (buffer-name (get-buffer sml-buffer)))             (or (ignore-errors (buffer-name (get-buffer sml-buffer)))
304                 "undefined")))                 "undefined")))
305    
306  (defun inferior-sml-mode ()  (defun sml-proc ()
307      "Return the current ML process.  See variable `sml-buffer'."
308      (assert (eq major-mode 'inferior-sml-mode))
309      (or (get-buffer-process (current-buffer))
310          (progn (call-interactively 'run-sml)
311                 (get-buffer-process (current-buffer)))))
312    
313    (defun sml-proc-comint-input-filter-function (str)
314      ;; `compile.el' in Emacs-22 fails to notice that file location info from
315      ;; errors should be recomputed afresh (without using stale info from
316      ;; earlier compilations).  We used to cause a refresh in sml-send-string,
317      ;; but this doesn't catch the case when the user types commands directly
318      ;; at the prompt.
319      (compilation-forget-errors)       ;Has to run before compilation-fake-loc.
320      (if (and (fboundp 'compilation-fake-loc) sml-temp-file)
321          (compilation-fake-loc (cdr sml-temp-file) (car sml-temp-file)))
322      str)
323    
324    (defun inferior-sml-next-error-hook ()
325      ;; Try to recognize SML/NJ type error message and to highlight finely the
326      ;; difference between the two types (in case they're large, it's not
327      ;; always obvious to spot it).
328      (save-current-buffer
329        (when (and (derived-mode-p 'sml-mode 'inferior-sml-mode)
330                   (boundp 'next-error-last-buffer)
331                   (bufferp next-error-last-buffer)
332                   (set-buffer next-error-last-buffer)
333                   (derived-mode-p 'inferior-sml-mode)
334                   ;; The position of `point' is not guaranteed :-(
335                   (looking-at ".*\n  operator domain: "))
336          (ignore-errors (require 'smerge-mode))
337          (if (not (fboundp 'smerge-refine-subst))
338              (remove-hook 'next-error-hook 'inferior-sml-next-error-hook)
339            (save-excursion
340              (let ((b1 (match-end 0))
341                    e1 b2 e2)
342                (when (re-search-forward "\n  in expression:\n" nil t)
343                  (setq e2 (match-beginning 0))
344                  (when (re-search-backward "\n  operand:         " b1 t)
345                    (setq e1 (match-beginning 0))
346                    (setq b2 (match-end 0))
347                    (smerge-refine-subst b1 e1 b2 e2
348                                         '((face . smerge-refined-change)))))))))))
349    
350    (define-derived-mode inferior-sml-mode comint-mode "Inferior-SML"
351    "Major mode for interacting with an inferior ML process.    "Major mode for interacting with an inferior ML process.
352    
353  The following commands are available:  The following commands are available:
# Line 321  Line 391 
391      to the end of the process' output, and sends it.      to the end of the process' output, and sends it.
392  DEL converts tabs to spaces as it moves back.  DEL converts tabs to spaces as it moves back.
393  TAB file name completion, as in shell-mode, etc.."  TAB file name completion, as in shell-mode, etc.."
   (interactive)  
   (kill-all-local-variables)  
   (comint-mode)  
394    (setq comint-prompt-regexp sml-prompt-regexp)    (setq comint-prompt-regexp sml-prompt-regexp)
395    (sml-mode-variables)    (sml-mode-variables)
396    
397      ;; We have to install it globally, 'cause it's run in the *source* buffer :-(
398      (add-hook 'next-error-hook 'inferior-sml-next-error-hook)
399    
400      ;; Make TAB add a " rather than a space at the end of a file name.
401      (set (make-local-variable 'comint-completion-addsuffix) '(?/ . ?\"))
402      (add-hook 'comint-input-filter-functions
403                'sml-proc-comint-input-filter-function nil t)
404    
405      (set (make-local-variable 'font-lock-defaults)
406           inferior-sml-font-lock-defaults)
407    ;; For sequencing through error messages:    ;; For sequencing through error messages:
408    (set (make-local-variable 'sml-error-cursor) (point-max-marker))    (set (make-local-variable 'sml-error-cursor) (point-max-marker))
409    (set-marker-insertion-type sml-error-cursor nil)    (set-marker-insertion-type sml-error-cursor nil)
   (set (make-local-variable 'font-lock-defaults)  
        inferior-sml-font-lock-defaults)  
410    
411    ;; compilation support (used for next-error)    ;; Compilation support (used for `next-error').
412      ;; The keymap of compilation-minor-mode is too unbearable, so we
413      ;; just can't use the minor-mode if we can't override the map.
414      (when (boundp 'minor-mode-overriding-map-alist)
415    (set (make-local-variable 'compilation-error-regexp-alist)    (set (make-local-variable 'compilation-error-regexp-alist)
416         sml-error-regexp-alist)         sml-error-regexp-alist)
417    (compilation-shell-minor-mode 1)      (compilation-minor-mode 1)
418        ;; Eliminate compilation-minor-mode's map.
419        (let ((map (make-sparse-keymap)))
420          (dolist (keys '([menu-bar] [follow-link]))
421            ;; Preserve some of the bindings.
422            (define-key map keys (lookup-key compilation-minor-mode-map keys)))
423          (add-to-list 'minor-mode-overriding-map-alist
424                       (cons 'compilation-minor-mode map)))
425    ;; I'm sure people might kill me for that    ;; I'm sure people might kill me for that
426    (setq compilation-error-screen-columns nil)    (setq compilation-error-screen-columns nil)
427    (make-local-variable 'sml-endof-error-alist)      (make-local-variable 'sml-endof-error-alist))
428    ;;(make-local-variable 'sml-error-overlay)    ;;(make-local-variable 'sml-error-overlay)
429    
430    (setq major-mode 'inferior-sml-mode)    (setq mode-line-process '(": %s")))
   (setq mode-name "Inferior ML")  
   (setq mode-line-process '(": %s"))  
   (use-local-map inferior-sml-mode-map)  
   ;;(add-hook 'kill-emacs-hook 'sml-temp-tidy)  
   
   (run-hooks 'inferior-sml-mode-hook))  
431    
432  ;;; FOR RUNNING ML FROM EMACS  ;;; FOR RUNNING ML FROM EMACS
433    
434  ;;;###autoload  ;;;###autoload
435  (defun run-sml (&optional pfx)  (autoload 'run-sml "sml-proc" nil t)
436    "Run an inferior ML process, input and output via buffer *sml*.  (defalias 'run-sml 'sml-run)
437  With a prefix argument, this command allows you to specify any command  (defun sml-run (cmd arg &optional host)
438  line options to pass to the complier. The command runs hook functions    "Run the program CMD with given arguments ARG.
439  on `comint-mode-hook' and `inferior-sml-mode-hook' in that order.  The command is run in buffer *CMD* using mode `inferior-sml-mode'.
440    If the buffer already exists and has a running process, then
441  If there is a process already running in *sml*, just switch to that  just go to this buffer.
442  buffer instead.  
443    This updates `sml-buffer' to the new buffer.
444  In fact the name of the buffer created is chosen to reflect the name  You can have several inferior M(or L process running, but only one (> s
 of the program name specified by `sml-program-name', or entered at the  
 prompt. You can have several inferior ML process running, but only one  
445  current one -- given by `sml-buffer' (qv).  current one -- given by `sml-buffer' (qv).
446    
447    If a prefix argument is used, the user is also prompted for a HOST
448    on which to run CMD using `remote-shell-program'.
449    
450  \(Type \\[describe-mode] in the process buffer for a list of commands.)"  \(Type \\[describe-mode] in the process buffer for a list of commands.)"
451    (interactive "P")    (interactive
452    (let ((cmd (if pfx     (list
453                   (read-string "ML command: " sml-program-name)                   (read-string "ML command: " sml-program-name)
454                 sml-program-name))      (if (or current-prefix-arg (> (length sml-default-arg) 0))
         (args (if pfx  
455                    (read-string "Any args: " sml-default-arg)                    (read-string "Any args: " sml-default-arg)
456                  sml-default-arg)))        sml-default-arg)
457      (sml-run cmd args)))      (if (or current-prefix-arg (> (length sml-host-name) 0))
458            (read-string "On host: " sml-host-name)
459  (defun sml-run (cmd arg)        sml-host-name)))
   "Run the ML program CMD with given arguments ARGS.  
 This usually updates `sml-buffer' to a buffer named *CMD*."  
460    (let* ((pname (file-name-nondirectory cmd))    (let* ((pname (file-name-nondirectory cmd))
461           (args (if (equal arg "") () (sml-args-to-list arg))))           (args (if (equal arg "") () (split-string arg)))
462             (file (when (and sml-config-file (file-exists-p sml-config-file))
463                     sml-config-file)))
464      ;; and this -- to keep these as defaults even if      ;; and this -- to keep these as defaults even if
465      ;; they're set in the mode hooks.      ;; they're set in the mode hooks.
466      (setq sml-program-name cmd)      (setq sml-program-name cmd)
467      (setq sml-default-arg arg)      (setq sml-default-arg arg)
468      (setq sml-buffer (apply 'make-comint pname cmd nil args))      (setq sml-host-name host)
469        ;; For remote execution, use `remote-shell-program'
470        (when (> (length host) 0)
471          (setq args (list* host "cd" default-directory ";" cmd args))
472          (setq cmd remote-shell-program))
473        ;; go for it
474        (let ((exec-path (if (file-name-directory cmd)
475                             ;; If the command has slashes, make sure we
476                             ;; first look relative to the current directory.
477                             ;; Emacs-21 does it for us, but not Emacs-20.
478                             (cons default-directory exec-path) exec-path)))
479          (setq sml-buffer (apply 'make-comint pname cmd file args)))
480    
481      (set-buffer sml-buffer)      (pop-to-buffer sml-buffer)
482      (message (format "Starting \"%s\" in background." pname))      ;;(message (format "Starting \"%s\" in background." pname))
483      (inferior-sml-mode)      (inferior-sml-mode)
484      (goto-char (point-max))      (goto-char (point-max))
485      sml-buffer))      sml-buffer))
486    
487  (defun sml-args-to-list (string)  (defun switch-to-sml (eobp)
   (let ((where (string-match "[ \t]" string)))  
     (cond ((null where) (list string))  
           ((not (= where 0))  
            (cons (substring string 0 where)  
                  (sml-args-to-list (substring string (+ 1 where)  
                                               (length string)))))  
           (t (let ((pos (string-match "[^ \t]" string)))  
                (if (null pos)  
                    nil  
                    (sml-args-to-list (substring string pos  
                                                 (length string)))))))))  
   
 ;;;###autoload  
 (defun switch-to-sml (eob-p)  
488    "Switch to the ML process buffer.    "Switch to the ML process buffer.
489  With prefix argument, positions cursor at point, otherwise at end of buffer."  Move point to the end of buffer unless prefix argument EOBP is set."
490    (interactive "P")    (interactive "P")
491    (pop-to-buffer (sml-proc-buffer))    (pop-to-buffer (sml-proc-buffer))
492    (cond ((not eob-p)    (unless eobp
493           (push-mark (point) t)           (push-mark (point) t)
494           (goto-char (point-max)))))      (goto-char (point-max))))
495    
496  ;; Fakes it with a "use <temp-file>;" if necessary.  ;; Fakes it with a "use <temp-file>;" if necessary.
497    
 ;;;###autoload  
498  (defun sml-send-region (start end &optional and-go)  (defun sml-send-region (start end &optional and-go)
499    "Send current region to the inferior ML process.    "Send current region START..END to the inferior ML process.
500  Prefix argument means switch-to-sml afterwards.  Prefix AND-GO argument means switch-to-sml afterwards.
501    
502  The region is written out to a temporary file and a \"use <temp-file>\" command  The region is written out to a temporary file and a \"use <temp-file>\" command
503  is sent to the compiler.  is sent to the compiler.
# Line 431  Line 506 
506    (if (= start end)    (if (= start end)
507        (message "The region is zero (ignored)")        (message "The region is zero (ignored)")
508      (let* ((buf (sml-proc-buffer))      (let* ((buf (sml-proc-buffer))
            (file (buffer-file-name))  
509             (marker (copy-marker start))             (marker (copy-marker start))
510             (tmp (make-temp-file "sml")))             (tmp (make-temp-file "sml")))
511        (write-region start end tmp nil 'silently)        (write-region start end tmp nil 'silently)
# Line 448  Line 522 
522    
523  (defun sml-send-function (&optional and-go)  (defun sml-send-function (&optional and-go)
524    "Send current paragraph to the inferior ML process.    "Send current paragraph to the inferior ML process.
525  With a prefix argument switch to the sml buffer as well  With a prefix argument AND-GO switch to the sml buffer as well
526  \(cf. `sml-send-region'\)."  \(cf. `sml-send-region'\)."
527    (interactive "P")    (interactive "P")
528    (save-excursion    (save-excursion
# Line 462  Line 536 
536  considered an ML source file by `sml-load-file'. Used by these commands  considered an ML source file by `sml-load-file'. Used by these commands
537  to determine defaults.")  to determine defaults.")
538    
 ;;;###autoload  
539  (defun sml-send-buffer (&optional and-go)  (defun sml-send-buffer (&optional and-go)
540    "Send buffer to inferior shell running ML process.    "Send buffer to inferior shell running ML process.
541  With a prefix argument switch to the sml buffer as well  With a prefix argument AND-GO switch to the sml buffer as well
542  \(cf. `sml-send-region'\)."  \(cf. `sml-send-region'\)."
543    (interactive "P")    (interactive "P")
544    (if (memq major-mode sml-source-modes)    (if (memq major-mode sml-source-modes)
# Line 476  Line 549 
549  ;; bind if she wishes, since its easier to type C-c r than C-u C-c C-r.  ;; bind if she wishes, since its easier to type C-c r than C-u C-c C-r.
550    
551  (defun sml-send-region-and-go (start end)  (defun sml-send-region-and-go (start end)
552    "Send current region to the inferior ML process, and go there."    "Send current region START..END to the inferior ML process, and go there."
553    (interactive "r")    (interactive "r")
554    (sml-send-region start end t))    (sml-send-region start end t))
555    
# Line 485  Line 558 
558    (interactive)    (interactive)
559    (sml-send-function t))    (sml-send-function t))
560    
 ;;; 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  
   
 (defun sml-drag-region (event)  
   "Highlight the text the mouse is dragged over, and send it to ML.  
 This must be bound to a button-down mouse event, currently \\[sml-drag-region].  
   
 If you drag the mouse (ie, keep the mouse button depressed) the  
 program text sent to the complier is delimited by where you started  
 dragging the mouse, and where you release the mouse button.  
   
 If you only click the mouse, the program text sent to the compiler is  
 delimited by the current position of point and the place where you  
 click the mouse.  
   
 In either event, the values of both point and mark are left  
 undisturbed once this operation is completed."  
   (interactive "e")  
   (let ((mark-ring)                     ;BAD: selection start gets cons'd  
         (pmark (point)))                ;where point is now  
     (if (fboundp 'mouse-track-default)  
         ;; Assume this is XEmacs, otherwise assume its Emacs  
         (save-excursion  
           (let ((zmacs-regions))  
             (set-marker (mark-marker) nil)  
             (mouse-track-default event)  
             (if (not (region-exists-p)) (push-mark pmark nil t))  
             (call-interactively 'sml-send-region)))  
       ;; Emacs: making this buffer-local ought to happen in sml-mode  
       (make-local-variable 'transient-mark-mode)  
       (save-excursion  
         (let ((transient-mark-mode 1))  
           (mouse-drag-region event)  
           (if (not mark-active) (push-mark pmark nil t))  
           (call-interactively 'sml-send-region))))))  
   
   
561  ;;; LOADING AND IMPORTING SOURCE FILES:  ;;; LOADING AND IMPORTING SOURCE FILES:
562    
563  (defvar sml-prev-dir/file nil  (defvar sml-prev-dir/file nil
564    "Caches the (directory . file) pair used in the last `sml-load-file'    "Cache for (DIRECTORY . FILE) pair last.
565  or `sml-cd' command. Used for determining the default in the next one.")  Set in `sml-load-file' and `sml-cd' commands.
566    Used to determine the default in the next `ml-load-file'.")
567    
 ;;;###autoload  
568  (defun sml-load-file (&optional and-go)  (defun sml-load-file (&optional and-go)
569    "Load an ML file into the current inferior ML process.    "Load an ML file into the current inferior ML process.
570  With a prefix argument switch to sml buffer as well.  With a prefix argument AND-GO switch to sml buffer as well.
571    
572  This command uses the ML command template `sml-use-command' to construct  This command uses the ML command template `sml-use-command' to construct
573  the command to send to the ML process\; a trailing \"\;\\n\" will be added  the command to send to the ML process\; a trailing \"\;\\n\" will be added
# Line 571  Line 608 
608      (comint-send-string proc str)      (comint-send-string proc str)
609      (when and-go (switch-to-sml nil))))      (when and-go (switch-to-sml nil))))
610    
611  (defun sml-compile (command)  (defun sml-compile (command &optional and-go)
612    "re-make a system using (by default) CM.    "Pass a COMMAND to the SML process to compile the current program.
613     The exact command used can be specified by providing a prefix argument."  
614    You can then use the command \\[next-error] to find the next error message
615    and move to the source code that caused it.
616    
617    Interactively, prompts for the command if `compilation-read-command' is
618    non-nil.  With prefix arg, always prompts.
619    
620    Prefix arg AND-GO also means to `switch-to-sml' afterwards."
621    (interactive    (interactive
622     ;; code taken straight from compile.el     (let* ((dir default-directory)
623              (cmd "cd \"."))
624         ;; look for files to determine the default command
625         (while (and (stringp dir)
626                     (dolist (cf sml-compile-commands-alist 1)
627                       (when (file-exists-p (expand-file-name (cdr cf) dir))
628                         (setq cmd (concat cmd "\"; " (car cf))) (return nil))))
629           (let ((newdir (file-name-directory (directory-file-name dir))))
630             (setq dir (unless (equal newdir dir) newdir))
631             (setq cmd (concat cmd "/.."))))
632         (setq cmd
633               (cond
634                ((local-variable-p 'sml-compile-command) sml-compile-command)
635                ((string-match "^\\s-*cd\\s-+\"\\.\"\\s-*;\\s-*" cmd)
636                 (substring cmd (match-end 0)))
637                ((string-match "^\\s-*cd\\s-+\"\\(\\./\\)" cmd)
638                 (replace-match "" t t cmd 1))
639                ((string-match ";" cmd) cmd)
640                (t sml-compile-command)))
641         ;; code taken from compile.el
642     (if (or compilation-read-command current-prefix-arg)     (if (or compilation-read-command current-prefix-arg)
643         (list (read-from-minibuffer "Compile command: "         (list (read-from-minibuffer "Compile command: "
644                                   sml-compile-command nil nil                                       cmd nil nil '(compile-history . 1)))
645                                   '(compile-history . 1)))         (list cmd))))
646       (list sml-compile-command)))       ;; ;; now look for command's file to determine the directory
647    (setq sml-compile-command command)       ;; (setq dir default-directory)
648         ;; (while (and (stringp dir)
649         ;;             (dolist (cf sml-compile-commands-alist t)
650         ;;               (when (and (equal cmd (car cf))
651         ;;                          (file-exists-p (expand-file-name (cdr cf) dir)))
652         ;;                 (return nil))))
653         ;;   (let ((newdir (file-name-directory (directory-file-name dir))))
654         ;;     (setq dir (unless (equal newdir dir) newdir))))
655         ;; (setq dir (or dir default-directory))
656         ;; (list cmd dir)))
657      (set (make-local-variable 'sml-compile-command) command)
658    (save-some-buffers (not compilation-ask-about-save) nil)    (save-some-buffers (not compilation-ask-about-save) nil)
659    ;; try to find a makefile up the directory tree    (let ((dir default-directory))
660    (let ((dir (when sml-make-file-name default-directory)))      (when (string-match "^\\s-*cd\\s-+\"\\([^\"]+\\)\"\\s-*;" command)
661      (while (and dir (not (file-exists-p (concat dir sml-make-file-name))))        (setq dir (match-string 1 command))
662        (let ((newdir (file-name-directory (directory-file-name dir))))        (setq command (replace-match "" t t command)))
663          (setq dir (unless (equal newdir dir) newdir))))      (setq dir (expand-file-name dir))
     (unless dir (setq dir default-directory))  
664      (with-current-buffer (sml-proc-buffer)      (with-current-buffer (sml-proc-buffer)
665        (setq default-directory dir)        (setq default-directory dir)
666        (sml-send-string (concat (format sml-cd-command dir) "; " command) t t))))        (sml-send-string (concat (format sml-cd-command dir) "; " command)
667                           t and-go))))
668    
669  ;;; PARSING ERROR MESSAGES  ;;; PARSING ERROR MESSAGES
670    
# Line 603  Line 676 
676  (defvar sml-endof-error-alist nil)  (defvar sml-endof-error-alist nil)
677    
678  (defun sml-update-cursor ()  (defun sml-update-cursor ()
679    ;; update buffer local variable    ;; Update buffer local variable.
680    (set-marker sml-error-cursor (1- (process-mark (sml-proc))))    (set-marker sml-error-cursor (1- (process-mark (sml-proc))))
681    (setq sml-endof-error-alist nil)    (setq sml-endof-error-alist nil)
682    (compilation-forget-errors)    ;; This is now done in comint-input-filter-functions.
683      ;; (compilation-forget-errors)       ;Has to run before compilation-fake-loc.
684      ;; (if (and (fboundp 'compilation-fake-loc) sml-temp-file)
685      ;;     (compilation-fake-loc (cdr sml-temp-file) (car sml-temp-file)))
686    (if (markerp compilation-parsing-end)    (if (markerp compilation-parsing-end)
687        (set-marker compilation-parsing-end sml-error-cursor)        (set-marker compilation-parsing-end sml-error-cursor)
688      (setq compilation-parsing-end sml-error-cursor)))      (setq compilation-parsing-end sml-error-cursor)))
# Line 615  Line 691 
691    (let ((err (point-marker))    (let ((err (point-marker))
692          (linenum (string-to-number c))          (linenum (string-to-number c))
693          (filename (list (first f) (second f)))          (filename (list (first f) (second f)))
694          (column (string-to-number (compile-buffer-substring (third f)))))          (column (string-to-number (match-string (third f)))))
695      ;; record the end of error, if any      ;; record the end of error, if any
696      (when (fourth f)      (when (fourth f)
697        (let* ((endline (string-to-number (compile-buffer-substring (fourth f))))        (let ((endlinestr (match-string (fourth f))))
698               (endcol (string-to-number (compile-buffer-substring (fifth f))))          (when endlinestr
699              (let* ((endline (string-to-number endlinestr))
700                     (endcol (string-to-number
701                              (or (match-string (fifth f)) "0")))
702               (linediff (- endline linenum)))               (linediff (- endline linenum)))
703          (push (list err linediff (if (= 0 linediff) (- endcol column) endcol))          (push (list err linediff (if (= 0 linediff) (- endcol column) endcol))
704                sml-endof-error-alist)))                    sml-endof-error-alist)))))
705      ;; build the error descriptor      ;; build the error descriptor
706      (if (string= (car sml-temp-file) (first f))      (if (string= (car sml-temp-file) (first f))
707          ;; special case for code sent via sml-send-region          ;; special case for code sent via sml-send-region
# Line 631  Line 710 
710              (goto-char marker)              (goto-char marker)
711              (forward-line (1- linenum))              (forward-line (1- linenum))
712              (forward-char (1- column))              (forward-char (1- column))
713              (cons err (point-marker))))              ;; A pair of markers is the right thing to return, but some
714                ;; code in compile.el doesn't like it (when we reach the end
715                ;; of the errors).  So we could try to avoid it, but we don't
716                ;; because that doesn't work correctly if the current buffer
717                ;; has unsaved modifications.  And it's fixed in Emacs-21.
718                ;; (if buffer-file-name
719                ;;  (list err buffer-file-name
720                ;;        (count-lines (point-min) (point)) (current-column))
721                (cons err (point-marker)))) ;; )
722        ;; taken from compile.el        ;; taken from compile.el
723        (list err filename linenum column))))        (list err filename linenum column))))
724    
725    (unless (fboundp 'compilation-fake-loc)
726  (defadvice compilation-goto-locus (after sml-endof-error activate)  (defadvice compilation-goto-locus (after sml-endof-error activate)
727    (let* ((next-error (ad-get-arg 0))    (let* ((next-error (ad-get-arg 0))
728           (err (car next-error))           (err (car next-error))
# Line 650  Line 738 
738            (forward-char coldiff))            (forward-char coldiff))
739          (sml-error-overlay nil pos (point))          (sml-error-overlay nil pos (point))
740          (push-mark nil t (not sml-error-overlay))          (push-mark nil t (not sml-error-overlay))
741          (goto-char pos)))))          (goto-char pos))))))
742    
743  (defun sml-error-overlay (undo &optional beg end)  (defun sml-error-overlay (undo &optional beg end)
744    "Move `sml-error-overlay' so it surrounds the text region in the    "Move `sml-error-overlay' to the text region in the current buffer.
745  current buffer. If the buffer-local variable `sml-error-overlay' is  If the buffer-local variable `sml-error-overlay' is
746  non-nil it should be an overlay \(or extent, in XEmacs speak\)\; this  non-nil it should be an overlay \(or extent, in XEmacs speak\)\; this
747  function moves the overlay over the current region. If the optional  function moves the overlay over the current region. If the optional
748  BUFFER argument is given, move the overlay in that buffer instead of  BUFFER argument is given, move the overlay in that buffer instead of
# Line 675  Line 763 
763              (end (or end (region-end))))              (end (or end (region-end))))
764          (move-overlay sml-error-overlay beg end (current-buffer))))))          (move-overlay sml-error-overlay beg end (current-buffer))))))
765    
 ;;; 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  
   
 (if window-system  
     (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)  
            ;; LUCID (19.10) or later...  
            (define-key sml-mode-map '(meta shift button1) 'sml-drag-region))  
           (t  
            ;; GNU, post circa 19.19  
            (define-key sml-mode-map [M-S-down-mouse-1] 'sml-drag-region))))  
   
 ;;; ...and do the user's customisations.  
   
 (run-hooks 'inferior-sml-load-hook)  
   
 ;;; Here is where sml-proc.el ends  
766  (provide 'sml-proc)  (provide 'sml-proc)
767    
768    ;;; sml-proc.el ends here

Legend:
Removed from v.394  
changed lines
  Added in v.2824

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