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/trunk/sml-mode/sml-proc.el
ViewVC logotype

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

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

revision 39, Sat Mar 14 04:41:37 1998 UTC revision 1691, Mon Nov 15 03:26:57 2004 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  ;; Copyright (C) 1989, Lars Bo Nielsen, 1994,1997 Matthew J. Morley  ;; Copyright (C) 1999,2000,03,04  Stefan Monnier
4    ;; Copyright (C) 1994-1997  Matthew J. Morley
5    ;; Copyright (C) 1989       Lars Bo Nielsen
6    
7  ;; $Revision$  ;; $Revision$
8  ;; $Date$  ;; $Date$
# Line 31  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,
40  ;; backup and all the other benefits of comint. Interaction is  ;; 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  ;; achieved by M-x run-sml which starts a sub-process under emacs. You may
42  ;; need to set this up for autoloading in your .emacs:  ;; need to set this up for autoloading in your .emacs:
43    
44  ;; (autoload 'sml "sml-proc" "Run an inferior ML process." t)  ;; (autoload 'run-sml "sml-proc" "Run an inferior ML process." t)
45    
46  ;; Exactly what process is governed by the variable sml-program-name  ;; 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  ;; -- 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  ;; run-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 --  ;; the default -- if you just hit RETURN you get the default anyway --
50  ;; along with the option to specify any command line arguments. Once  ;; along with the option to specify any command line arguments. Once
51  ;; you select the ML program name in this manner, it remains the  ;; you select the ML program name in this manner, it remains the
# Line 64  Line 66 
66  ;; region of text to the ML process, etc. Given a prefix argument to  ;; 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  ;; 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  ;; 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  ;; reported by the compiler, C-x ` (next-error) will step through
70  ;; the errors with you.  ;; the errors with you.
71    
72  ;; NOTE. There is only limited support for this as it obviously  ;; NOTE. There is only limited support for this as it obviously
73  ;; depends on the compiler's error messages being recognised by the  ;; depends on the compiler's error messages being recognised by the
74  ;; mode. Error reporting is currently only geared up for SML/NJ,  ;; 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  ;; Moscow ML, and Poly/ML.  For other compilers, add the relevant
76  ;; the documentation for sml-error-parser and sml-next-error -- you  ;; regexp to sml-error-regexp-alist and send it to me.
 ;; may only need to modify the former to recover this feature for some  
 ;; other ML systems, along with sml-error-regexp.  
   
 ;; While small pieces of text can be fed quite happily into the ML  
 ;; process directly, lager pieces should (probably) be sent via a  
 ;; temporary file making use of the compiler's "use" command.  
   
 ;; CURRENT RATIONALE: you get sense out of the error messages if  
 ;; there's a real file associated with a block of code, and XEmacs is  
 ;; less likely to hang. These are likely to change.  
   
 ;; For more information see the variable sml-temp-threshold. You  
 ;; should set the variable sml-use-command appropriately for your ML  
 ;; compiler. By default things are set up to work for the SML/NJ  
 ;; compiler.  
   
 ;;; FOR YOUR .EMACS  
   
 ;; Here  are some ideas for inferior-sml-*-hooks:  
   
 ;; (setq inferior-sml-load-hook  
 ;;       '(lambda() "Set global defaults for inferior-sml-mode"  
 ;;          (define-key inferior-sml-mode-map "\C-cd"    'sml-cd)  
 ;;          (define-key          sml-mode-map "\C-cd"    'sml-cd)  
 ;;          (define-key          sml-mode-map "\C-c\C-f" 'sml-send-function)  
 ;;          (setq sml-temp-threshold 0))) ; safe: always use tmp file  
   
 ;; (setq inferior-sml-mode-hook  
 ;;       '(lambda() "Inferior SML mode defaults"  
 ;;          (setq comint-scroll-show-maximum-output t  
 ;;                comint-scroll-to-bottom-on-output t  
 ;;                comint-input-autoexpand nil)))  
77    
78  ;; ===================================================================  ;; 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    
83  ;;; INFERIOR ML MODE VARIABLES  ;; Bugs:
84    
85  (require 'sml-mode)  ;; Todo:
 (require 'comint)  
 (provide 'sml-proc)  
86    
87  (defvar sml-program-name "sml"  ;; - Keep improving `sml-compile'.
88    "*Program to run as ML.")  ;; - ignore warnings (if requested) for next-error
89    
90  (defvar sml-default-arg ""  ;;; Code:
   "*Default command line option to pass, if any.")  
91    
92  (defvar sml-make-command "CM.make()"  (eval-when-compile (require 'cl))
93    "The command used by default by `sml-make'.")  (require 'sml-mode)
94    (require 'sml-util)
95    (require 'comint)
96    (require 'compile)
97    
98  (defvar sml-make-file-name "sources.cm"  (defgroup sml-proc ()
99    "The name of the makefile that `sml-make' will look for (if non-nil).")    "Interacting with an SML process."
100      :group 'sml)
101  ;;(defvar sml-raise-on-error nil  
102  ;;  "*When non-nil, `sml-next-error' will raise the ML process's frame.")  (defcustom sml-program-name "sml"
103      "*Program to run as ML."
104  (defvar sml-temp-threshold 0    :group 'sml-proc
105    "*Controls when emacs uses temporary files to communicate with ML.    :type '(string))
106  If not a number (e.g., NIL), then emacs always sends text directly to  
107  the subprocess. If an integer N, then emacs uses a temporary file  (defcustom sml-default-arg ""
108  whenever the text is longer than N chars. `sml-temp-file' contains the    "*Default command line option to pass, if any."
109  name of the temporary file for communicating. See variable    :group 'sml-proc
110  `sml-use-command' and function `sml-send-region'.    :type '(string))
111    
112  Sending regions directly through the pty (not using temp files)  (defcustom sml-host-name ""
113  doesn't work very well -- e.g., SML/NJ nor Poly/ML incorrectly report    "*Host on which to run ML."
114  the line # of errors occurring in std_in.")    :group 'sml-proc
115      :type '(string))
116  (defvar sml-temp-file  
117    (make-temp-name  (defcustom sml-config-file "~/.smlproc.sml"
118     (concat (file-name-as-directory (or (getenv "TMPDIR") "/tmp")) "/ml"))    "*File that should be fed to the ML process when started."
119    "*Temp file that emacs uses to communicate with the ML process.    :group 'sml-proc
120  See `sml-temp-threshold'. Defaults to \(make-temp-name \"/tmp/ml\"\)")    :type '(string))
121    
122    (defcustom sml-compile-command "CM.make()"
123      "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    
140  (defvar inferior-sml-load-hook nil  (defvar sml-error-overlay nil
141    "*Hook run when inferior-sml-mode (sml-proc.el) is loaded into Emacs.    "*Non-nil means use an overlay to highlight errorful code in the buffer.
142  This is a good place to put your preferred key bindings.")  The actual value is the name of a face to use for the overlay.
143    Instead of setting this variable to 'region, you can also simply keep
144    it NIL and use (transient-mark-mode) which will provide similar
145    benefits (but with several side effects).")
146    
147  (defvar sml-buffer nil  (defvar sml-buffer nil
148    "*The current ML process buffer.    "*The current ML process buffer.
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 187  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 211  Line 201 
201  The format specifier \"%s\" will be converted into the directory name  The format specifier \"%s\" will be converted into the directory name
202  specified when running the command \\[sml-cd].")  specified when running the command \\[sml-cd].")
203    
204  (defvar sml-prompt-regexp "^[\-=] *"  (defcustom sml-prompt-regexp "^[-=>#] *"
205    "*Regexp used to recognise prompts in the inferior ML process.")    "*Regexp used to recognise prompts in the inferior ML process."
206      :group 'sml-proc
207  (defvar sml-error-parser 'sml-smlnj-error-parser    :type '(regexp))
208    "*This function parses an error message into a 3-5 element list:  
209    (defvar sml-error-regexp-alist
210      \(file start-line start-col end-line-col err-msg\).    `( ;; Poly/ML messages
211        ("\\(Error\\|Warning:\\) in '\\(.+\\)', line \\([0-9]+\\)" 2 3)
212  The first three components are required by `sml-next-error', but the other      ;; Moscow ML
213  two are optional. If the file associated with the input is the standard      ("File \"\\([^\"]+\\)\", line \\([0-9]+\\)\\(-\\([0-9]+\\)\\)?, characters \\([0-9]+\\)-\\([0-9]+\\):" 1 2 5)
214  input stream, this function should probably return      ,@(if (not (fboundp 'compilation-fake-loc))
215              ;; SML/NJ:  the file-pattern is anchored to avoid
216      \(\"std_in\" start-line start-col\).            ;; pathological behavior with very long lines.
217              '(
218  This function will be called in a context in which the match data \(see              ("^[-= ]*\\(.*[^\n)]\\)\\( (.*)\\)?:\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warning\\): .*" 1 sml-make-error 3 4 6 7)
219  `match-data'\) are current for `sml-error-regexp'. The mode sets the              ("^ +\\(raised at: \\)?\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2 sml-make-error 3 4 6 7))
220  default value to the function `sml-smlnj-error-parser'.          '(("^[-= ]*\\(.*[^\n)]\\)\\( (.*)\\)?:\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warnin\\(g\\)\\): .*" 1 (3 . 6) (4 . 7) (9))
221              ;; SML/NJ's exceptions:  see above.
222  In a step towards greater sml-mode modularity END-LINE-COL can be either            ("^ +\\(raised at: \\)?\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2 (3 . 6) (4 . 7)))))
223      "Alist that specifies how to match errors in compiler output.
224    - the symbol nil \(in which case it is ignored\)  See `compilation-error-regexp-alist' for a description of the format.")
   
 or  
   
   - an Emacs Lisp expression that when `eval'd at \(start-line,start-col\)  
     will move point to the end of the errorful text in the file.  
   
 Note that the compiler should return the full path name of the errorful  
 file, and that this might require you to fiddle with the compiler's  
 prettyprinting switches.")  
   
 ;; std_in:2.1-4.3 Error: operator and operand don't agree (tycon mismatch)  
 ;; std_in:2.1 Error: operator and operand don't agree (tycon mismatch)  
   
 (defconst sml-smlnj-error-regexp  
   (concat  
    "^[-= ]*\\(.+\\):"                     ;file name  
    "\\([0-9]+\\)\\.\\([0-9]+\\)"          ;start line.column  
    "\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)?"  ;end line.colum  
    ".+\\(\\(Error\\|Warning\\): .*\\)")   ;the message  
   
   "Default regexp matching SML/NJ error and warning messages.  
   
 There should be no need to customise this, though you might decide  
 that you aren't interested in Warnings -- my advice would be to modify  
 `sml-error-regexp' explicitly to do that though.  
   
 If you do customise `sml-smlnj-error-regexp' you may need to modify  
 the function `sml-smlnj-error-parser' (qv).")  
   
 (defvar sml-error-regexp sml-smlnj-error-regexp  
   "*Regexp for matching \(the start of\) an error message.")  
225    
226  ;; font-lock support  ;; font-lock support
227  (defvar inferior-sml-font-lock-keywords  (defconst inferior-sml-font-lock-keywords
228    `((,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")    `(;; prompt and following interactive command
229        (,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
230       (1 font-lock-prompt-face)       (1 font-lock-prompt-face)
231       (2 font-lock-command-face keep))       (2 font-lock-command-face keep))
232      (,sml-error-regexp . font-lock-warning-face)      ;; CM's messages
233      ("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face)      ("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face)
234      ("^GC #.*" . font-lock-comment-face)))      ;; SML/NJ's irritating GC messages
235        ("^GC #.*" . font-lock-comment-face)
236        ;; error messages
237        ,@(mapcar (lambda (ra) (cons (car ra) 'font-lock-warning-face))
238                  sml-error-regexp-alist))
239      "Font-locking specification for inferior SML mode.")
240    
241    (defface font-lock-prompt-face
242      '((t (:bold t)))
243      "Font Lock mode face used to highlight prompts."
244      :group 'font-lock-highlighting-faces)
245    (defvar font-lock-prompt-face 'font-lock-prompt-face
246      "Face name to use for prompts.")
247    
248    (defface font-lock-command-face
249      '((t (:bold t)))
250      "Font Lock mode face used to highlight interactive commands."
251      :group 'font-lock-highlighting-faces)
252    (defvar font-lock-command-face 'font-lock-command-face
253      "Face name to use for interactive commands.")
254    
255  ;; default faces values  (defconst inferior-sml-font-lock-defaults
 (defvar font-lock-prompt-face  
   (if (facep 'font-lock-prompt-face)  
       'font-lock-prompt-face  
     'font-lock-keyword-face))  
 (defvar font-lock-command-face  
   (if (facep 'font-lock-command-face)  
       'font-lock-command-face  
     'font-lock-function-name-face))  
   
 (defvar inferior-sml-font-lock-defaults  
256    '(inferior-sml-font-lock-keywords nil nil nil nil))    '(inferior-sml-font-lock-keywords nil nil nil nil))
257    
 (defun sml-smlnj-error-parser (pt)  
  "This parses the SML/NJ error message at PT into a 5 element list  
   
     \(file start-line start-col end-of-err msg\)  
   
 where FILE is the file in which the error occurs\; START-LINE is the line  
 number in the file where the error occurs\; START-COL is the character  
 position on that line where the error occurs.  
   
 If present, the fourth return value is a simple Emacs Lisp expression that  
 will move point to the end of the errorful text, assuming that point is at  
 \(start-line,start-col\) to begin with\; and MSG is the text of the error  
 message given by the compiler."  
   
  ;; This function uses `sml-smlnj-error-regexp' to do the parsing, and  
  ;; assumes that regexp groups 1, 2, and 3 correspond to the first three  
  ;; elements of the list returned\; and groups 5, 6 and 7 correspond to the  
  ;; optional elements in that order.  
   
  (save-excursion  
    (goto-char pt)  
    (if (not (looking-at sml-smlnj-error-regexp))  
        ;; the user loses big time.  
        (list nil nil nil)  
      (let ((file (match-string 1))                  ; the file  
            (slin (string-to-int (match-string 2)))  ; the start line  
            (scol (string-to-int (match-string 3)))  ; the start col  
            (msg (if (match-beginning 7) (match-string 7))))  
        ;; another loss: buggy sml/nj's produce nonsense like file:0.0 Error  
        (if (zerop slin) (list file nil scol)  
          ;; ok, was a range of characters mentioned?  
          (if (match-beginning 4)  
              ;; assume m-b 4 implies m-b 5 and m-b 6 (sml-smlnj-error-regexp)  
              (let* ((elin (string-to-int (match-string 5))) ; end line  
                     (ecol (string-to-int (match-string 6))) ; end col  
                     (jump (if (= elin slin)  
                               ;; move forward on the same line  
                               `(forward-char ,(1+ (- ecol scol)))  
                             ;; otherwise move down, and over to ecol  
                             `(progn  
                                (forward-line ,(- elin slin))  
                                (forward-char ,ecol)))))  
                ;; nconc glues lists together. jump & msg aren't lists  
                (nconc (list file slin scol) (list jump) (list msg)))  
            (nconc (list file slin scol) (list nil) (list msg))))))))  
   
 (defun sml-smlnj (pfx)  
    "Set up and run Standard ML of New Jersey.  
 Prefix argument means accept the defaults below.  
   
 Note: defaults set here will be clobbered if you setq them in the  
 inferior-sml-mode-hook.  
   
  sml-program-name  <option> \(default \"sml\"\)  
  sml-default-arg   <option> \(default \"\"\)  
  sml-use-command   \"use \\\"%s\\\"\"  
  sml-cd-command    \"OS.FileSys.chDir \\\"%s\\\"\"  
  sml-prompt-regexp \"^[\\-=] *\"  
  sml-error-regexp  sml-sml-nj-error-regexp  
  sml-error-parser  'sml-sml-nj-error-parser"  
    (interactive "P")  
    (let ((cmd (if pfx "sml"  
                 (read-string "Command name: " sml-program-name)))  
          (arg (if pfx ""  
                 (read-string "Any arguments or options (default none): "))))  
      ;; sml-mode global variables  
      (setq sml-program-name cmd)  
      (setq sml-default-arg  arg)  
      ;; buffer-local (compiler-local) variables  
      (setq-default sml-use-command   "use \"%s\""  
                    sml-cd-command    "OS.FileSys.chDir \"%s\""  
                    sml-prompt-regexp "^[\-=] *"  
                    sml-error-regexp  sml-smlnj-error-regexp  
                    sml-error-parser  'sml-smlnj-error-parser)  
      (sml-run cmd sml-default-arg)))  
   
258    
259  ;;; CODE  ;;; CODE
260    
261  (defvar inferior-sml-mode-map nil)  (defmap inferior-sml-mode-map
262      '(("\C-c\C-s" . run-sml)
263        ("\C-c\C-l" . sml-load-file)
264        ("\t"       . comint-dynamic-complete))
265      "Keymap for inferior-sml mode"
266      :inherit comint-mode-map
267      :group 'sml-proc)
268    
269    
270  ;; buffer-local  ;; buffer-local
271    
272  (defvar sml-error-file nil)             ; file from which the last error came  (defvar sml-temp-file nil)
273  (defvar sml-real-file nil)              ; used for finding source errors  ;;(defvar sml-error-file nil)             ; file from which the last error came
274  (defvar sml-error-cursor nil)           ;   ditto  (defvar sml-error-cursor nil)           ;   ditto
 (defvar sml-error-barrier nil)          ;   ditto  
275    
276  (defun sml-proc-buffer ()  (defun sml-proc-buffer ()
277    "Returns the current ML process buffer,    "Return the current ML process buffer.
278  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
279  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
280  buffer."  buffer."
281    (let ((buffer    (or (and (eq major-mode 'inferior-sml-mode) (current-buffer))
282           (cond ((eq major-mode 'inferior-sml-mode)        (and sml-buffer
283                  ;; default to current buffer if it's in inferior-sml-mode             (let ((buf (get-buffer sml-buffer)))
                 (current-buffer))  
                ((bufferp sml-buffer)  
284                 ;; buffer-name returns nil if the buffer has been killed                 ;; buffer-name returns nil if the buffer has been killed
285                  (buffer-name sml-buffer))               (and buf (buffer-name buf) buf)))
286                 ((stringp sml-buffer)        ;; no buffer found, make a new one
287                  ;; get-buffer returns nil if there's no buffer of that name        (save-excursion (call-interactively 'run-sml))))
                 (get-buffer sml-buffer)))))  
     (or buffer  
         (error "No current process buffer. See variable sml-buffer"))))  
   
 (defun sml-proc ()  
   "Returns the current ML process. See variable `sml-buffer'."  
   (let ((proc (get-buffer-process (sml-proc-buffer))))  
     (or proc  
         (error "No current process. See variable sml-buffer"))))  
288    
289  (defun sml-buffer (echo)  (defun sml-buffer (echo)
290    "Make the current buffer the current `sml-buffer' if that is sensible.    "Make the current buffer the current `sml-buffer' if that is sensible.
291  Lookup variable `sml-buffer' to see why this might be useful."  Lookup variable `sml-buffer' to see why this might be useful.
292    If prefix argument ECHO is set, then it only reports on the current state."
293    (interactive "P")    (interactive "P")
294    (let ((current    (when (not echo)
295           (cond ((bufferp sml-buffer) (or (buffer-name sml-buffer) "undefined"))      (setq sml-buffer
296                 ((stringp sml-buffer) sml-buffer)            (if (eq major-mode 'inferior-sml-mode) (current-buffer)
297                 (t "undefined"))))              (read-buffer "Set ML process buffer to: " nil t))))
298    (if echo (message (format "ML process buffer is %s." current))    (message "ML process buffer is now %s."
299      (let ((buffer (if (eq major-mode 'inferior-sml-mode) (current-buffer))))             (or (ignore-errors (buffer-name (get-buffer sml-buffer)))
300        (if (not buffer) (message (format "ML process buffer is %s." current))                 "undefined")))
301          (setq sml-buffer buffer)  
302          (message (format "ML process buffer is %s." (buffer-name buffer))))))))  (defun sml-proc ()
303      "Return the current ML process.  See variable `sml-buffer'."
304  (defun sml-noproc ()    (assert (eq major-mode 'inferior-sml-mode))
305    "Nil iff `sml-proc' returns a process."    (or (get-buffer-process (current-buffer))
306    (condition-case nil (progn (sml-proc) nil) (error t)))        (progn (call-interactively 'run-sml)
307                 (get-buffer-process (current-buffer)))))
 (defun sml-proc-tidy ()  
   "Something to add to `kill-emacs-hook' to tidy up tmp files on exit."  
   (if (file-readable-p sml-temp-file)  
       (delete-file sml-temp-file)))  
308    
309  (defun inferior-sml-mode ()  (define-derived-mode inferior-sml-mode comint-mode "Inferior-SML"
310    "Major mode for interacting with an inferior ML process.    "Major mode for interacting with an inferior ML process.
311    
312  The following commands are available:  The following commands are available:
# Line 446  Line 331 
331  `sml-prompt-regexp' (default \"^[\\-=] *\")  `sml-prompt-regexp' (default \"^[\\-=] *\")
332      Regexp used to recognise prompts in the inferior ML process.      Regexp used to recognise prompts in the inferior ML process.
333    
 `sml-temp-threshold' (default 0)  
     Controls when emacs uses temporary files to communicate with ML.  
     If an integer N, then emacs uses a temporary file whenever the  
     text is longer than N chars.  
   
 `sml-temp-file' (default (make-temp-name \"/tmp/ml\"))  
     Temp file that emacs uses to communicate with the ML process.  
   
 `sml-error-regexp'  
    (default -- complicated)  
     Regexp for matching error messages from the compiler.  
   
 `sml-error-parser' (default 'sml-smlnj-error-parser)  
     This function parses a error messages into a 3, 4 or 5 element list:  
     (file start-line start-col (end-line end-col) err-msg).  
   
334  You can send text to the inferior ML process from other buffers containing  You can send text to the inferior ML process from other buffers containing
335  ML source.  ML source.
336      `switch-to-sml' switches the current buffer to the ML process buffer.      `switch-to-sml' switches the current buffer to the ML process buffer.
# Line 481  Line 350 
350      to the end of the process' output, and sends it.      to the end of the process' output, and sends it.
351  DEL converts tabs to spaces as it moves back.  DEL converts tabs to spaces as it moves back.
352  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)  
353    (setq comint-prompt-regexp sml-prompt-regexp)    (setq comint-prompt-regexp sml-prompt-regexp)
354    (sml-mode-variables)    (sml-mode-variables)
355    
   ;; For sequencing through error messages:  
   
   (set (make-local-variable 'sml-error-cursor)  
        (marker-position (point-max-marker)))  
   (set (make-local-variable 'sml-error-barrier)  
        (marker-position (point-max-marker)))  
   (set (make-local-variable 'sml-real-file) (cons nil 0))  
356    (set (make-local-variable 'font-lock-defaults)    (set (make-local-variable 'font-lock-defaults)
357         inferior-sml-font-lock-defaults)         inferior-sml-font-lock-defaults)
358      ;; For sequencing through error messages:
359      (set (make-local-variable 'sml-error-cursor) (point-max-marker))
360      (set-marker-insertion-type sml-error-cursor nil)
361    
362    (make-local-variable 'sml-use-command)    ;; Compilation support (used for `next-error').
363    (make-local-variable 'sml-cd-command)    ;; The keymap of compilation-minor-mode is too unbearable, so we
364    (make-local-variable 'sml-prompt-regexp)    ;; just can't use the minor-mode if we can't override the map.
365    (make-local-variable 'sml-error-parser)    (when (boundp 'minor-mode-overriding-map-alist)
366    (make-local-variable 'sml-error-regexp)      (set (make-local-variable 'compilation-error-regexp-alist)
367             sml-error-regexp-alist)
368    (setq major-mode 'inferior-sml-mode)      (compilation-minor-mode 1)
369    (setq mode-name "Inferior ML")      ;; Eliminate compilation-minor-mode's map.
370    (setq mode-line-process '(": %s"))      (add-to-list 'minor-mode-overriding-map-alist
371    (use-local-map inferior-sml-mode-map)                   (cons 'compilation-minor-mode (make-sparse-keymap)))
372    (add-hook 'kill-emacs-hook 'sml-proc-tidy)      ;; I'm sure people might kill me for that
373        (setq compilation-error-screen-columns nil)
374        (make-local-variable 'sml-endof-error-alist))
375        ;;(make-local-variable 'sml-error-overlay)
376    
377    (run-hooks 'inferior-sml-mode-hook))    (setq mode-line-process '(": %s")))
378    
379  ;;; FOR RUNNING ML FROM EMACS  ;;; FOR RUNNING ML FROM EMACS
380    
381  ;;;###autoload  ;;;###autoload
382  (defun run-sml (&optional pfx)  (autoload 'run-sml "sml-proc" nil t)
383    "Run an inferior ML process, input and output via buffer *sml*.  (defalias 'run-sml 'sml-run)
384  With a prefix argument, this command allows you to specify any command  (defun sml-run (cmd arg &optional host)
385  line options to pass to the complier. The command runs hook functions    "Run the program CMD with given arguments ARG.
386  on `comint-mode-hook' and `inferior-sml-mode-hook' in that order.  The command is run in buffer *CMD* using mode `inferior-sml-mode'.
387    If the buffer already exists and has a running process, then
388  If there is a process already running in *sml*, just switch to that  just go to this buffer.
389  buffer instead.  
390    This updates `sml-buffer' to the new buffer.
391  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  
392  current one -- given by `sml-buffer' (qv).  current one -- given by `sml-buffer' (qv).
393    
394    If a prefix argument is used, the user is also prompted for a HOST
395    on which to run CMD using `remote-shell-program'.
396    
397  \(Type \\[describe-mode] in the process buffer for a list of commands.)"  \(Type \\[describe-mode] in the process buffer for a list of commands.)"
398    (interactive "P")    (interactive
399    (let ((cmd (if pfx     (list
400                   (read-string "ML command: " sml-program-name)                   (read-string "ML command: " sml-program-name)
401                 sml-program-name))      (if (or current-prefix-arg (> (length sml-default-arg) 0))
         (args (if pfx  
402                    (read-string "Any args: " sml-default-arg)                    (read-string "Any args: " sml-default-arg)
403                  sml-default-arg)))        sml-default-arg)
404      (sml-run cmd args)))      (if (or current-prefix-arg (> (length sml-host-name) 0))
405            (read-string "On host: " sml-host-name)
406  (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*."  
407    (let* ((pname (file-name-nondirectory cmd))    (let* ((pname (file-name-nondirectory cmd))
408           (bname (format "*%s*" pname))           (args (if (equal arg "") () (split-string arg)))
409           (args (if (equal arg "") () (sml-args-to-list arg))))           (file (when (and sml-config-file (file-exists-p sml-config-file))
410      (if (comint-check-proc bname)                   sml-config-file)))
         (pop-to-buffer (sml-proc-buffer)) ;do nothing but switch buffer  
       (setq sml-buffer  
             (if (null args)  
                 ;; there is a good reason for this; to ensure  
                 ;; *no* argument is sent, not even a "".  
                 (set-buffer (apply 'make-comint pname cmd nil))  
               (set-buffer (apply 'make-comint pname cmd nil args))))  
       (message (format "Starting \"%s\" in background." pname))  
       (inferior-sml-mode)  
       (goto-char (point-max))  
411        ;; and this -- to keep these as defaults even if        ;; and this -- to keep these as defaults even if
412        ;; they're set in the mode hooks.        ;; they're set in the mode hooks.
413        (setq sml-program-name cmd)        (setq sml-program-name cmd)
414        (setq sml-default-arg arg))))      (setq sml-default-arg arg)
415        (setq sml-host-name host)
416        ;; For remote execution, use `remote-shell-program'
417        (when (> (length host) 0)
418          (setq args (list* host "cd" default-directory ";" cmd args))
419          (setq cmd remote-shell-program))
420        ;; go for it
421        (let ((exec-path (if (file-name-directory cmd)
422                             ;; If the command has slashes, make sure we
423                             ;; first look relative to the current directory.
424                             ;; Emacs-21 does it for us, but not Emacs-20.
425                             (cons default-directory exec-path) exec-path)))
426          (setq sml-buffer (apply 'make-comint pname cmd file args)))
427    
428  (defun sml-args-to-list (string)      (pop-to-buffer sml-buffer)
429    (let ((where (string-match "[ \t]" string)))      ;;(message (format "Starting \"%s\" in background." pname))
430      (cond ((null where) (list string))      (inferior-sml-mode)
431            ((not (= where 0))      (goto-char (point-max))
432             (cons (substring string 0 where)      sml-buffer))
                  (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)))))))))  
   
 (defun sml-temp-threshold (&optional thold)  
   "Set the variable to the given prefix (nil, if no prefix given).  
 This is really mainly here to help debugging sml-mode!"  
   (interactive "P")  
   (setq sml-temp-threshold  
         (if current-prefix-arg (prefix-numeric-value thold)))  
   (message "%s" sml-temp-threshold))  
433    
434  ;;;###autoload  (defun switch-to-sml (eobp)
 (defun switch-to-sml (eob-p)  
435    "Switch to the ML process buffer.    "Switch to the ML process buffer.
436  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."
437    (interactive "P")    (interactive "P")
   (if (sml-noproc) (save-excursion (run-sml t)))  
438    (pop-to-buffer (sml-proc-buffer))    (pop-to-buffer (sml-proc-buffer))
439    (cond ((not eob-p)    (unless eobp
440           (push-mark (point) t)           (push-mark (point) t)
441           (goto-char (point-max)))))      (goto-char (point-max))))
442    
443  ;; Fakes it with a "use <temp-file>;" if necessary.  ;; Fakes it with a "use <temp-file>;" if necessary.
444    
 ;;;###autoload  
445  (defun sml-send-region (start end &optional and-go)  (defun sml-send-region (start end &optional and-go)
446    "Send current region to the inferior ML process.    "Send current region START..END to the inferior ML process.
447  Prefix argument means switch-to-sml afterwards.  Prefix AND-GO argument means switch-to-sml afterwards.
448    
449  If the region is longer than `sml-temp-threshold' and the variable  The region is written out to a temporary file and a \"use <temp-file>\" command
450  `sml-use-command' is defined, the region is written out to a temporary file  is sent to the compiler.
451  and a \"use <temp-file>\" command is sent to the compiler\; otherwise the  See variables `sml-use-command'."
 text in the region is sent directly to the compiler. In either case a  
 trailing \"\;\\n\" will be added automatically.  
   
 See variables `sml-temp-threshold', `sml-temp-file' and `sml-use-command'."  
452    (interactive "r\nP")    (interactive "r\nP")
453    (if (sml-noproc) (save-excursion (run-sml t)))    (if (= start end)
454    (cond ((equal start end)        (message "The region is zero (ignored)")
455           (message "The region is zero (ignored)"))      (let* ((buf (sml-proc-buffer))
456          ((and sml-use-command             (marker (copy-marker start))
457                (numberp sml-temp-threshold)             (tmp (make-temp-file "sml")))
458                (< sml-temp-threshold (- end start)))        (write-region start end tmp nil 'silently)
459           ;; Just in case someone is still reading from sml-temp-file:        (with-current-buffer buf
460           (if (file-exists-p sml-temp-file)          (when sml-temp-file
461               (delete-file sml-temp-file))            (ignore-errors (delete-file (car sml-temp-file)))
462           (write-region start end sml-temp-file nil 'silently)            (set-marker (cdr sml-temp-file) nil))
463           (sml-update-barrier (buffer-file-name (current-buffer)) start)          (setq sml-temp-file (cons tmp marker))
464           (sml-update-cursor (sml-proc-buffer))          (sml-send-string (format sml-use-command tmp) nil and-go)))))
          (comint-send-string (sml-proc)  
                  (concat (format sml-use-command sml-temp-file) ";\n")))  
         (t  
          (comint-send-region (sml-proc) start end)  
          (comint-send-string (sml-proc) ";\n")))  
   (if and-go (switch-to-sml nil)))  
   
 ;; Update the buffer-local variables sml-real-file and sml-error-barrier  
 ;; in the process buffer:  
   
 (defun sml-update-barrier (file pos)  
   (let ((buf (current-buffer)))  
     (unwind-protect  
         (let* ((proc (sml-proc))  
                (pmark (marker-position (process-mark proc))))  
           (set-buffer (process-buffer proc))  
           ;; update buffer local variables  
           (setq sml-real-file (and file (cons file pos)))  
           (setq sml-error-barrier pmark))  
       (set-buffer buf))))  
   
 ;; Update the buffer-local error-cursor in proc-buffer to be its  
 ;; current proc mark.  
   
 (defun sml-update-cursor (proc-buffer)  ;always= sml-proc-buffer  
   (let ((buf (current-buffer)))  
     (unwind-protect  
         (let* ((proc (sml-proc))        ;just in case?  
                (pmark (marker-position (process-mark proc))))  
           (set-buffer proc-buffer)  
           ;; update buffer local variable  
           (setq sml-error-cursor pmark))  
       (set-buffer buf))))  
465    
466  ;; This is quite bogus, so it isn't bound to a key by default.  ;; This is quite bogus, so it isn't bound to a key by default.
467  ;; Anyone coming up with an algorithm to recognise fun & local  ;; Anyone coming up with an algorithm to recognise fun & local
# Line 659  Line 469 
469    
470  (defun sml-send-function (&optional and-go)  (defun sml-send-function (&optional and-go)
471    "Send current paragraph to the inferior ML process.    "Send current paragraph to the inferior ML process.
472  With a prefix argument switch to the sml buffer as well  With a prefix argument AND-GO switch to the sml buffer as well
473  \(cf. `sml-send-region'\)."  \(cf. `sml-send-region'\)."
474    (interactive "P")    (interactive "P")
475    (save-excursion    (save-excursion
# Line 667  Line 477 
477      (sml-send-region (point) (mark)))      (sml-send-region (point) (mark)))
478    (if and-go (switch-to-sml nil)))    (if and-go (switch-to-sml nil)))
479    
480  ;;;###autoload  (defvar sml-source-modes '(sml-mode)
481      "*Used to determine if a buffer contains ML source code.
482    If it's loaded into a buffer that is in one of these major modes, it's
483    considered an ML source file by `sml-load-file'.  Used by these commands
484    to determine defaults.")
485    
486  (defun sml-send-buffer (&optional and-go)  (defun sml-send-buffer (&optional and-go)
487    "Send buffer to inferior shell running ML process.    "Send buffer to inferior shell running ML process.
488  With a prefix argument switch to the sml buffer as well  With a prefix argument AND-GO switch to the sml buffer as well
489  \(cf. `sml-send-region'\)."  \(cf. `sml-send-region'\)."
490    (interactive "P")    (interactive "P")
491    (if (memq major-mode sml-source-modes)    (if (memq major-mode sml-source-modes)
# Line 681  Line 496 
496  ;; 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.
497    
498  (defun sml-send-region-and-go (start end)  (defun sml-send-region-and-go (start end)
499    "Send current region to the inferior ML process, and go there."    "Send current region START..END to the inferior ML process, and go there."
500    (interactive "r")    (interactive "r")
501    (sml-send-region start end t))    (sml-send-region start end t))
502    
# Line 690  Line 505 
505    (interactive)    (interactive)
506    (sml-send-function t))    (sml-send-function t))
507    
   
 ;;; Mouse control and handling dedicated frames for Inferior ML  
   
 ;; simplified from frame.el in Emacs: special-display-popup-frame...  
   
 (defun sml-proc-frame ()  
   "Returns the current ML process buffer's frame, or creates one first."  
   (let ((buffer (sml-proc-buffer)))  
     (window-frame (display-buffer buffer))))  
   
 ;;(defun sml-pop-to-buffer (warp)  
 ;;  "(Towards) handling multiple frames properly.  
 ;;Raises the frame, and warps the mouse over there, only if WARP is non-nil."  
 ;;  (let ((current (window-frame (selected-window)))  
 ;;        (buffer  (sml-proc-buffer)))  
 ;;    (let ((frame (sml-proc-frame)))  
 ;;      (if (eq current frame)  
 ;;          (pop-to-buffer buffer)           ; stay on the same frame.  
 ;;        (select-frame frame)               ; XEmacs sometimes moves focus.  
 ;;        (select-window (get-buffer-window buffer)) ; necc. for XEmacs  
 ;;        ;; (raise-frame frame)  
 ;;        (if warp (sml-warp-mouse frame))))))  
   
   
 ;;; 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  
   
 ;; Only these two functions have to dance around the inane differences  
 ;; between Emacs and XEmacs (fortunately)  
   
 (defun sml-warp-mouse (frame)  
   "Warp the pointer across the screen to upper right corner of FRAME."  
   (raise-frame frame)  
   (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)  
          ;; LUCID (19.10) or later... set-m-pos needs a WINDOW  
          (set-mouse-position (frame-root-window frame) (1- (frame-width)) 0))  
         (t  
          ;; GNU, post circa 19.19... set-m-pos needs a FRAME  
          (set-mouse-position frame (1- (frame-width)) 0)  
          ;; probably not needed post 19.29  
          (if (fboundp 'unfocus-frame) (unfocus-frame)))))  
   
 (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))))))  
   
   
508  ;;; LOADING AND IMPORTING SOURCE FILES:  ;;; LOADING AND IMPORTING SOURCE FILES:
509    
510  (defvar sml-source-modes '(sml-mode)  (defvar sml-prev-dir/file nil
511    "*Used to determine if a buffer contains ML source code.    "Cache for (DIRECTORY . FILE) pair last.
512  If it's loaded into a buffer that is in one of these major modes, it's  Set in `sml-load-file' and `sml-cd' commands.
513  considered an ML source file by `sml-load-file'. Used by these commands  Used to determine the default in the next `ml-load-file'.")
 to determine defaults.")  
   
 (defvar sml-prev-l/c-dir/file nil  
   "Caches the (directory . file) pair used in the last `sml-load-file'  
 or `sml-cd' command. Used for determining the default in the next one.")  
514    
 ;;;###autoload  
515  (defun sml-load-file (&optional and-go)  (defun sml-load-file (&optional and-go)
516    "Load an ML file into the current inferior ML process.    "Load an ML file into the current inferior ML process.
517  With a prefix argument switch to sml buffer as well.  With a prefix argument AND-GO switch to sml buffer as well.
518    
519  This command uses the ML command template `sml-use-command' to construct  This command uses the ML command template `sml-use-command' to construct
520  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
521  automatically."  automatically."
522    (interactive "P")    (interactive "P")
523    (if (sml-noproc) (save-excursion (run-sml t)))    (let ((file (car (comint-get-source
524    (if sml-use-command                      "Load ML file: " sml-prev-dir/file sml-source-modes t))))
525        (let ((file      (with-current-buffer (sml-proc-buffer)
              (car (comint-get-source "Load ML file: " sml-prev-l/c-dir/file  
                                      sml-source-modes t))))  
526          ;; Check if buffer needs saved. Should (save-some-buffers) instead?          ;; Check if buffer needs saved. Should (save-some-buffers) instead?
527          (comint-check-source file)          (comint-check-source file)
528          (setq sml-prev-l/c-dir/file        (setq sml-prev-dir/file
529                (cons (file-name-directory file) (file-name-nondirectory file)))                (cons (file-name-directory file) (file-name-nondirectory file)))
530          (sml-update-cursor (sml-proc-buffer))        (sml-send-string (format sml-use-command file) nil and-go))))
         (comint-send-string  
          (sml-proc) (concat (format sml-use-command file) ";\n")))  
     (message "Can't load files if `sml-use-command' is undefined!"))  
   (if and-go (switch-to-sml nil)))  
531    
532  (defun sml-cd (dir)  (defun sml-cd (dir)
533    "Change the working directory of the inferior ML process.    "Change the working directory of the inferior ML process.
# Line 808  Line 536 
536  be executed to change the compiler's working directory\; a trailing  be executed to change the compiler's working directory\; a trailing
537  \"\;\\n\" will be added automatically."  \"\;\\n\" will be added automatically."
538    (interactive "DSML Directory: ")    (interactive "DSML Directory: ")
539    (let* ((buf (sml-proc-buffer))    (let ((dir (expand-file-name dir)))
540           (proc (get-buffer-process buf))      (with-current-buffer (sml-proc-buffer)
541           (dir (expand-file-name dir))        (sml-send-string (format sml-cd-command dir) t)
542           (string (concat (format sml-cd-command dir) ";\n")))        (setq default-directory dir))
543      (save-excursion      (setq sml-prev-dir/file (cons dir nil))))
544        (set-buffer buf)  
545        (goto-char (point-max))  (defun sml-send-string (str &optional print and-go)
546        (insert string)    (let ((proc (sml-proc))
547        (set-marker (process-mark proc) (point))          (str (concat str ";\n"))
548        (if sml-cd-command (process-send-string proc string))          (win (get-buffer-window (current-buffer) 'visible)))
549        (cd dir))      (when win (select-window win))
     (setq sml-prev-l/c-dir/file (cons dir nil))))  
   
 (defun sml-send-command (cmd &optional dir)  
   "Send string to ML process, display this string in ML's buffer"  
   (if (sml-noproc) (save-excursion (run-sml t)))  
   (let* ((my-dir (or dir (expand-file-name default-directory)))  
          (cd-cmd (if my-dir  
                      (concat (format sml-cd-command my-dir) "; ")  
                    ""))  
          (buf (sml-proc-buffer))  
          (proc (get-buffer-process buf))  
          (string (concat cd-cmd cmd ";\n")))  
     (save-some-buffers t)  
     (save-excursion  
       (sml-update-cursor buf)  
       (set-buffer buf)  
550        (goto-char (point-max))        (goto-char (point-max))
551        (insert string)      (when print (insert str))
552        (if my-dir (cd my-dir))      (sml-update-cursor)
553        (set-marker (process-mark proc) (point))      (set-marker (process-mark proc) (point-max))
554        (process-send-string proc string))      (setq compilation-last-buffer (current-buffer))
555      (switch-to-sml t)))      (comint-send-string proc str)
556        (when and-go (switch-to-sml nil))))
557  (defun sml-make (command)  
558    "re-make a system using (by default) CM.  (defun sml-compile (command)
559     The exact command used can be specified by providing a prefix argument."    "Pass a COMMAND to the SML process to compile the current program.
560    
561    You can then use the command \\[next-error] to find the next error message
562    and move to the source code that caused it.
563    
564    Interactively, prompts for the command if `compilation-read-command' is
565    non-nil.  With prefix arg, always prompts."
566    (interactive    (interactive
567     ;; code taken straight from compile.el     (let* ((dir default-directory)
568     (if (or current-prefix-arg (not sml-make-command))            (cmd "cd \"."))
569         (list (read-from-minibuffer "Compile command: "       ;; look for files to determine the default command
570                                   sml-make-command nil nil       (while (and (stringp dir)
571                                   '(compile-history . 1)))                   (dolist (cf sml-compile-commands-alist 1)
572       (list sml-make-command)))                     (when (file-exists-p (expand-file-name (cdr cf) dir))
573    (setq sml-make-command command)                       (setq cmd (concat cmd "\"; " (car cf))) (return nil))))
   ;; try to find a makefile up the sirectory tree  
   (let ((dir (and sml-make-file-name (expand-file-name default-directory))))  
     (while (and dir (not (file-exists-p (concat dir sml-make-file-name))))  
574        (let ((newdir (file-name-directory (directory-file-name dir))))        (let ((newdir (file-name-directory (directory-file-name dir))))
575          (setq dir (if (equal newdir dir) nil newdir))))           (setq dir (unless (equal newdir dir) newdir))
576      (sml-send-command command dir)))           (setq cmd (concat cmd "/.."))))
577         (setq cmd
578               (cond
579                ((local-variable-p 'sml-compile-command) sml-compile-command)
580                ((string-match "^\\s-*cd\\s-+\"\\.\"\\s-*;\\s-*" cmd)
581                 (substring cmd (match-end 0)))
582                ((string-match "^\\s-*cd\\s-+\"\\(\\./\\)" cmd)
583                 (replace-match "" t t cmd 1))
584                ((string-match ";" cmd) cmd)
585                (t sml-compile-command)))
586         ;; code taken from compile.el
587         (if (or compilation-read-command current-prefix-arg)
588             (list (read-from-minibuffer "Compile command: "
589                                         cmd nil nil '(compile-history . 1)))
590           (list cmd))))
591         ;; ;; now look for command's file to determine the directory
592         ;; (setq dir default-directory)
593         ;; (while (and (stringp dir)
594         ;;             (dolist (cf sml-compile-commands-alist t)
595         ;;               (when (and (equal cmd (car cf))
596         ;;                          (file-exists-p (expand-file-name (cdr cf) dir)))
597         ;;                 (return nil))))
598         ;;   (let ((newdir (file-name-directory (directory-file-name dir))))
599         ;;     (setq dir (unless (equal newdir dir) newdir))))
600         ;; (setq dir (or dir default-directory))
601         ;; (list cmd dir)))
602      (set (make-local-variable 'sml-compile-command) command)
603      (save-some-buffers (not compilation-ask-about-save) nil)
604      (let ((dir default-directory))
605        (when (string-match "^\\s-*cd\\s-+\"\\([^\"]+\\)\"\\s-*;" command)
606          (setq dir (match-string 1 command))
607          (setq command (replace-match "" t t command)))
608        (setq dir (expand-file-name dir))
609        (with-current-buffer (sml-proc-buffer)
610          (setq default-directory dir)
611          (sml-send-string (concat (format sml-cd-command dir) "; " command) t t))))
612    
613  ;;; PARSING ERROR MESSAGES  ;;; PARSING ERROR MESSAGES
614    
615  ;; This should need no modification to support other compilers.  ;; This should need no modification to support other compilers.
616    
617  ;;;###autoload  ;; Update the buffer-local error-cursor in proc-buffer to be its
618  (defun sml-next-error (skip)  ;; current proc mark.
   "Find the next error by parsing the inferior ML buffer.  
 A prefix argument means `sml-skip-errors' (qv) instead.  
   
 Move the error message on the top line of the window\; put the cursor  
 \(point\) at the beginning of the error source.  
   
 If the error message specifies a range, and `sml-error-parser' returns  
 the range, the mark is placed at the end of the range. If the variable  
 `sml-error-overlay' is non-nil, the region will also be highlighted.  
   
 If `sml-error-parser' returns a fifth component this is assumed to be  
 a string to indicate the nature of the error: this will be echoed in  
 the minibuffer.  
   
 Error interaction only works if there is a real file associated with  
 the input -- though of course it also depends on the compiler's error  
 messages \(also see documantation for `sml-error-parser'\).  
   
 However: if the last text sent went via `sml-load-file' (or the temp  
 file mechanism), the next error reported will be relative to the start  
 of the region sent, any error reports in the previous output being  
 forgotten. If the text went directly to the compiler the succeeding  
 error reported will be the next error relative to the location \(in  
 the output\) of the last error. This odd behaviour may have a use...?"  
   (interactive "P")  
   (if skip (sml-skip-errors) (sml-do-next-error)))  
   
 (defun sml-bottle (msg)  
   "Function to let `sml-next-error' give up gracefully."  
   (sml-warp-mouse (selected-frame))  
   (error msg))  
   
 (defun sml-do-next-error ()  
   "The buisiness end of `sml-next-error' (qv)"  
   (let ((case-fold-search nil)  
         ;; set this variable iff we called sml-next-error in a SML buffer  
         (sml-window (if (memq major-mode sml-source-modes) (selected-window)))  
         (proc-buffer (sml-proc-buffer)))  
     ;; undo (don't destroy) the previous overlay to be tidy  
     (sml-error-overlay 'undo 1 1  
                        (and sml-error-file (get-file-buffer sml-error-file)))  
     ;; go to interaction buffer but don't raise it's frame  
     (pop-to-buffer (sml-proc-buffer))  
     ;; go to the last remembered error, and search for the next one.  
     (goto-char sml-error-cursor)  
     (if (not (re-search-forward sml-error-regexp (point-max) t))  
         ;; no more errors -- move point to the sml prompt at the end  
         (progn  
           (goto-char (point-max))  
           (if sml-window (select-window sml-window)) ;return there, perhaps  
           (message "No error message(s) found."))  
       ;; error found: point is at end of last match; set the cursor posn.  
       (setq sml-error-cursor (point))  
       ;; move the SML window's text up to this line  
       (set-window-start (get-buffer-window proc-buffer) (match-beginning 0))  
       (let* ((pos)  
              (parse (funcall sml-error-parser (match-beginning 0)))  
              (file (nth 0 parse))  
              (line0 (nth 1 parse))  
              (col0 (nth 2 parse))  
              (line/col1 (nth 3 parse))  
              (msg (nth 4 parse)))  
         ;; Give up immediately if the error report is scribble  
         (if (or (null file) (null line0))  
             (sml-bottle "Failed to parse/locate this error properly!"))  
         ;; decide what to do depending on the file returned  
         (if (string= file "std_in")  
             ;; presently a fundamental limitation i'm afraid.  
             (sml-bottle "Sorry, can't locate errors on std_in.")  
           (if (string= file sml-temp-file)  
               ;; errors found in tmp file; seek the real file  
               (if (< (point) sml-error-barrier)  
                   ;; weird. user cleared *sml* and use'd the tmp file?  
                   (sml-bottle "Temp file error report is not current.")  
                 (if (not (car sml-real-file))  
                     ;; sent from a buffer w/o a file attached.  
                     ;; DEAL WITH THIS EVENTUALLY.  
                     (sml-bottle "No real file associated with the temp file.")  
                   ;; real file and error-barrier  
                   (setq file (car sml-real-file))  
                   (setq pos (cdr sml-real-file))))))  
         (if (not (file-readable-p file))  
             (sml-bottle (concat "Can't read " file))  
           ;; instead of (find-file-other-window file) to lookup the file  
           (find-file-other-window file)  
           ;; no good if the buffer's narrowed, still...  
           (goto-char (or pos 1))        ; line 1 if no tmp file  
           (forward-line (1- line0))  
           (forward-char (1- col0))  
           ;; point is at start of error text; seek the end.  
           (let ((start (point))  
                 (end (and line/col1  
                           (condition-case nil  
                               (progn (eval line/col1) (point))  
                             (error nil)))))  
             ;; return to start anyway  
             (goto-char start)  
             ;; if point went to end, put mark there, and maybe highlight  
             (if end (progn (push-mark end t)  
                            (sml-error-overlay nil start end)))  
             (setq sml-error-file file)   ; remember this for next time  
             (if msg (message msg)))))))) ; echo the error/warning message  
   
 (defun sml-skip-errors ()  
   "Skip past the rest of the errors."  
   (interactive)  
   (if (memq major-mode sml-source-modes) (sml-error-overlay 'undo))  
   (sml-update-cursor (sml-proc-buffer))  
   (if (eq major-mode 'sml-inferior-mode) (goto-char (point-max))))  
   
 ;;; Set up the inferior mode keymap, using sml-mode bindings...  
   
 (cond ((not inferior-sml-mode-map)  
        (setq inferior-sml-mode-map (nconc (make-sparse-keymap) comint-mode-map))  
        (install-sml-keybindings inferior-sml-mode-map)  
        (define-key inferior-sml-mode-map "\C-c\C-s" 'run-sml)  
        (define-key inferior-sml-mode-map "\t"       'comint-dynamic-complete)))  
   
 ;;; 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  
619    
620  (if window-system  (defvar sml-endof-error-alist nil)
     (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))))  
621    
622  ;;; ...and do the user's customisations.  (defun sml-update-cursor ()
623      ;; Update buffer local variable.
624      (set-marker sml-error-cursor (1- (process-mark (sml-proc))))
625      (setq sml-endof-error-alist nil)
626      (compilation-forget-errors)
627      (if (fboundp 'compilation-fake-loc)
628          (compilation-fake-loc (cdr sml-temp-file) (car sml-temp-file)))
629      (if (markerp compilation-parsing-end)
630          (set-marker compilation-parsing-end sml-error-cursor)
631        (setq compilation-parsing-end sml-error-cursor)))
632    
633    (defun sml-make-error (f c)
634      (let ((err (point-marker))
635            (linenum (string-to-number c))
636            (filename (list (first f) (second f)))
637            (column (string-to-number (match-string (third f)))))
638        ;; record the end of error, if any
639        (when (fourth f)
640          (let ((endlinestr (match-string (fourth f))))
641            (when endlinestr
642              (let* ((endline (string-to-number endlinestr))
643                     (endcol (string-to-number
644                              (or (match-string (fifth f)) "0")))
645                     (linediff (- endline linenum)))
646                (push (list err linediff (if (= 0 linediff) (- endcol column) endcol))
647                      sml-endof-error-alist)))))
648        ;; build the error descriptor
649        (if (string= (car sml-temp-file) (first f))
650            ;; special case for code sent via sml-send-region
651            (let ((marker (cdr sml-temp-file)))
652              (with-current-buffer (marker-buffer marker)
653                (goto-char marker)
654                (forward-line (1- linenum))
655                (forward-char (1- column))
656                ;; A pair of markers is the right thing to return, but some
657                ;; code in compile.el doesn't like it (when we reach the end
658                ;; of the errors).  So we could try to avoid it, but we don't
659                ;; because that doesn't work correctly if the current buffer
660                ;; has unsaved modifications.  And it's fixed in Emacs-21.
661                ;; (if buffer-file-name
662                ;;  (list err buffer-file-name
663                ;;        (count-lines (point-min) (point)) (current-column))
664                (cons err (point-marker)))) ;; )
665          ;; taken from compile.el
666          (list err filename linenum column))))
667    
668    (unless (fboundp 'compilation-fake-loc)
669    (defadvice compilation-goto-locus (after sml-endof-error activate)
670      (let* ((next-error (ad-get-arg 0))
671             (err (car next-error))
672             (pos (cdr next-error))
673             (endof (with-current-buffer (marker-buffer err)
674                      (assq err sml-endof-error-alist))))
675        (if (not endof) (sml-error-overlay 'undo)
676          (with-current-buffer (marker-buffer pos)
677            (goto-char pos)
678            (let ((linediff (second endof))
679                  (coldiff (third endof)))
680              (when (> 0 linediff) (forward-line linediff))
681              (forward-char coldiff))
682            (sml-error-overlay nil pos (point))
683            (push-mark nil t (not sml-error-overlay))
684            (goto-char pos))))))
685    
686    (defun sml-error-overlay (undo &optional beg end)
687      "Move `sml-error-overlay' to the text region in the current buffer.
688    If the buffer-local variable `sml-error-overlay' is
689    non-nil it should be an overlay \(or extent, in XEmacs speak\)\; this
690    function moves the overlay over the current region. If the optional
691    BUFFER argument is given, move the overlay in that buffer instead of
692    the current buffer.
693    
694    Called interactively, the optional prefix argument UNDO indicates that
695    the overlay should simply be removed: \\[universal-argument] \
696    \\[sml-error-overlay]."
697      (interactive "P")
698      (when sml-error-overlay
699        (unless (overlayp sml-error-overlay)
700          (let ((ol sml-error-overlay))
701            (setq sml-error-overlay (make-overlay 0 0))
702            (overlay-put sml-error-overlay 'face (if (symbolp ol) ol 'region))))
703        (if undo (move-overlay sml-error-overlay 1 1 (current-buffer))
704          ;; if active regions, signals mark not active if no region set
705          (let ((beg (or beg (region-beginning)))
706                (end (or end (region-end))))
707            (move-overlay sml-error-overlay beg end (current-buffer))))))
708    
709  (run-hooks 'inferior-sml-load-hook)  (provide 'sml-proc)
710    
711  ;;; Here is where sml-proc.el ends  ;;; sml-proc.el ends here

Legend:
Removed from v.39  
changed lines
  Added in v.1691

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