Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Tracker SCM

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 32, Thu Mar 12 16:54:39 1998 UTC revision 332, Tue Jun 15 00:51:38 1999 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$")
4    
5  ;; Copyright (C) 1989, Lars Bo Nielsen, 1994,1997 Matthew J. Morley  ;; Copyright (C) 1989, Lars Bo Nielsen, 1994,1997 Matthew J. Morley
6    
7  ;; $Revision$  ;; $Revision$
# Line 78  Line 80 
80  ;; While small pieces of text can be fed quite happily into the ML  ;; While small pieces of text can be fed quite happily into the ML
81  ;; process directly, lager pieces should (probably) be sent via a  ;; process directly, lager pieces should (probably) be sent via a
82  ;; temporary file making use of the compiler's "use" command.  ;; temporary file making use of the compiler's "use" command.
83    ;; To be safe, we always use a temp file (which also improves error
84  ;; CURRENT RATIONALE: you get sense out of the error messages if  ;; reporting).
 ;; 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.  
85    
86  ;;; FOR YOUR .EMACS  ;;; FOR YOUR .EMACS
87    
# Line 97  Line 92 
92  ;;          (define-key inferior-sml-mode-map "\C-cd"    'sml-cd)  ;;          (define-key inferior-sml-mode-map "\C-cd"    'sml-cd)
93  ;;          (define-key          sml-mode-map "\C-cd"    'sml-cd)  ;;          (define-key          sml-mode-map "\C-cd"    'sml-cd)
94  ;;          (define-key          sml-mode-map "\C-c\C-f" 'sml-send-function)  ;;          (define-key          sml-mode-map "\C-c\C-f" 'sml-send-function)
 ;;          (setq sml-temp-threshold 0))) ; safe: always use tmp file  
95    
96  ;; (setq inferior-sml-mode-hook  ;; (setq inferior-sml-mode-hook
97  ;;       '(lambda() "Inferior SML mode defaults"  ;;       '(lambda() "Inferior SML mode defaults"
# Line 110  Line 104 
104  ;;; INFERIOR ML MODE VARIABLES  ;;; INFERIOR ML MODE VARIABLES
105    
106  (require 'sml-mode)  (require 'sml-mode)
107    (require 'sml-util)
108  (require 'comint)  (require 'comint)
109  (provide 'sml-proc)  (require 'compile)
110    
111  (defvar sml-program-name "sml"  (defvar sml-program-name "sml"
112    "*Program to run as ML.")    "*Program to run as ML.")
# Line 119  Line 114 
114  (defvar sml-default-arg ""  (defvar sml-default-arg ""
115    "*Default command line option to pass, if any.")    "*Default command line option to pass, if any.")
116    
117  (defvar sml-display-frame-alist  (defvar sml-compile-command "CM.make()"
118    '((height . 24) (width . 80) (menu-bar-lines . 0))    "The command used by default by `sml-make'.")
   "*Alist of frame parameters used in creating dedicated ML interaction frames.  
 These supersede the values given in `default-frame-alist'.  
 You might like a larger screen  
   
   \(setcdr \(assoc 'height sml-display-frame-alist\) 40\)  
   
 or you might like a small font  
   
   \(setq sml-display-frame-alist  
         \(cons '\(font . \"7x14\"\) sml-display-frame-alist\)\)  
   
 in your `inferior-sml-load-hook', say. The parameters  
   
   '\(\(unsplittable . t\) \(icon-name . \"*sml*\"\)\)  
   
 are always added to sml-display-frame-alist by default, though the value of  
 icon-name is actually culled from `sml-program-name'.  
   
 See also the documentation for `modify-frame-parameters'.")  
119    
120  (defvar sml-dedicated-frame (if window-system t nil)  (defvar sml-make-file-name "sources.cm"
121    "*If non-nil, interaction buffers display in their own frame.    "The name of the makefile that `sml-make' will look for (if non-nil).")
 Default is equivalent to variable `window-system'.  
 If you reset this variable after starting the compiler, you might have  
 to reset the window-dedicated property of the window displaying the  
 interaction buffer. See `set-window-dedicated-p'.")  
122    
123  ;;(defvar sml-raise-on-error nil  ;;(defvar sml-raise-on-error nil
124  ;;  "*When non-nil, `sml-next-error' will raise the ML process's frame.")  ;;  "*When non-nil, `sml-next-error' will raise the ML process's frame.")
125    
 (defvar sml-temp-threshold 0  
   "*Controls when emacs uses temporary files to communicate with ML.  
 If not a number (e.g., NIL), then emacs always sends text directly to  
 the subprocess. If an integer N, then emacs uses a temporary file  
 whenever the text is longer than N chars. `sml-temp-file' contains the  
 name of the temporary file for communicating. See variable  
 `sml-use-command' and function `sml-send-region'.  
   
 Sending regions directly through the pty (not using temp files)  
 doesn't work very well -- e.g., SML/NJ nor Poly/ML incorrectly report  
 the line # of errors occurring in std_in.")  
   
 (defvar sml-temp-file (make-temp-name "/tmp/ml")  
   "*Temp file that emacs uses to communicate with the ML process.  
 See `sml-temp-threshold'. Defaults to \(make-temp-name \"/tmp/ml\"\)")  
   
126  (defvar inferior-sml-mode-hook nil  (defvar inferior-sml-mode-hook nil
127    "*This hook is run when the inferior ML process is started.    "*This hook is run when the inferior ML process is started.
128  All buffer local customisations for the interaction buffers go here.")  All buffer local customisations for the interaction buffers go here.")
# Line 175  Line 131 
131    "*Hook run when inferior-sml-mode (sml-proc.el) is loaded into Emacs.    "*Hook run when inferior-sml-mode (sml-proc.el) is loaded into Emacs.
132  This is a good place to put your preferred key bindings.")  This is a good place to put your preferred key bindings.")
133    
134    (defvar sml-error-overlay nil
135      "*Non-nil means use an overlay to highlight errorful code in the buffer.
136    The actual value is the name of a face to use for the overlay.
137    Instead of setting this variable to 'region, you can also simply keep
138    it NIL and use (transient-mark-mode) which will provide similar
139    benefits (but with several side effects).")
140    
141  (defvar sml-buffer nil  (defvar sml-buffer nil
142    "*The current ML process buffer.    "*The current ML process buffer.
143    
# Line 225  Line 188 
188  Set to \"use \\\"%s\\\"\" for SML/NJ or Edinburgh ML;  Set to \"use \\\"%s\\\"\" for SML/NJ or Edinburgh ML;
189  set to \"PolyML.use \\\"%s\\\"\" for Poly/ML, etc.")  set to \"PolyML.use \\\"%s\\\"\" for Poly/ML, etc.")
190    
191  (defvar sml-cd-command "System.Directory.cd \"%s\""  (defvar sml-cd-command "OS.FileSys.chDir \"%s\""
192    "*Command template for changing working directories under ML.    "*Command template for changing working directories under ML.
193  Set this to nil if your compiler can't change directories.  Set this to nil if your compiler can't change directories.
194    
195  The format specifier \"%s\" will be converted into the directory name  The format specifier \"%s\" will be converted into the directory name
196  specified when running the command \\[sml-cd].")  specified when running the command \\[sml-cd].")
197    
198  (defvar sml-prompt-regexp "^[\-=] *"  (defvar sml-prompt-regexp "^[-=>#] *"
199    "*Regexp used to recognise prompts in the inferior ML process.")    "*Regexp used to recognise prompts in the inferior ML process.")
200    
201  (defvar sml-error-parser 'sml-smlnj-error-parser  (defvar sml-error-parser 'sml-smlnj-error-parser
# Line 266  Line 229 
229  ;; std_in:2.1-4.3 Error: operator and operand don't agree (tycon mismatch)  ;; std_in:2.1-4.3 Error: operator and operand don't agree (tycon mismatch)
230  ;; std_in:2.1 Error: operator and operand don't agree (tycon mismatch)  ;; std_in:2.1 Error: operator and operand don't agree (tycon mismatch)
231    
232  (defconst sml-smlnj-error-regexp  (defconst sml-error-regexp-alist
233    (concat    '(;; Poly/ML messages
234     "^[-= ]*\\(.+\\):"                     ;file name      ("\\(Error\\|Warning:\\) in '\\(.+\\)', line \\([0-9]+\\)" 2 3)
235     "\\([0-9]+\\)\\.\\([0-9]+\\)"          ;start line.column      ;; Moscow ML
236     "\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)?"  ;end line.colum      ("File \"\\([^\"]+\\)\", line \\([0-9]+\\)\\(-\\([0-9]+\\)\\)?, characters \\([0-9]+\\)-\\([0-9]+\\):" 1 2 5)
237     ".+\\(\\(Error\\|Warning\\): .*\\)")   ;the message      ;; SML/NJ
238        ("[-= ]*\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warning\\): .*" 1 sml-make-error 2 3 5 6)
239    "Default regexp matching SML/NJ error and warning messages.      ;; SML/NJ's exceptions
240        (" +\\(raised at: \\)?\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2 sml-make-error 3 4 6 7)))
 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).")  
241    
242  (defvar sml-error-regexp sml-smlnj-error-regexp  (defvar sml-error-regexp nil
243    "*Regexp for matching \(the start of\) an error message.")    "*Regexp for matching \(the start of\) an error message.")
244    
245  (defun sml-smlnj-error-parser (pt)  ;; font-lock support
246   "This parses the SML/NJ error message at PT into a 5 element list  (defconst inferior-sml-font-lock-keywords
247      `(;; prompt and following interactive command
248      \(file start-line start-col end-of-err msg\)      (,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
249         (1 font-lock-prompt-face)
250  where FILE is the file in which the error occurs\; START-LINE is the line       (2 font-lock-command-face keep))
251  number in the file where the error occurs\; START-COL is the character      ;; CM's messages
252  position on that line where the error occurs.      ("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face)
253        ;; SML/NJ's irritating GC messages
254  If present, the fourth return value is a simple Emacs Lisp expression that      ("^GC #.*" . font-lock-comment-face)
255  will move point to the end of the errorful text, assuming that point is at      ;; error messages
256  \(start-line,start-col\) to begin with\; and MSG is the text of the error      ,@(mapcar (lambda (ra) (cons (car ra) 'font-lock-warning-face))
257  message given by the compiler."                sml-error-regexp-alist))
258      "Font-locking specification for inferior SML mode.")
259   ;; This function uses `sml-smlnj-error-regexp' to do the parsing, and  
260   ;; assumes that regexp groups 1, 2, and 3 correspond to the first three  ;; default faces values
261   ;; elements of the list returned\; and groups 5, 6 and 7 correspond to the  (defvar font-lock-prompt-face
262   ;; optional elements in that order.    (if (facep 'font-lock-prompt-face)
263          'font-lock-prompt-face
264   (save-excursion      'font-lock-keyword-face))
265     (goto-char pt)  (defvar font-lock-command-face
266     (if (not (looking-at sml-smlnj-error-regexp))    (if (facep 'font-lock-command-face)
267         ;; the user loses big time.        'font-lock-command-face
268         (list nil nil nil)      'font-lock-function-name-face))
      (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    \"System.Directory.cd \\\"%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    "System.Directory.cd \"%s\""  
                    sml-prompt-regexp "^[\-=] *"  
                    sml-error-regexp  sml-smlnj-error-regexp  
                    sml-error-parser  'sml-smlnj-error-parser)  
      (sml-run cmd sml-default-arg)))  
269    
270    (defvar inferior-sml-font-lock-defaults
271      '(inferior-sml-font-lock-keywords nil nil nil nil))
272    
273  ;;; CODE  ;;; CODE
274    
275  (defvar inferior-sml-mode-map nil)  (defmap inferior-sml-mode-map
276      '(("\C-c\C-s" . run-sml)
277        ("\t"       . comint-dynamic-complete))
278      "Keymap for inferior-sml mode"
279      :inherit (list sml-bindings comint-mode-map))
280    
281    
282  ;; buffer-local  ;; buffer-local
283    
284    (defvar sml-temp-file nil)
285  (defvar sml-error-file nil)             ; file from which the last error came  (defvar sml-error-file nil)             ; file from which the last error came
 (defvar sml-real-file nil)              ; used for finding source errors  
286  (defvar sml-error-cursor nil)           ;   ditto  (defvar sml-error-cursor nil)           ;   ditto
 (defvar sml-error-barrier nil)          ;   ditto  
287    
288  (defun sml-proc-buffer ()  (defun sml-proc-buffer ()
289    "Returns the current ML process buffer,    "Returns the current ML process buffer,
290  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
291  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
292  buffer."  buffer."
293    (let ((buffer    (or (and (eq major-mode 'inferior-sml-mode) (current-buffer))
294           (cond ((eq major-mode 'inferior-sml-mode)        (and sml-buffer
295                  ;; default to current buffer if it's in inferior-sml-mode             (let ((buf (get-buffer sml-buffer)))
                 (current-buffer))  
                ((bufferp sml-buffer)  
296                 ;; buffer-name returns nil if the buffer has been killed                 ;; buffer-name returns nil if the buffer has been killed
297                  (buffer-name sml-buffer))               (and buf (buffer-name buf) buf)))
298                 ((stringp sml-buffer)        ;; no buffer found, make a new one
299                  ;; get-buffer returns nil if there's no buffer of that name        (run-sml t)))
                 (get-buffer sml-buffer)))))  
     (or buffer  
         (error "No current process buffer. See variable sml-buffer"))))  
300    
301  (defun sml-proc ()  (defun sml-proc ()
302    "Returns the current ML process. See variable `sml-buffer'."    "Returns the current ML process. See variable `sml-buffer'."
303    (let ((proc (get-buffer-process (sml-proc-buffer))))    (assert (eq major-mode 'inferior-sml-mode))
304      (or proc    (or (get-buffer-process (current-buffer))
305          (error "No current process. See variable sml-buffer"))))        (progn (run-sml t) (get-buffer-process (current-buffer)))))
306    
307  (defun sml-buffer (echo)  (defun sml-buffer (echo)
308    "Make the current buffer the current `sml-buffer' if that is sensible.    "Make the current buffer the current `sml-buffer' if that is sensible.
309  Lookup variable `sml-buffer' to see why this might be useful."  Lookup variable `sml-buffer' to see why this might be useful."
310    (interactive "P")    (interactive "P")
311    (let ((current    (when (and (not echo) (eq major-mode 'inferior-sml-mode))
312           (cond ((bufferp sml-buffer) (or (buffer-name sml-buffer) "undefined"))      (setq sml-buffer (current-buffer)))
313                 ((stringp sml-buffer) sml-buffer)    (message "ML process buffer is %s."
314                 (t "undefined"))))             (or (ignore-errors (buffer-name (get-buffer sml-buffer)))
315    (if echo (message (format "ML process buffer is %s." current))                 "undefined")))
     (let ((buffer (if (eq major-mode 'inferior-sml-mode) (current-buffer))))  
       (if (not buffer) (message (format "ML process buffer is %s." current))  
         (setq sml-buffer buffer)  
         (message (format "ML process buffer is %s." (buffer-name buffer))))))))  
   
 (defun sml-noproc ()  
   "Nil iff `sml-proc' returns a process."  
   (condition-case nil (progn (sml-proc) nil) (error t)))  
   
 (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)))  
316    
317  (defun inferior-sml-mode ()  (defun inferior-sml-mode ()
318    "Major mode for interacting with an inferior ML process.    "Major mode for interacting with an inferior ML process.
# Line 445  Line 339 
339  `sml-prompt-regexp' (default \"^[\\-=] *\")  `sml-prompt-regexp' (default \"^[\\-=] *\")
340      Regexp used to recognise prompts in the inferior ML process.      Regexp used to recognise prompts in the inferior ML process.
341    
 `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.  
   
342  `sml-error-regexp'  `sml-error-regexp'
343     (default -- complicated)     (default -- complicated)
344      Regexp for matching error messages from the compiler.      Regexp for matching error messages from the compiler.
# Line 487  Line 373 
373    (sml-mode-variables)    (sml-mode-variables)
374    
375    ;; For sequencing through error messages:    ;; For sequencing through error messages:
376    (make-local-variable 'sml-error-cursor)    (set (make-local-variable 'sml-error-cursor) (point-max-marker))
377    (setq sml-error-cursor (marker-position (point-max-marker)))    (set-marker-insertion-type sml-error-cursor nil)
378    (make-local-variable 'sml-error-barrier)    (set (make-local-variable 'font-lock-defaults)
379    (setq sml-error-barrier (marker-position (point-max-marker)))         inferior-sml-font-lock-defaults)
380    (make-local-variable 'sml-real-file)  
381    (setq sml-real-file (cons nil 0))    ;; compilation support (used for next-error)
382      (set (make-local-variable 'compilation-error-regexp-alist)
383    (make-local-variable 'sml-use-command)         sml-error-regexp-alist)
384    (make-local-variable 'sml-cd-command)    (compilation-shell-minor-mode 1)
385    (make-local-variable 'sml-prompt-regexp)    ;; I'm sure people might kill me for that
386    (make-local-variable 'sml-error-parser)    (setq compilation-error-screen-columns nil)
387    (make-local-variable 'sml-error-regexp)    (make-local-variable 'sml-endof-error-alist)
388      ;;(make-local-variable 'sml-error-overlay)
389    
390    (setq major-mode 'inferior-sml-mode)    (setq major-mode 'inferior-sml-mode)
391    (setq mode-name "Inferior ML")    (setq mode-name "Inferior ML")
392    (setq mode-line-process '(": %s"))    (setq mode-line-process '(": %s"))
393    (use-local-map inferior-sml-mode-map)    (use-local-map inferior-sml-mode-map)
394    (add-hook 'kill-emacs-hook 'sml-proc-tidy)    ;;(add-hook 'kill-emacs-hook 'sml-temp-tidy)
395    
396    (run-hooks 'inferior-sml-mode-hook))    (run-hooks 'inferior-sml-mode-hook))
397    
398  ;;; FOR RUNNING ML FROM EMACS  ;;; FOR RUNNING ML FROM EMACS
399    
400  ;;;###autoload  ;;;###autoload
401  (defun sml (&optional pfx)  (defun run-sml (&optional pfx)
402    "Run an inferior ML process, input and output via buffer *sml*.    "Run an inferior ML process, input and output via buffer *sml*.
403  With a prefix argument, this command allows you to specify any command  With a prefix argument, this command allows you to specify any command
404  line options to pass to the complier. The command runs hook functions  line options to pass to the complier. The command runs hook functions
# Line 539  Line 426 
426    "Run the ML program CMD with given arguments ARGS.    "Run the ML program CMD with given arguments ARGS.
427  This usually updates `sml-buffer' to a buffer named *CMD*."  This usually updates `sml-buffer' to a buffer named *CMD*."
428    (let* ((pname (file-name-nondirectory cmd))    (let* ((pname (file-name-nondirectory cmd))
          (bname (format "*%s*" pname))  
429           (args (if (equal arg "") () (sml-args-to-list arg))))           (args (if (equal arg "") () (sml-args-to-list arg))))
     (if (comint-check-proc bname)  
         (sml-pop-to-buffer t)           ;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))  
430        ;; and this -- to keep these as defaults even if        ;; and this -- to keep these as defaults even if
431        ;; they're set in the mode hooks.        ;; they're set in the mode hooks.
432        (setq sml-program-name cmd)        (setq sml-program-name cmd)
433        (setq sml-default-arg arg))))      (setq sml-default-arg arg)
434        (setq sml-buffer (apply 'make-comint pname cmd nil args))
435    
436        (set-buffer sml-buffer)
437        (message (format "Starting \"%s\" in background." pname))
438        (inferior-sml-mode)
439        (goto-char (point-max))
440        sml-buffer))
441    
442  (defun sml-args-to-list (string)  (defun sml-args-to-list (string)
443    (let ((where (string-match "[ \t]" string)))    (let ((where (string-match "[ \t]" string)))
# Line 570  Line 452 
452                     (sml-args-to-list (substring string pos                     (sml-args-to-list (substring string pos
453                                                  (length string)))))))))                                                  (length string)))))))))
454    
 (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))  
   
455  ;;;###autoload  ;;;###autoload
456  (defun switch-to-sml (eob-p)  (defun switch-to-sml (eob-p)
457    "Switch to the ML process buffer.    "Switch to the ML process buffer.
458  With prefix argument, positions cursor at point, otherwise at end of buffer."  With prefix argument, positions cursor at point, otherwise at end of buffer."
459    (interactive "P")    (interactive "P")
460    (sml-pop-to-buffer t)    (pop-to-buffer (sml-proc-buffer))
461    (cond ((not eob-p)    (cond ((not eob-p)
462           (push-mark (point) t)           (push-mark (point) t)
463           (goto-char (point-max)))))           (goto-char (point-max)))))
# Line 595  Line 469 
469    "Send current region to the inferior ML process.    "Send current region to the inferior ML process.
470  Prefix argument means switch-to-sml afterwards.  Prefix argument means switch-to-sml afterwards.
471    
472  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
473  `sml-use-command' is defined, the region is written out to a temporary file  is sent to the compiler.
474  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'."  
475    (interactive "r\nP")    (interactive "r\nP")
476    (if (sml-noproc) (save-excursion (sml t)))    (if (= start end)
477    (cond ((equal start end)        (message "The region is zero (ignored)")
478           (message "The region is zero (ignored)"))      (let* ((buf (sml-proc-buffer))
479          ((and sml-use-command             (file (buffer-file-name))
480                (numberp sml-temp-threshold)             (marker (copy-marker start))
481                (< sml-temp-threshold (- end start)))             (tmp (make-temp-file "sml")))
482           ;; Just in case someone is still reading from sml-temp-file:        (write-region start end tmp nil 'silently)
483           (if (file-exists-p sml-temp-file)        (with-current-buffer buf
484               (delete-file sml-temp-file))          (when sml-temp-file
485           (write-region start end sml-temp-file nil 'silently)            (ignore-errors (delete-file (car sml-temp-file)))
486           (sml-update-barrier (buffer-file-name (current-buffer)) start)            (set-marker (cdr sml-temp-file) nil))
487           (sml-update-cursor (sml-proc-buffer))          (setq sml-temp-file (cons tmp marker))
488           (comint-send-string (sml-proc)          (sml-send-string (format sml-use-command tmp) nil and-go)))))
                  (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))))  
489    
490  ;; 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.
491  ;; Anyone coming up with an algorithm to recognise fun & local  ;; Anyone coming up with an algorithm to recognise fun & local
# Line 663  Line 501 
501      (sml-send-region (point) (mark)))      (sml-send-region (point) (mark)))
502    (if and-go (switch-to-sml nil)))    (if and-go (switch-to-sml nil)))
503    
504    (defvar sml-source-modes '(sml-mode)
505      "*Used to determine if a buffer contains ML source code.
506    If it's loaded into a buffer that is in one of these major modes, it's
507    considered an ML source file by `sml-load-file'. Used by these commands
508    to determine defaults.")
509    
510  ;;;###autoload  ;;;###autoload
511  (defun sml-send-buffer (&optional and-go)  (defun sml-send-buffer (&optional and-go)
512    "Send buffer to inferior shell running ML process.    "Send buffer to inferior shell running ML process.
# Line 691  Line 535 
535    
536  ;; simplified from frame.el in Emacs: special-display-popup-frame...  ;; simplified from frame.el in Emacs: special-display-popup-frame...
537    
538  ;; Display BUFFER in its own frame, reusing an existing window if any.  ;; (defun sml-proc-frame ()
539  ;; Return the window chosen.  ;;   "Returns the current ML process buffer's frame, or creates one first."
540    ;;   (let ((buffer (sml-proc-buffer)))
541  (defun sml-display-popup-frame (buffer &optional args)  ;;     (window-frame (display-buffer buffer))))
   (let ((window (get-buffer-window buffer t)))  
     (if window  
         ;; If we have a window already, make it visible.  
         (let ((frame (window-frame window)))  
           (make-frame-visible frame)  
           (raise-frame frame)  
           window)  
       ;; otherwise no window yet, make one in a new frame.  
       (let* ((frame (make-frame (append args sml-display-frame-alist)))  
              (window (frame-selected-window frame)))  
         (set-window-buffer window buffer)  
         ;; XEmacs mostly ignores this  
         (set-window-dedicated-p window t)  
         window))))  
   
 (defun sml-proc-frame ()  
   "Returns the current ML process buffer's frame, or creates one first."  
   (let ((buffer (sml-proc-buffer)))  
     (window-frame  
      (or  
       ;; if its already displayed on some frame, take that as default...  
       (get-buffer-window buffer t)  
       ;; ...irrespective of what sml-dedicated-frame says, otherwise  
       ;; create a new frame (or raise an old one) perhaps...  
       (and sml-dedicated-frame  
            (sml-display-popup-frame buffer  
                                     (list (cons 'icon-name buffer)  
                                           '(unsplittable . t))))  
       ;; ...or default to the current frame anyway.  
       (frame-selected-window)))))  
   
 (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))))))  
   
542    
543  ;;; H A C K   A T T A C K !   X E M A C S   V E R S U S   E M A C S  ;;; H A C K   A T T A C K !   X E M A C S   V E R S U S   E M A C S
544    
545  ;; Only these two functions have to dance around the inane differences  ;; Only these two functions have to dance around the inane differences
546  ;; between Emacs and XEmacs (fortunately)  ;; between Emacs and XEmacs (fortunately)
547    
548  (defun sml-warp-mouse (frame)  ;; (defun sml-warp-mouse (frame)
549    "Warp the pointer across the screen to upper right corner of FRAME."  ;;   "Warp the pointer across the screen to upper right corner of FRAME."
550    (raise-frame frame)  ;;   (raise-frame frame)
551    (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)  ;;   (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)
552           ;; LUCID (19.10) or later... set-m-pos needs a WINDOW  ;;          ;; LUCID (19.10) or later... set-m-pos needs a WINDOW
553           (set-mouse-position (frame-root-window frame) (1- (frame-width)) 0))  ;;          (set-mouse-position (frame-root-window frame) (1- (frame-width)) 0))
554          (t  ;;         (t
555           ;; GNU, post circa 19.19... set-m-pos needs a FRAME  ;;          ;; GNU, post circa 19.19... set-m-pos needs a FRAME
556           (set-mouse-position frame (1- (frame-width)) 0)  ;;          (set-mouse-position frame (1- (frame-width)) 0)
557           ;; probably not needed post 19.29  ;;          ;; probably not needed post 19.29
558           (if (fboundp 'unfocus-frame) (unfocus-frame)))))  ;;          (if (fboundp 'unfocus-frame) (unfocus-frame)))))
559    
560  (defun sml-drag-region (event)  (defun sml-drag-region (event)
561    "Highlight the text the mouse is dragged over, and send it to ML.    "Highlight the text the mouse is dragged over, and send it to ML.
# Line 793  Line 593 
593    
594  ;;; LOADING AND IMPORTING SOURCE FILES:  ;;; LOADING AND IMPORTING SOURCE FILES:
595    
596  (defvar sml-source-modes '(sml-mode)  (defvar sml-prev-dir/file nil
   "*Used to determine if a buffer contains ML source code.  
 If it's loaded into a buffer that is in one of these major modes, it's  
 considered an ML source file by `sml-load-file'. Used by these commands  
 to determine defaults.")  
   
 (defvar sml-prev-l/c-dir/file nil  
597    "Caches the (directory . file) pair used in the last `sml-load-file'    "Caches the (directory . file) pair used in the last `sml-load-file'
598  or `sml-cd' command. Used for determining the default in the next one.")  or `sml-cd' command. Used for determining the default in the next one.")
599    
# Line 812  Line 606 
606  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
607  automatically."  automatically."
608    (interactive "P")    (interactive "P")
609    (if (sml-noproc) (save-excursion (sml t)))    (let ((file (car (comint-get-source
610    (if sml-use-command                      "Load ML file: " sml-prev-dir/file sml-source-modes t))))
611        (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))))  
612          ;; Check if buffer needs saved. Should (save-some-buffers) instead?          ;; Check if buffer needs saved. Should (save-some-buffers) instead?
613          (comint-check-source file)          (comint-check-source file)
614          (setq sml-prev-l/c-dir/file        (setq sml-prev-dir/file
615                (cons (file-name-directory file) (file-name-nondirectory file)))                (cons (file-name-directory file) (file-name-nondirectory file)))
616          (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)))  
617    
618  (defun sml-cd (dir)  (defun sml-cd (dir)
619    "Change the working directory of the inferior ML process.    "Change the working directory of the inferior ML process.
# Line 834  Line 622 
622  be executed to change the compiler's working directory\; a trailing  be executed to change the compiler's working directory\; a trailing
623  \"\;\\n\" will be added automatically."  \"\;\\n\" will be added automatically."
624    (interactive "DSML Directory: ")    (interactive "DSML Directory: ")
625    (let* ((buf (sml-proc-buffer))    (let ((dir (expand-file-name dir)))
626           (proc (get-buffer-process buf))      (with-current-buffer (sml-proc-buffer)
627           (dir (expand-file-name dir)))        (sml-send-string (format sml-cd-command dir) t)
628      (save-excursion        (setq default-directory dir))
629        (set-buffer buf)      (setq sml-prev-dir/file (cons dir nil))))
630        (if sml-cd-command  
631            (process-send-string proc  (defun sml-send-string (str &optional print and-go)
632                                 (concat (format sml-cd-command dir) ";\n")))    (let ((proc (sml-proc))
633        (cd dir))          (str (concat str ";\n"))
634      (setq sml-prev-l/c-dir/file (cons dir nil))))          (win (get-buffer-window (current-buffer) 'visible)))
635        (when win (select-window win))
636        (goto-char (point-max))
637        (when print (insert str))
638        (sml-update-cursor)
639        (set-marker (process-mark proc) (point-max))
640        (setq compilation-last-buffer (current-buffer))
641        (comint-send-string proc str)
642        (when and-go (switch-to-sml nil))))
643    
644    (defun sml-compile (command)
645      "re-make a system using (by default) CM.
646       The exact command used can be specified by providing a prefix argument."
647      (interactive
648       ;; code taken straight from compile.el
649       (if (or compilation-read-command current-prefix-arg)
650           (list (read-from-minibuffer "Compile command: "
651                                     sml-compile-command nil nil
652                                     '(compile-history . 1)))
653         (list sml-compile-command)))
654      (setq sml-compile-command command)
655      (save-some-buffers (not compilation-ask-about-save) nil)
656      ;; try to find a makefile up the directory tree
657      (let ((dir (when sml-make-file-name default-directory)))
658        (while (and dir (not (file-exists-p (concat dir sml-make-file-name))))
659          (let ((newdir (file-name-directory (directory-file-name dir))))
660            (setq dir (unless (equal newdir dir) newdir))))
661        (unless dir (setq dir default-directory))
662        (with-current-buffer (sml-proc-buffer)
663          (setq default-directory dir)
664          (sml-send-string (concat (format sml-cd-command dir) "; " command) t t))))
665    
666  ;;; PARSING ERROR MESSAGES  ;;; PARSING ERROR MESSAGES
667    
 ;; to a very large extent "find-file-other-window" works admirably when the  
 ;; compiler is running in a dedicated, *unsplittable* window, and so all  
 ;; the goop in sml-file-other-frame-or-window is of questionable worth.  
 ;; unhappily, XEmacs doesn't (yet, will it ever?) implement the window  
 ;; unsplittable property, hence this nonsense...  
   
 (defun sml-file-other-frame-or-window (file &optional window)  
   "Find or make another frame on which to display FILE.  
 Start in ML interaction buffer, by hypothesis, and try not to use  
 this window to display the file (with bugs in it). FILE may already  
 be on display somewhere, so use that frame by default; otherwise,  
 try to find a window that is displaying an sml buffer; if there is  
 no such frame/window, find the nearest non-dedicated buffer or,  
 in the last resort, create a whole new frame.  
   
 If optional WINDOW is supplied, just use that window to display FILE."  
   (if window  
       (progn                            ; just reuse it  
         (set-window-buffer window (find-file-noselect file))  
         (select-window window))         ; assume "this" frame's selected)  
     (let* ((buf (find-file-noselect file))  
            (win (get-buffer-window buf t))  
            (frm (if win (window-frame win))))  
       (if frm  
           ;; buf is displayed in win on some frame: select frame & window  
           (progn (select-window win) (raise-frame (select-frame frm)))  
         (let* ((frame (selected-frame))   ;current frame & window  
                (window (selected-window)))  
           ;; look through all (but minibuffer) windows for an sml buffer  
           (while (and (not (eq window  
                                (select-window  
                                 (previous-window (selected-window) 'mini t))))  
                       (not (memq major-mode sml-source-modes))))  
           (if (not (eq window (selected-window)))  
               ;; found window displaying an sml buffer: use that window & frame  
               (raise-frame (select-frame (window-frame (selected-window))))  
             ;; otherwise, cycle through frames looking for a spare one  
             ;; select-frame also selects the top (or root) window  
             (while (and (not (eq frame (select-frame (previous-frame  
                                                       (selected-frame) nil))))  
                         (window-dedicated-p (selected-window))))  
             ;; if no suitable frame, create one and (belt & braces) select it  
             (if (eq frame (selected-frame))  
                 ;; sml-dedicated-frame iff window-dedicated-p (selected-window)  
                 (if sml-dedicated-frame  
                     (progn  
                       (sml-warp-mouse (select-frame (make-frame)))  
                       (set-window-buffer  
                        (frame-selected-window (selected-frame)) buf))  
                   (switch-to-buffer-other-window buf))  
               (raise-frame (selected-frame))))  
           (switch-to-buffer buf))))))  
   
668  ;; This should need no modification to support other compilers.  ;; This should need no modification to support other compilers.
669    
670  ;;;###autoload  ;; Update the buffer-local error-cursor in proc-buffer to be its
671  (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)))  
672    
673  (defun sml-bottle (msg)  (defvar sml-endof-error-alist nil)
   "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  
     (sml-pop-to-buffer nil)  
     ;; 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  
           (sml-file-other-frame-or-window file sml-window)  
           ;; 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  
674    
675  (defun sml-skip-errors ()  (defun sml-update-cursor ()
676    "Skip past the rest of the errors."    ;; update buffer local variable
677    (interactive)    (set-marker sml-error-cursor (1- (process-mark (sml-proc))))
678    (if (memq major-mode sml-source-modes) (sml-error-overlay 'undo))    (setq sml-endof-error-alist nil)
679    (sml-update-cursor (sml-proc-buffer))    (compilation-forget-errors)
680    (if (eq major-mode 'sml-inferior-mode) (goto-char (point-max))))    (setq compilation-parsing-end sml-error-cursor))
681    
682  ;;; Set up the inferior mode keymap, using sml-mode bindings...  (defun sml-make-error (f c)
683      (let ((err (point-marker))
684  (cond ((not inferior-sml-mode-map)          (linenum (string-to-number c))
685         (setq inferior-sml-mode-map          (filename (list (first f) (second f)))
686               (copy-keymap comint-mode-map))          (column (string-to-number (compile-buffer-substring (third f)))))
687         (install-sml-keybindings inferior-sml-mode-map)      ;; record the end of error, if any
688         (define-key inferior-sml-mode-map "\C-c\C-s" 'sml)      (when (fourth f)
689         (define-key inferior-sml-mode-map "\t"       'comint-dynamic-complete)))        (let* ((endline (string-to-number (compile-buffer-substring (fourth f))))
690                 (endcol (string-to-number (compile-buffer-substring (fifth f))))
691                 (linediff (- endline linenum)))
692            (push (list err linediff (if (= 0 linediff) (- endcol column) endcol))
693                  sml-endof-error-alist)))
694        ;; build the error descriptor
695        (if (string= (car sml-temp-file) (first f))
696            ;; special case for code sent via sml-send-region
697            (let ((marker (cdr sml-temp-file)))
698              (with-current-buffer (marker-buffer marker)
699                (goto-char marker)
700                (forward-line (1- linenum))
701                (forward-char (1- column))
702                (cons err (point-marker))))
703          ;; taken from compile.el
704          (list err filename linenum column))))
705    
706    (defadvice compilation-goto-locus (after sml-endof-error activate)
707      (let* ((next-error (ad-get-arg 0))
708             (err (car next-error))
709             (pos (cdr next-error))
710             (endof (with-current-buffer (marker-buffer err)
711                      (assq err sml-endof-error-alist))))
712        (if (not endof) (sml-error-overlay 'undo)
713          (with-current-buffer (marker-buffer pos)
714            (goto-char pos)
715            (let ((linediff (second endof))
716                  (coldiff (third endof)))
717              (when (> 0 linediff) (forward-line linediff))
718              (forward-char coldiff))
719            (sml-error-overlay nil pos (point))
720            (push-mark nil t (not sml-error-overlay))
721            (goto-char pos)))))
722    
723    (defun sml-error-overlay (undo &optional beg end)
724      "Move `sml-error-overlay' so it surrounds the text region in the
725    current buffer. If the buffer-local variable `sml-error-overlay' is
726    non-nil it should be an overlay \(or extent, in XEmacs speak\)\; this
727    function moves the overlay over the current region. If the optional
728    BUFFER argument is given, move the overlay in that buffer instead of
729    the current buffer.
730    
731    Called interactively, the optional prefix argument UNDO indicates that
732    the overlay should simply be removed: \\[universal-argument] \
733    \\[sml-error-overlay]."
734      (interactive "P")
735      (when sml-error-overlay
736        (unless (overlayp sml-error-overlay)
737          (let ((ol sml-error-overlay))
738            (setq sml-error-overlay (make-overlay 0 0))
739            (overlay-put sml-error-overlay 'face (if (symbolp ol) ol 'region))))
740        (if undo
741            (move-overlay sml-error-overlay 1 1 (current-buffer))
742          ;; if active regions, signals mark not active if no region set
743          (let ((beg (or beg (region-beginning)))
744                (end (or end (region-end))))
745            (move-overlay sml-error-overlay beg end (current-buffer))))))
746    
747    ;; ;;;###autoload
748    ;; (defun sml-next-error (skip)
749    ;;   "Find the next error by parsing the inferior ML buffer.
750    ;; A prefix argument means `sml-skip-errors' (qv) instead.
751    
752    ;; Move the error message on the top line of the window\; put the cursor
753    ;; \(point\) at the beginning of the error source.
754    
755    ;; If the error message specifies a range, and `sml-error-parser' returns
756    ;; the range, the mark is placed at the end of the range. If the variable
757    ;; `sml-error-overlay' is non-nil, the region will also be highlighted.
758    
759    ;; If `sml-error-parser' returns a fifth component this is assumed to be
760    ;; a string to indicate the nature of the error: this will be echoed in
761    ;; the minibuffer.
762    
763    ;; Error interaction only works if there is a real file associated with
764    ;; the input -- though of course it also depends on the compiler's error
765    ;; messages \(also see documantation for `sml-error-parser'\).
766    
767    ;; However: if the last text sent went via `sml-load-file' (or the temp
768    ;; file mechanism), the next error reported will be relative to the start
769    ;; of the region sent, any error reports in the previous output being
770    ;; forgotten. If the text went directly to the compiler the succeeding
771    ;; error reported will be the next error relative to the location \(in
772    ;; the output\) of the last error. This odd behaviour may have a use...?"
773    ;;   (interactive "P")
774    ;;   (if skip (sml-skip-errors) (sml-do-next-error)))
775    
776    ;; (defun sml-do-next-error ()
777    ;;   "The business end of `sml-next-error' (qv)"
778    ;;   (let ((case-fold-search nil)
779    ;;         ;; set this variable iff we called sml-next-error in a SML buffer
780    ;;         (sml-window (if (memq major-mode sml-source-modes) (selected-window)))
781    ;;         (proc-buffer (sml-proc-buffer)))
782    ;;     ;; undo (don't destroy) the previous overlay to be tidy
783    ;;     (sml-error-overlay 'undo 1 1
784    ;;                        (and sml-error-file (get-file-buffer sml-error-file)))
785    ;;     ;; go to interaction buffer but don't raise it's frame
786    ;;     (pop-to-buffer (sml-proc-buffer))
787    ;;     ;; go to the last remembered error, and search for the next one.
788    ;;     (goto-char sml-error-cursor)
789    ;;     (if (not (re-search-forward sml-error-regexp (point-max) t))
790    ;;         ;; no more errors -- move point to the sml prompt at the end
791    ;;         (progn
792    ;;           (goto-char (point-max))
793    ;;           (if sml-window (select-window sml-window)) ;return there, perhaps
794    ;;           (message "No error message(s) found."))
795    ;;       ;; error found: point is at end of last match; set the cursor posn.
796    ;;       (set-marker sml-error-cursor (point))
797    ;;       ;; move the SML window's text up to this line
798    ;;       (set-window-start (get-buffer-window proc-buffer) (match-beginning 0))
799    ;;       (let* ((pos)
800    ;;              (parse (funcall sml-error-parser (match-beginning 0)))
801    ;;              (file (nth 0 parse))
802    ;;              (line0 (nth 1 parse))
803    ;;              (col0 (nth 2 parse))
804    ;;              (line/col1 (nth 3 parse))
805    ;;              (msg (nth 4 parse)))
806    ;;         ;; Give up immediately if the error report is scribble
807    ;;         (if (or (null file) (null line0))
808    ;;             (error "Failed to parse/locate this error properly!"))
809    ;;         ;; decide what to do depending on the file returned
810    ;;         (when (string= file "std_in")
811    ;;        ;; presently a fundamental limitation i'm afraid.
812    ;;        (error "Sorry, can't locate errors on std_in."))
813    ;;      ;; jump to the beginning
814    ;;      (if (string= file (car sml-temp-file))
815    ;;          (let* ((maker (cdr sml-temp-file))
816    ;;                 (buf (marker-buffer marker)))
817    ;;            (display-buffer buf)
818    ;;            (set-buffer buf)
819    ;;            (goto-char marker))
820    ;;        (unless (file-readable-p file) (error "Can't read %s" file))
821    ;;           ;; instead of (find-file-other-window file) to lookup the file
822    ;;           (find-file-other-window file)
823    ;;           ;; no good if the buffer's narrowed, still...
824    ;;           (goto-char (point-min)))
825    ;;      ;; jump to the error
826    ;;      (forward-line (1- line0))
827    ;;      (forward-char (1- col0))
828    ;;      ;; point is at start of error text; seek the end.
829    ;;      (let ((start (point))
830    ;;            (end (and line/col1
831    ;;                      (condition-case nil
832    ;;                          (progn (eval line/col1) (point))
833    ;;                        (error nil)))))
834    ;;        ;; return to start anyway
835    ;;        (goto-char start)
836    ;;        ;; if point went to end, put mark there, and maybe highlight
837    ;;        (if end (progn (push-mark end t)
838    ;;                       (sml-error-overlay nil start end)))
839    ;;        (setq sml-error-file file)   ; remember this for next time
840    ;;        (if msg (message msg))))))) ; echo the error/warning message
841    
842    ;; (defun sml-skip-errors ()
843    ;;   "Skip past the rest of the errors."
844    ;;   (interactive)
845    ;;   (if (memq major-mode sml-source-modes) (sml-error-overlay 'undo))
846    ;;   (with-current-buffer (sml-proc-buffer) (sml-update-cursor))
847    ;;   (if (eq major-mode 'sml-inferior-mode) (goto-char (point-max))))
848    
849  ;;; 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  ;;; H A C K   A T T A C K !   X E M A C S   /   E M A C S   K E Y S
850    
# Line 1038  Line 861 
861  (run-hooks 'inferior-sml-load-hook)  (run-hooks 'inferior-sml-load-hook)
862    
863  ;;; Here is where sml-proc.el ends  ;;; Here is where sml-proc.el ends
864    (provide 'sml-proc)

Legend:
Removed from v.32  
changed lines
  Added in v.332

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