| 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$ |
| 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 |
|
|
| 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" |
| 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.") |
| 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-make-command "CM.make()" |
(defvar sml-compile-command "CM.make()" |
| 118 |
"The command used by default by `sml-make'.") |
"The command used by default by `sml-make'.") |
| 119 |
|
|
| 120 |
(defvar sml-make-file-name "sources.cm" |
(defvar sml-make-file-name "sources.cm" |
| 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 |
|
|
(concat (file-name-as-directory (or (getenv "TMPDIR") "/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.") |
| 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 |
|
|
| 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 |
| 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 |
;; font-lock support |
;; font-lock support |
| 246 |
(defvar inferior-sml-font-lock-keywords |
(defconst inferior-sml-font-lock-keywords |
| 247 |
`((,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)") |
`(;; prompt and following interactive command |
| 248 |
|
(,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)") |
| 249 |
(1 font-lock-prompt-face) |
(1 font-lock-prompt-face) |
| 250 |
(2 font-lock-command-face keep)) |
(2 font-lock-command-face keep)) |
| 251 |
(,sml-error-regexp . font-lock-warning-face) |
;; CM's messages |
| 252 |
("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face) |
("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face) |
| 253 |
("^GC #.*" . font-lock-comment-face))) |
;; SML/NJ's irritating GC messages |
| 254 |
|
("^GC #.*" . font-lock-comment-face) |
| 255 |
|
;; error messages |
| 256 |
|
,@(mapcar (lambda (ra) (cons (car ra) 'font-lock-warning-face)) |
| 257 |
|
sml-error-regexp-alist)) |
| 258 |
|
"Font-locking specification for inferior SML mode.") |
| 259 |
|
|
| 260 |
;; default faces values |
;; default faces values |
| 261 |
(defvar font-lock-prompt-face |
(defvar font-lock-prompt-face |
| 270 |
(defvar inferior-sml-font-lock-defaults |
(defvar inferior-sml-font-lock-defaults |
| 271 |
'(inferior-sml-font-lock-keywords nil nil nil nil)) |
'(inferior-sml-font-lock-keywords nil nil nil nil)) |
| 272 |
|
|
|
(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))) |
|
|
|
|
|
|
|
| 273 |
;;; CODE |
;;; CODE |
| 274 |
|
|
| 275 |
(defmap inferior-sml-mode-map |
(defmap inferior-sml-mode-map |
| 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 |
| 287 |
|
|
| 288 |
(defun sml-proc-buffer () |
(defun sml-proc-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. |
| 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. |
| 373 |
(sml-mode-variables) |
(sml-mode-variables) |
| 374 |
|
|
| 375 |
;; For sequencing through error messages: |
;; For sequencing through error messages: |
|
|
|
| 376 |
(set (make-local-variable 'sml-error-cursor) (point-max-marker)) |
(set (make-local-variable 'sml-error-cursor) (point-max-marker)) |
| 377 |
(set (make-local-variable 'sml-real-file) nil) |
(set-marker-insertion-type sml-error-cursor nil) |
| 378 |
(set (make-local-variable 'font-lock-defaults) |
(set (make-local-variable 'font-lock-defaults) |
| 379 |
inferior-sml-font-lock-defaults) |
inferior-sml-font-lock-defaults) |
| 380 |
|
|
| 381 |
(make-local-variable 'sml-use-command) |
;; compilation support (used for next-error) |
| 382 |
(make-local-variable 'sml-cd-command) |
(set (make-local-variable 'compilation-error-regexp-alist) |
| 383 |
(make-local-variable 'sml-prompt-regexp) |
sml-error-regexp-alist) |
| 384 |
(make-local-variable 'sml-error-parser) |
(compilation-shell-minor-mode 1) |
| 385 |
(make-local-variable 'sml-error-regexp) |
;; I'm sure people might kill me for that |
| 386 |
|
(setq compilation-error-screen-columns nil) |
| 387 |
|
(make-local-variable 'sml-endof-error-alist) |
| 388 |
|
;;(make-local-variable 'sml-error-overlay) |
| 389 |
|
|
| 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 |
|
|
| 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) |
|
|
(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)) |
|
| 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))) |
| 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") |
|
(if (sml-noproc) (save-excursion (run-sml t))) |
|
| 460 |
(pop-to-buffer (sml-proc-buffer)) |
(pop-to-buffer (sml-proc-buffer)) |
| 461 |
(cond ((not eob-p) |
(cond ((not eob-p) |
| 462 |
(push-mark (point) t) |
(push-mark (point) t) |
| 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 (run-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 |
|
|
;; in the process buffer: |
|
|
|
|
|
(defun sml-update-barrier (&optional 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)))) |
|
|
(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 |
|
|
(set-marker 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 |
| 535 |
|
|
| 536 |
;; simplified from frame.el in Emacs: special-display-popup-frame... |
;; simplified from frame.el in Emacs: special-display-popup-frame... |
| 537 |
|
|
| 538 |
(defun sml-proc-frame () |
;; (defun sml-proc-frame () |
| 539 |
"Returns the current ML process buffer's frame, or creates one first." |
;; "Returns the current ML process buffer's frame, or creates one first." |
| 540 |
(let ((buffer (sml-proc-buffer))) |
;; (let ((buffer (sml-proc-buffer))) |
| 541 |
(window-frame (display-buffer buffer)))) |
;; (window-frame (display-buffer buffer)))) |
| 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. |
| 593 |
|
|
| 594 |
;;; LOADING AND IMPORTING SOURCE FILES: |
;;; LOADING AND IMPORTING SOURCE FILES: |
| 595 |
|
|
| 596 |
(defvar sml-prev-l/c-dir/file nil |
(defvar sml-prev-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 |
|
|
| 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 (run-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. |
| 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 |
(string (concat (format sml-cd-command dir) ";\n"))) |
(setq default-directory dir)) |
| 629 |
(save-excursion |
(setq sml-prev-dir/file (cons dir nil)))) |
| 630 |
(set-buffer buf) |
|
| 631 |
(goto-char (point-max)) |
(defun sml-send-string (str &optional print and-go) |
| 632 |
(insert string) |
(let ((proc (sml-proc)) |
| 633 |
(set-marker (process-mark proc) (point)) |
(str (concat str ";\n")) |
| 634 |
(if sml-cd-command (process-send-string proc string)) |
(win (get-buffer-window (current-buffer) 'visible))) |
|
(cd dir)) |
|
|
(setq sml-prev-l/c-dir/file (cons dir nil)))) |
|
|
|
|
|
(defun sml-send-command (cmd &optional dir print) |
|
|
"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)) |
|
|
(win (get-buffer-window buf 'visible)) |
|
|
(proc (get-buffer-process buf)) |
|
|
(string (concat cd-cmd cmd ";\n"))) |
|
|
(save-some-buffers t) |
|
|
(save-excursion |
|
|
(set-buffer buf) |
|
| 635 |
(when win (select-window win)) |
(when win (select-window win)) |
| 636 |
(goto-char (point-max)) |
(goto-char (point-max)) |
| 637 |
(when print (insert string)) |
(when print (insert str)) |
| 638 |
(when my-dir (cd my-dir)) |
(sml-update-cursor) |
|
(sml-update-cursor buf) |
|
|
(sml-update-barrier) |
|
| 639 |
(set-marker (process-mark proc) (point-max)) |
(set-marker (process-mark proc) (point-max)) |
| 640 |
(comint-send-string proc string)) |
(setq compilation-last-buffer (current-buffer)) |
| 641 |
(switch-to-sml t))) |
(comint-send-string proc str) |
| 642 |
|
(when and-go (switch-to-sml nil)))) |
| 643 |
|
|
| 644 |
(defun sml-make (command) |
(defun sml-compile (command) |
| 645 |
"re-make a system using (by default) CM. |
"re-make a system using (by default) CM. |
| 646 |
The exact command used can be specified by providing a prefix argument." |
The exact command used can be specified by providing a prefix argument." |
| 647 |
(interactive |
(interactive |
| 648 |
;; code taken straight from compile.el |
;; code taken straight from compile.el |
| 649 |
(if (or current-prefix-arg (not sml-make-command)) |
(if (or compilation-read-command current-prefix-arg) |
| 650 |
(list (read-from-minibuffer "Compile command: " |
(list (read-from-minibuffer "Compile command: " |
| 651 |
sml-make-command nil nil |
sml-compile-command nil nil |
| 652 |
'(compile-history . 1))) |
'(compile-history . 1))) |
| 653 |
(list sml-make-command))) |
(list sml-compile-command))) |
| 654 |
(setq sml-make-command command) |
(setq sml-compile-command command) |
| 655 |
;; try to find a makefile up the sirectory tree |
(save-some-buffers (not compilation-ask-about-save) nil) |
| 656 |
(let ((dir (and sml-make-file-name (expand-file-name default-directory)))) |
;; 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)))) |
(while (and dir (not (file-exists-p (concat dir sml-make-file-name)))) |
| 659 |
(let ((newdir (file-name-directory (directory-file-name dir)))) |
(let ((newdir (file-name-directory (directory-file-name dir)))) |
| 660 |
(setq dir (if (equal newdir dir) nil newdir)))) |
(setq dir (unless (equal newdir dir) newdir)))) |
| 661 |
(sml-send-command command dir t))) |
(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 |
|
|
| 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 business 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 (marker-position 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. |
|
|
(set-marker 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 (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 |
|
| 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 |
|
(defun sml-make-error (f c) |
| 683 |
|
(let ((err (point-marker)) |
| 684 |
|
(linenum (string-to-number c)) |
| 685 |
|
(filename (list (first f) (second f))) |
| 686 |
|
(column (string-to-number (compile-buffer-substring (third f))))) |
| 687 |
|
;; record the end of error, if any |
| 688 |
|
(when (fourth f) |
| 689 |
|
(let* ((endline (string-to-number (compile-buffer-substring (fourth f)))) |
| 690 |
|
(endcol (string-to-number (compile-buffer-substring (fifth f)))) |
| 691 |
|
(linediff (- endline linenum))) |
| 692 |
|
(push (list err linediff (if (= 0 linediff) (- endcol column) endcol)) |
| 693 |
|
sml-endof-error-alist))) |
| 694 |
|
;; build the error descriptor |
| 695 |
|
(if (string= (car sml-temp-file) (first f)) |
| 696 |
|
;; special case for code sent via sml-send-region |
| 697 |
|
(let ((marker (cdr sml-temp-file))) |
| 698 |
|
(with-current-buffer (marker-buffer marker) |
| 699 |
|
(goto-char marker) |
| 700 |
|
(forward-line (1- linenum)) |
| 701 |
|
(forward-char (1- column)) |
| 702 |
|
(cons err (point-marker)))) |
| 703 |
|
;; taken from compile.el |
| 704 |
|
(list err filename linenum column)))) |
| 705 |
|
|
| 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 |
|
|
| 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) |
Parent Directory
| 
Revision Log
| 
Patch
