+1999-06-13 Stefan Monnier <monnier@cs.yale.edu>
+
+ * sml-smlnj.el, sml-mosml.el, sml-poly-ml.el: removed.
+
+ * sml-proc.el (...): got rid of sml-next-error by spicing up the interface
+ with compile.el so that intervals can be displayed. `sml-overlay' is
+ kept (and moved from sml-mode to sml-proc where it belongs) but is
+ made redundant in the case of transient-mark-mode.
+
+1999-06-12 Stefan Monnier <monnier@cs.yale.edu>
+
+ * sml-proc.el (sml-prompt-regexp): more general regexp to catch mosml,
+ smlnj as well as polyml prompts.
+ (sml-update-cursor, sml-send-command, inferior-sml-mode): make it work
+ with compile.el's `next-error'.
+ (sml-temp-threshold): dropped: always use a temp file.
+
+1999-06-10 Stefan Monnier <monnier@cs.yale.edu>
+
+ * sml-move.el (sml-op-prec): updated the list of default infix ops based on
+ sml/nj's source files.
+
1999-06-08 Stefan Monnier <monnier@cs.yale.edu>
* sml-proc.el (sml-run): removed dubious code to take care of a supposedly
ELC = $(EMACS) -batch $(ELFLAGS) -f batch-byte-compile
ELFILES = sml-compat.el sml-util.el sml-defs.el sml-move.el sml-mode.el \
- sml-proc.el sml-menus.el sml-mosml.el sml-poly-ml.el sml-smlnj.el
+ sml-proc.el sml-mosml.el sml-poly-ml.el sml-smlnj.el
ELCFILES = $(ELFILES:.el=.elc)
TEXEXTS = *.cps *.fns *.kys *.vr *.tp *.pg *.log *.aux *.toc *.cp *.ky *.fn
in (fk, f, args, loop body)
end
fun foo x = let
- val
+ val
in
-
- let f
- in if 2 then
- ~3
- else
- asdf
- end
-
- (
- if foo then 1 else 2;
- ())
+
+ let f
+ in if 2 then
+ ~3
+ else
+ asdf
+ end
+
+ (
+ if foo then 1 else 2;
+ ())
end
end
| toStringFKind =
orelse vs = (map (F.VAR o #1) args) andalso
not (C.escaping g)
then
- let val g = F.VAR g
- in substitute(f, val2sval g, g)
- end
- handle NotFound =>
- addbind (f, Fun(f, body, args, fk, od))
+ let val g = F.VAR g
+ in substitute(f, val2sval g, g)
+ end
+ handle NotFound =>
+ addbind (f, Fun(f, body, args, fk, od))
else addbind (f, Fun(f, body, args, fk, od))
| (fk,f,args,body) =>
addbind (f, Fun(f, body, args, fk, od)))
- (if 1 then 1 + 2 else
- if
- 1 then
- 1
- + df
+ (if 1 then 1 + 2 else if
+ 1 then
+ 1
+ + df
else
- hell
- de
- der
- +1)
+ hell
+ de
+ der
+ +1)
case
- case a
- of 2 =>
- 1
- + 2
- | =>
+ case a of
+ 2 =>
+ 1
+ + 2
+ | =>
of 1 =>
sd
| =>
(unless (fboundp 'set-keymap-parents)
(defun set-keymap-parents (m parents)
(set-keymap-parent
- m (reduce (lambda (m1 m2)
- (let ((m (copy-keymap m1)))
- (set-keymap-parent m m2) m))
- parents))))
+ m
+ (if (cdr parents)
+ (reduce (lambda (m1 m2)
+ (let ((m (copy-keymap m1)))
+ (set-keymap-parent m m2) m))
+ parents
+ :from-end t)
+ (car parents)))))
;;
(provide 'sml-compat)
("%&$+-/:<=>?@`^|" . "."))
"The syntax table used in sml-mode.")
+(defconst sml-menu
+ '("SML"
+ ("Process"
+ ["Start default ML compiler" sml :active (fboundp 'sml)]
+ ["-" nil nil]
+ ["run CM.make" sml-make :active (featurep 'sml-proc)]
+ ["load ML source file" sml-load-file :active (featurep 'sml-proc)]
+ ["switch to ML buffer" switch-to-sml :active (featurep 'sml-proc)]
+ ["--" nil nil]
+ ["send buffer contents" sml-send-buffer :active (featurep 'sml-proc)]
+ ["send region" sml-send-region :active (featurep 'sml-proc)]
+ ["send paragraph" sml-send-function :active (featurep 'sml-proc)]
+ ["goto next error" sml-next-error :active (featurep 'sml-proc)]
+ ["---" nil nil]
+ ["Standard ML of New Jersey" sml-smlnj :active (fboundp 'sml-smlnj)]
+ ["Poly/ML" sml-poly-ml :active (fboundp 'sml-poly-ml)]
+ ["Moscow ML" sml-mosml :active (fboundp 'sml-mosml)]
+ ["Help for Inferior ML" (describe-function 'inferior-sml-mode) :active (featurep 'sml-proc)])
+ ["electric pipe" sml-electric-pipe t]
+ ["insert SML form" sml-insert-form t]
+ ("Forms"
+ ["abstype" sml-form-abstype t]
+ ["datatype" sml-form-datatype t]
+ ["-" nil nil]
+ ["let" sml-form-let t]
+ ["local" sml-form-local t]
+ ["case" sml-form-case t]
+ ["--" nil nil]
+ ["signature" sml-form-signature t]
+ ["functor" sml-form-functor t]
+ ["structure" sml-form-structure t])
+ ("Format/Mode Variables"
+ ["indent region" sml-indent-region t]
+ ["outdent" sml-back-to-outer-indent t]
+ ["-" nil nil]
+ ["set indent-level" sml-indent-level t]
+ ["set pipe-indent" sml-pipe-indent t]
+ ["--" nil nil]
+ ["toggle type-of-indent" (sml-type-of-indent) t]
+ ["toggle nested-if-indent" (sml-nested-if-indent) t]
+ ["toggle case-indent" (sml-case-indent) t]
+ ["toggle electric-semi-mode" (sml-electric-semi-mode) t])
+ ["-----" nil nil]
+ ["SML mode help (brief)" describe-mode t]
+ ["SML mode *info*" sml-mode-info t]
+ ["SML mode version" sml-mode-version t]
+ ["-----" nil nil]
+ ["Remove overlay" (sml-error-overlay 'undo) :active (sml-overlay-active-p)]))
+
+(when (ignore-errors (require 'easymenu))
+ (easy-menu-define sml-mode-menu
+ sml-mode-map
+ "Menu used in sml-mode."
+ sml-menu))
+
+;;; Make's sure they appear in the menu bar when sml-mode-map is active.
+;; On the hook for XEmacs only -- see easy-menu-add in auc-menu.el.
+;; (defun sml-mode-menu-bar ()
+;; "Make sure menus appear in the menu bar as well as under mouse 3."
+;; (and (eq major-mode 'sml-mode)
+;; (easy-menu-add sml-mode-menu sml-mode-map)))
+;; (add-hook 'sml-mode-hook 'sml-mode-menu-bar)
+
;;
;; regexps
;;
(cons "\\<local\\>" '(sml-indent-level 0))
(cons "\\<of\\>" '(3 nil))
(cons "\\<else\\>" '(sml-indent-level 0))
- (cons "\\<in\\>" '(sml-indent-level nil))
- (cons (sml-syms-re "abstype" "and" "case" "of" "datatype"
- "fun" "if" "then" "else" "sharing" "infix" "infixr"
- "let" "in" "local" "nonfix" "open" "raise" "sig"
+ (cons "\\<in\\|fun\\|and\\>" '(sml-indent-level nil))
+ (cons (sml-syms-re "abstype" "case" "datatype"
+ "if" "then" "else" "sharing" "infix" "infixr"
+ "let" "local" "nonfix" "open" "raise" "sig"
"struct" "type" "val" "while" "do" "with" "withtype")
'sml-indent-level))
"")
+++ /dev/null
-;;; sml-menus.el. Simple menus for sml-mode
-
-;; Copyright (C) 1994, Matthew J. Morley
-
-;; This file is not part of GNU Emacs, but it is distributed under the
-;; same conditions.
-
-;; ====================================================================
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or (at
-;; your option) any later version.
-
-;; This program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;; ====================================================================
-
-;;; DESCRIPTION
-
-;; You need auc-menu or easymenu on your lisp load-path.
-
-;; Menus appear only when the cursor is in an sml-mode buffer. They
-;; should appear automatically as long as sml-mode can find this file
-;; and easymenu.el (or auc-menu.el), but not otherwise.
-
-;; If you load sml-proc.el to run an inferior ML process -- or even a
-;; superior one, who knows? -- the "Process" submenu will become active.
-
-;;; CODE
-
-(condition-case () (require 'easymenu) (error (require 'auc-menu)))
-
-;; That's FSF easymenu, distributed with GNU Emacs 19, or Per
-;; Abrahamsen's auc-menu distributed with AUCTeX, or from the Emacs
-;; lisp archive, or the IESD (ftp://sunsite.auc.dk/packages/auctex/)
-;; lisp archive at Aalborg (auc-menu works with XEmacs too).
-
-(defconst sml-menu
- (list ;"SML"
- (list "Process"
- ["Start default ML compiler" sml
- :active (fboundp 'sml)]
- ["-" nil nil]
- ["run CM.make" sml-make
- :active (and (featurep 'sml-proc))]
- ["load ML source file" sml-load-file
- :active (featurep 'sml-proc)]
- ["switch to ML buffer" switch-to-sml
- :active (featurep 'sml-proc)]
- ["--" nil nil]
- ["send buffer contents" sml-send-buffer
- :active (featurep 'sml-proc)]
- ["send region" sml-send-region
- :active (featurep 'sml-proc)]
- ["send paragraph" sml-send-function
- :active (featurep 'sml-proc)]
- ["goto next error" sml-next-error
- :active (featurep 'sml-proc)]
- ["---" nil nil]
- ["Standard ML of New Jersey" sml-smlnj
- :active (fboundp 'sml-smlnj)]
- ["Poly/ML" sml-poly-ml
- :active (fboundp 'sml-poly-ml)]
- ["Moscow ML" sml-mosml
- :active (fboundp 'sml-mosml)]
- ["Help for Inferior ML" (describe-function 'inferior-sml-mode)
- :active (featurep 'sml-proc)]
- )
- ["electric pipe" sml-electric-pipe t]
- ["insert SML form" sml-insert-form t]
- (list "Forms"
- ["abstype" sml-form-abstype t]
- ["datatype" sml-form-datatype t]
- ["-" nil nil]
- ["let" sml-form-let t]
- ["local" sml-form-local t]
- ["case" sml-form-case t]
- ["--" nil nil]
- ["signature" sml-form-signature t]
- ["functor" sml-form-functor t]
- ["structure" sml-form-structure t])
- (list "Format/Mode Variables"
- ["indent region" sml-indent-region t]
- ["outdent" sml-back-to-outer-indent t]
- ["-" nil nil]
- ["set indent-level" sml-indent-level t]
- ["set pipe-indent" sml-pipe-indent t]
- ["--" nil nil]
- ["toggle type-of-indent" (sml-type-of-indent) t]
- ["toggle nested-if-indent" (sml-nested-if-indent) t]
- ["toggle case-indent" (sml-case-indent) t]
- ["toggle electric-semi-mode" (sml-electric-semi-mode) t])
- ["-----" nil nil]
- ["SML mode help (brief)" describe-mode t]
- ["SML mode *info*" sml-mode-info t]
- ["SML mode version" sml-mode-version t]
- ["-----" nil nil]
- ["Fontify buffer" (sml-mode-fontify-buffer)
- :active (or (featurep 'sml-font) (featurep 'sml-hilite))]
- ["Remove overlay" (sml-error-overlay 'undo)
- :active (sml-overlay-active-p)]
- ))
-
-(defun sml-mode-fontify-buffer ()
- "Just as it suggests."
- (cond ((featurep 'sml-font)
- (font-lock-fontify-buffer))
- ((featurep 'sml-hilite)
- (hilit-rehighlight-buffer))
- (t
- (message "No highlight scheme specified")))) ; belt & braces
-
-(easy-menu-define sml-mode-menu
- sml-mode-map
- "Menu used in sml-mode."
- (cons "SML" sml-menu))
-
-;;; Make's sure they appear in the menu bar when sml-mode-map is active.
-
-;; On the hook for XEmacs only -- see easy-menu-add in auc-menu.el.
-
-(defun sml-mode-menu-bar ()
- "Make sure menus appear in the menu bar as well as under mouse 3."
- (and (eq major-mode 'sml-mode)
- (easy-menu-add sml-mode-menu sml-mode-map)))
-
-(add-hook 'sml-mode-hook 'sml-mode-menu-bar)
-
-;; Autoload all the process code if these are selected.
-
-(autoload 'sml "sml-proc" sml-no-doc t)
-
-;; Not these two.
-;; (autoload 'sml-poly-ml "sml-poly-ml" sml-no-doc t)
-;; (autoload 'sml-mosml "sml-mosml" sml-no-doc t)
-
-(provide 'sml-menus)
-
-;;; sml-menu.el is over now.
;;; VERSION STRING
-(defconst sml-mode-version-string
- "sml-mode, version 3.3")
+(defconst sml-mode-version-string "sml-mode, version 3.9.1")
(require 'cl)
(require 'sml-util)
(defvar sml-pipe-indent -2
"*Extra (usually negative) indentation for lines beginning with `|'.")
-(defvar sml-indent-case-arm 0
- "*Indentation of case arms.")
-
(defvar sml-indent-case-of 2
"*Indentation of an `of'Â on its own line.")
-(defvar sml-indent-equal -2
- "*Extra (usually negative) indenting for lines beginning with `='.")
-
-(defvar sml-indent-fn -3
- "*Extra (usually negative) indenting for lines beginning with `fn'.")
-
-;;(defvar sml-indent-paren -1
-;; "*Extra (usually negative) indenting for lines beginning with `('.")
-
(defvar sml-indent-args 4
"*Indentation of args placed on a separate line.")
The first seems to be the standard in SML/NJ, but the second
seems nicer...")
-(defvar sml-nested-if-indent nil
- "*Determine how nested if-then-else will be formatted:
- If t: if exp1 then exp2 If nil: if exp1 then exp2
- else if exp3 then exp4 else if exp3 then exp4
- else if exp5 then exp6 else if exp5 then exp6
- else exp7 else exp7")
-
-(defvar sml-type-of-indent nil
- "*How to indent `let' `struct' etc.
- If t: fun foo bar = let If nil: fun foo bar = let
- val p = 4 val p = 4
- in in
- bar + p bar + p
- end end
-
-Will not have any effect if the starting keyword is first on the line.")
-
(defvar sml-electric-semi-mode nil
"*If t, `\;' will self insert, reindent the line, and do a newline.
If nil, just insert a `\;'. (To insert while t, do: C-q \;).")
-(defvar sml-paren-lookback 1000
- "*How far back (in chars) the indentation algorithm should look
-for open parenthesis. High value means slow indentation algorithm. A
-value of 1000 (being the equivalent of 20-30 lines) should suffice
-most uses. (A value of nil, means do not look at all)")
-
;;; OTHER GENERIC MODE VARIABLES
(defvar sml-mode-info "sml-mode"
(defvar sml-mode-abbrev-table nil "*SML mode abbrev table (default nil)")
-(defvar sml-error-overlay t
- "*Non-nil means use an overlay to highlight errorful code in the buffer.
-
-This gets set when `sml-mode' is invoked\; if you don't like/want SML
-source errors to be highlighted in this way, do something like
-
- \(setq-default sml-error-overlay nil\)
-
-in your `sml-load-hook', say.")
-
-(make-variable-buffer-local 'sml-error-overlay)
-
;;; CODE FOR SML-MODE
(defun sml-mode-info ()
"This function is part of sml-proc, and has not yet been loaded.
Full documentation will be available after autoloading the function."))
- (autoload 'run-sml "sml-proc" sml-no-doc t)
- (autoload 'sml-make "sml-proc" sml-no-doc t)
- (autoload 'sml-load-file "sml-proc" sml-no-doc t)
-
- (autoload 'switch-to-sml "sml-proc" sml-no-doc t)
- (autoload 'sml-send-region "sml-proc" sml-no-doc t)
- (autoload 'sml-send-buffer "sml-proc" sml-no-doc t)
- (autoload 'sml-next-error "sml-proc" sml-no-doc t))
+ (autoload 'run-sml "sml-proc" sml-no-doc t)
+ (autoload 'sml-compile "sml-proc" sml-no-doc t)
+ (autoload 'sml-load-file "sml-proc" sml-no-doc t)
+ (autoload 'switch-to-sml "sml-proc" sml-no-doc t)
+ (autoload 'sml-send-region "sml-proc" sml-no-doc t)
+ (autoload 'sml-send-buffer "sml-proc" sml-no-doc t))
;; font-lock setup
(modify-syntax-entry ?l "(d" st)
(modify-syntax-entry ?s "(d" st)
(modify-syntax-entry ?d ")l" st)
+ (modify-syntax-entry ?\\ "." st)
(modify-syntax-entry ?* "." st)
st))
`(;;("\\<\\(l\\)\\(et\\|ocal\\)\\>" (1 ',sml-syntax-prop-table))
;;("\\<\\(s\\)\\(ig\\truct\\)\\>" (1 ',sml-syntax-prop-table))
;;("\\<en\\(d\\)\\>" (1 ',sml-syntax-prop-table))
+ ("^\\s-*\\(\\\\\\)" (1 ',sml-syntax-prop-table))
("(?\\(\\*\\))?" (1 (sml-get-depth-st)))))
(defconst sml-font-lock-defaults
'(sml-font-lock-keywords nil nil ((?_ . "w") (?' . "w")) nil
(font-lock-syntactic-keywords . sml-font-lock-syntactic-keywords)))
-;; code to get comment fontification working in the face of recursive
-;; comments. It's lots more work than it should be. -- stefan
-;; (defvar sml-font-cache '((0 . normal))
-;; "List of (POSITION . STATE) pairs for an SML buffer.
-;; The STATE is either `normal', `comment', or `string'. The POSITION is
-;; immediately after the token that caused the state change.")
-;; (make-variable-buffer-local 'sml-font-cache)
-
-;; (defun sml-font-comments-and-strings (limit)
-;; "Fontify SML comments and strings up to LIMIT.
-;; Handles nested comments and SML's escapes for breaking a string over lines.
-;; Uses sml-font-cache to maintain the fontification state over the buffer."
-;; (let ((beg (point))
-;; last class)
-;; (while (< beg limit)
-;; (while (and sml-font-cache
-;; (> (caar sml-font-cache) beg))
-;; (pop sml-font-cache))
-;; (setq last (caar sml-font-cache))
-;; (setq class (cdar sml-font-cache))
-;; (goto-char last)
-;; (cond
-;; ((eq class 'normal)
-;; (cond
-;; ((not (re-search-forward "\\((\\*\\)\\|\\(\"\\)" limit t))
-;; (goto-char limit))
-;; ((match-beginning 1)
-;; (push (cons (point) 'comment) sml-font-cache))
-;; ((match-beginning 2)
-;; (push (cons (point) 'string) sml-font-cache))))
-;; ((eq class 'comment)
-;; (cond
-;; ((let ((nest 1))
-;; (while (and (> nest 0)
-;; (re-search-forward "\\((\\*\\)\\|\\(\\*)\\)" limit t))
-;; (cond
-;; ((match-beginning 1) (incf nest))
-;; ((match-beginning 2) (decf nest))))
-;; (> nest 0))
-;; (goto-char limit))
-;; (t
-;; (push (cons (point) 'normal) sml-font-cache)))
-;; (put-text-property (- last 2) (point) 'face 'font-lock-comment-face))
-;; ((eq class 'string)
-;; (while (and (re-search-forward
-;; "\\(\"\\)\\|\\(\\\\\\s-*\\\\\\)\\|\\(\\\\\"\\)" limit t)
-;; (not (match-beginning 1))))
-;; (cond
-;; ((match-beginning 1)
-;; (push (cons (point) 'normal) sml-font-cache))
-;; (t
-;; (goto-char limit)))
-;; (put-text-property (- last 1) (point) 'face 'font-lock-string-face)))
-;; (setq beg (point)))))
-
-;;; 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
-
-;; (cond ((fboundp 'make-extent)
-;; ;; suppose this is XEmacs
-
-;; (defun sml-make-overlay ()
-;; "Create a new text overlay (extent) for the SML buffer."
-;; (let ((ex (make-extent 1 1)))
-;; (set-extent-property ex 'face 'zmacs-region) ex))
-
-;; (defalias 'sml-is-overlay 'extentp)
-
-;; (defun sml-overlay-active-p ()
-;; "Determine whether the current buffer's error overlay is visible."
-;; (and (sml-is-overlay sml-error-overlay)
-;; (not (zerop (extent-length sml-error-overlay)))))
-
-;; (defalias 'sml-move-overlay 'set-extent-endpoints))
-
-;; ((fboundp 'make-overlay)
- ;; otherwise assume it's Emacs
-
- (defun sml-make-overlay ()
- "Create a new text overlay (extent) for the SML buffer."
- (let ((ex (make-overlay 0 0)))
- (overlay-put ex 'face 'region) ex))
-
- (defalias 'sml-is-overlay 'overlayp)
-
- (defun sml-overlay-active-p ()
- "Determine whether the current buffer's error overlay is visible."
- (and (sml-is-overlay sml-error-overlay)
- (not (equal (overlay-start sml-error-overlay)
- (overlay-end sml-error-overlay)))))
-
- (defalias 'sml-move-overlay 'move-overlay);;)
-;; (t
-;; ;; what *is* this!?
-;; (defalias 'sml-is-overlay 'ignore)
-;; (defalias 'sml-overlay-active-p 'ignore)
-;; (defalias 'sml-make-overlay 'ignore)
-;; (defalias 'sml-move-overlay 'ignore)))
;;; MORE CODE FOR SML-MODE
sml-case-indent (default nil)
Determine the way to indent case-of expression.
-sml-nested-if-indent (default nil)
- Determine how nested if-then-else expressions are formatted.
-
-sml-type-of-indent (default nil)
- How to indent let, struct, local, etc.
- Will not have any effect if the starting keyword is first on the line.
-
sml-electric-semi-mode (default nil)
If t, a `\;' will reindent line, and perform a newline.
-sml-paren-lookback (default 1000)
- Determines how far back (in chars) the indentation algorithm should
- look to match parenthesis. A value of nil, means do not look at all.
-
Mode map
========
\\{sml-mode-map}"
(set (make-local-variable 'comment-column) 40)
(set (make-local-variable 'comment-start-skip) "(\\*+[ \t]?")
(set (make-local-variable 'comment-indent-function) 'sml-comment-indent)
- (set (make-local-variable 'font-lock-defaults) sml-font-lock-defaults)
- ;;(set (make-local-variable 'parse-sexp-lookup-properties) t)
- ;;(set (make-local-variable 'parse-sexp-ignore-comments) t)
- (setq sml-error-overlay (and sml-error-overlay (sml-make-overlay))))
-
-(defun sml-error-overlay (undo &optional beg end buffer)
- "Move `sml-error-overlay' so it surrounds the text region in the
-current buffer. If the buffer-local variable `sml-error-overlay' is
-non-nil it should be an overlay \(or extent, in XEmacs speak\)\; this
-function moves the overlay over the current region. If the optional
-BUFFER argument is given, move the overlay in that buffer instead of
-the current buffer.
-
-Called interactively, the optional prefix argument UNDO indicates that
-the overlay should simply be removed: \\[universal-argument] \
-\\[sml-error-overlay]."
- (interactive "P")
- (save-excursion
- (set-buffer (or buffer (current-buffer)))
- (if (sml-is-overlay sml-error-overlay)
- (if undo
- (sml-move-overlay sml-error-overlay 1 1)
- ;; if active regions, signals mark not active if no region set
- (let ((beg (or beg (region-beginning)))
- (end (or end (region-end))))
- (sml-move-overlay sml-error-overlay beg end))))))
+ (set (make-local-variable 'font-lock-defaults) sml-font-lock-defaults))
(defun sml-electric-pipe ()
"Insert a \"|\".
(looking-at "[\t ]*\\\\"))
(progn (previous-line 1) (current-indentation))
(if (re-search-backward "[^\\\\]\"" nil t)
- (1+ (current-indentation))
+ (1+ (current-column))
0))))
(and (looking-at "in\\>") ; Match the beginning let/local
(and (looking-at "else\\>") ; Match the if
(progn
(sml-find-match-backward "\\<else\\>" "\\<if\\>")
- (sml-move-if (backward-word 1)
- (and sml-nested-if-indent
- (looking-at "else[ \t]+if\\>")))
- (current-column)))
+ ;;(sml-move-if (backward-word 1)
+ ;; (and sml-nested-if-indent
+ ;; (looking-at "else[ \t]+if\\>")))
+ (if (sml-dangling-sym)
+ (sml-indent-default 'noindent)
+ (current-column))))
(and (looking-at "then\\>") ; Match the if + extra indentation
(sml-find-match-indent "\\<then\\>" "\\<if\\>" t))
(sml-indent-arg)
(sml-indent-default))))))
-;; (let ((indent (current-column)))
-;; ;;(skip-chars-forward "\t (")
-;; (cond
-;; ;; a "let fun" or "let val"
-;; ((looking-at "let \\(fun\\|val\\)\\>")
-;; (+ (current-column) 4 sml-indent-level))
-;; ;; Started val/fun/structure...
-;; ;; Indent after "=>" pattern, but only if its not an fn _ =>
-;; ;; (890726)
-;; ((looking-at ".*=>")
-;; (if (looking-at ".*\\<fn\\>.*=>")
-;; indent
-;; (+ indent sml-indent-case-arm)))
-;; ;; else keep the same indentation as previous line
-;; (t indent)))))))))
-
-
- ;;(and (setq indent (sml-get-indent)) nil)
-
- ;;(and (looking-at "=[^>]") (+ indent sml-indent-equal))
- ;;(and (looking-at "fn\\>") (+ indent sml-indent-fn))
- ;; (and (looking-at "(") (+ indent sml-indent-paren))
-
- ;;(and sml-paren-lookback ; Look for open parenthesis ?
- ;; (max indent (sml-get-paren-indent)))
- ;;indent)))))
-
(defun sml-indent-pipe ()
(when (sml-find-matching-starter (concat "|\\|\\<of\\>\\|" sml-pipehead-re)
(sml-op-prec "|" 'back))
(when sym
(cdr (assoc* sym al
:test (lambda (x y) (string-match y x))))))
+
(defun sml-get-indent (data n &optional strict)
(eval (if (listp data)
(nth n data)
(sml-forward-spaces))))))
(defun sml-get-sym-indent (sym &optional style)
- "expects to be looking-at SYM."
+ "expects to be looking-at SYM.
+If indentation is delegated, the point will be at the start of
+the parent at the end of this function."
(let ((indent-data (sml-re-assoc sml-indent-starters sym))
(delegate (eval (sml-re-assoc sml-delegate sym))))
(or (when indent-data
(let* ((parent-sym (save-excursion (sml-move-read (sml-forward-sym))))
(parent-indent (sml-re-assoc sml-indent-starters parent-sym)))
;; check the special rules
- (sml-move-if (backward-word 1)
- (looking-at "\\<else[ \t]+if\\>"))
+ ;;(sml-move-if (backward-word 1)
+ ;; (looking-at "\\<else[ \t]+if\\>"))
(+ (if (sml-dangling-sym)
(sml-indent-default 'noindent)
(current-column))
(_ (sml-backward-spaces))
(sym-before (sml-move-read (sml-backward-sym)))
(prec (or (sml-op-prec sym-before 'back) prec-after 100))
- sexp)
- (or (and sym-before (sml-get-sym-indent sym-before))
+ (sym-indent (and sym-before (sml-get-sym-indent sym-before))))
+ (or (and sym-indent (if noindent (current-column) sym-indent))
(progn
;;(sml-forward-sym)
(while (and (not (sml-bolp))
(not (sml-bolp)))
(while (sml-move-if (sml-backward-sexp prec))))
(or (and (not (sml-bolp))
- (= prec 65) (string-equal "=" sym-before) ;Yuck!!
+ ;; If we backed over an equal char which was not the
+ ;; polymorphic equality, then we did what amounts to
+ ;; delegate indent from `=' to the corresponding head, so we
+ ;; need to look at the preceding symbol and follow its
+ ;; intentation instructions.
+ (= prec 65) (string-equal "=" sym-before)
(save-excursion
(sml-backward-spaces)
(let* ((sym (sml-move-read (sml-backward-sym)))
(save-excursion
(skip-chars-backward " \t|") (bolp)))
-;; (defun sml-goto-first-subexp ()
-;; (let ((initpoint (point)))
-
-;; (let ((argp (and (looking-at "[[({a-zA-Z0-9_'#~]\\|$")
-;; (not (looking-at (concat "[ \t]*" sml-not-arg-regexp))))))
-;; (while (and argp (not (bobp)))
-;; (let* ((endpoint (point))
-;; (startpoint endpoint))
-;; (setq argp
-;; (ignore-errors
-;; (sml-backward-sexp t)
-;; (setq startpoint (point))
-;; (and (not (looking-at (concat "[[(]\\|" sml-keywords-regexp)))
-;; (progn (sml-forward-sexp)
-;; (sml-skip-spaces)
-;; (>= (point) endpoint)))))
-;; (goto-char (if argp startpoint endpoint))))
-;; (let ((res (point)))
-;; (sml-backward-spaces) (skip-syntax-backward "^ ")
-;; (if (looking-at "*\\|:[^=]\\|->\\|of\\>")
-;; (goto-char initpoint)
-;; (goto-char res)
-;; (sml-skip-spaces))))))
;; maybe `|' should be set to word-syntax in our temp syntax table ?
(defun sml-current-indentation ()
(skip-chars-forward " \t|")
(current-column)))
-;; (defun sml-get-indent ()
-;; (save-excursion
-;; ;;(let ((endpoint (point)))
-
-;; ;; let's try to see whether we are inside an `f a1 a2 ..' expression
-;; ;;(sml-goto-first-subexp)
-;; ;;(setq rover (current-column))
-;; ;;(sml-skip-spaces)
-;; (cond
-;; ;; ((< (point) endpoint)
-;; ;; ;; we're not the first subexp
-;; ;; (sml-forward-sexp)
-;; ;; (if (and sml-indent-align-args
-;; ;; (progn (sml-skip-spaces) (< (point) endpoint)))
-;; ;; ;; we're not the second subexp
-;; ;; (current-column)
-;; ;; (+ rover sml-indent-args)))
-
-;; ;; we're not inside an `f a1 a2 ..' expr
-;; ((progn ;;(goto-char endpoint)
-;; (sml-backward-spaces)
-;; (/= (skip-chars-backward ";,") 0))
-;; (sml-backward-sexps (concat "[[(]\\'\\|" sml-user-begin-symbols-re))
-;; (current-column))
-
-;; (t
-;; (while (/= (current-column) (current-indentation))
-;; (sml-backward-sexp t))
-;; (when (looking-at "\\<of\\>") (forward-word 1))
-;; (skip-chars-forward "\t |")
-;; (let ((indent (current-column)))
-;; ;;(skip-chars-forward "\t (")
-;; (cond
-;; ;; a "let fun" or "let val"
-;; ((looking-at "let \\(fun\\|val\\)\\>")
-;; (+ (current-column) 4 sml-indent-level))
-;; ;; Started val/fun/structure...
-;; ((looking-at sml-indent-starters-reg)
-;; (+ (current-column) sml-indent-level))
-;; ;; Indent after "=>" pattern, but only if its not an fn _ =>
-;; ;; (890726)
-;; ((looking-at ".*=>")
-;; (if (looking-at ".*\\<fn\\>.*=>")
-;; indent
-;; (+ indent sml-indent-case-arm)))
-;; ;; else keep the same indentation as previous line
-;; (t indent)))))))
-
-;; (defun sml-get-paren-indent ()
-;; (save-excursion
-;; (condition-case ()
-;; (progn
-;; (up-list -1)
-;; (if (save-excursion
-;; (forward-char 1)
-;; (looking-at sml-indent-starters-reg))
-;; (1+ (+ (current-column) sml-indent-level))
-;; (1+ (current-column))))
-;; (error 0))))
-
-;; (defun sml-inside-comment-or-string-p ()
-;; (let ((start (point)))
-;; (if (save-excursion
-;; (condition-case ()
-;; (progn
-;; (search-backward "(*")
-;; (search-forward "*)")
-;; (forward-char -1) ; A "*)" is not inside the comment
-;; (> (point) start))
-;; (error nil)))
-;; t
-;; (let ((numb 0))
-;; (save-excursion
-;; (save-restriction
-;; (narrow-to-region (progn (beginning-of-line) (point)) start)
-;; (condition-case ()
-;; (while t
-;; (search-forward "\"")
-;; (setq numb (1+ numb)))
-;; (error (if (and (not (zerop numb))
-;; (not (zerop (% numb 2))))
-;; t nil)))))))))
-
-;; (defun sml-find-match-backward (unquoted-this this match)
-;; (let ((case-fold-search nil)
-;; (level 1)
-;; (pattern (concat this "\\|" match)))
-;; (while (not (zerop level))
-;; (if (sml-re-search-backward pattern)
-;; (setq level (cond
-;; ((looking-at this) (1+ level))
-;; ((looking-at match) (1- level))))
-;; ;; The right match couldn't be found
-;; (error (concat "Unbalanced: " unquoted-this))))))
(defun sml-find-match-indent (this match &optional indented)
(save-excursion
(sml-backward-sexp prec))
(not (bobp)))
-;; (defun sml-re-search-backward (regexpr)
-;; (let ((case-fold-search nil) (found t))
-;; (if (re-search-backward regexpr nil t)
-;; (progn
-;; (condition-case ()
-;; (while (sml-inside-comment-or-string-p)
-;; (re-search-backward regexpr))
-;; (error (setq found nil)))
-;; found)
-;; nil)))
-
(defun sml-comment-indent ()
(if (looking-at "^(\\*") ; Existing comment at beginning
0 ; of line stays there.
(indent-to indent)
(insert "end"))))
-;;; Load the menus, if they can be found on the load-path
-
-(condition-case nil
- (require 'sml-menus)
- (error (message "Sorry, not able to load SML mode menus.")))
-
;;; & do the user's customisation
-
-(add-hook 'sml-load-hook 'sml-mode-version t)
-
(run-hooks 'sml-load-hook)
;;; sml-mode.el has just finished.
+++ /dev/null
-;;; sml-mosml.el: Modifies inferior-sml-mode defaults for Moscow ML.
-
-;; Copyright (C) 1997, Matthew J. Morley
-
-;; $Revision: 1.5 $
-;; $Date: 1997/06/23 09:19:56 $
-
-;; This file is not part of GNU Emacs, but it is distributed under the
-;; same conditions.
-
-;; ====================================================================
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or (at
-;; your option) any later version.
-
-;; This program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;; ====================================================================
-
-;;; DESCRIPTION
-
-;; To use this library just put
-
-;;(autoload 'sml-mosml "sml-mosml" "Set up and run Moscow ML." t)
-
-;; in your .emacs file. If you only ever use Moscow ML then you might
-;; as well put something like
-
-;;(setq sml-mode-hook
-;; '(lambda() "SML mode defaults to Moscow ML"
-;; (define-key sml-mode-map "\C-cp" 'sml-mosml)))
-
-;; for your sml-mode-hook. The command prompts for the program name
-;; and any command line options.
-
-;; If you need to reset the default value of sml-program-name, or any
-;; of the other compiler variables, put something like
-
-;;(eval-after-load "sml-mosml" '(setq sml-program-name "whatever"))
-
-;; in your .emacs -- or you can use the inferior-sml-{load,mode}-hooks
-;; to achieve the same ends.
-
-;;; CODE
-
-(require 'sml-proc)
-
-;; The regular expression used when looking for errors. Moscow ML errors:
-
-(defconst sml-mosml-error-regexp
- (concat "^File \"\\([^\"]+\\)\"," ;1
- " line \\([0-9]+\\)-?\\([0-9]+\\)?," ;2-3?
- " characters \\([0-9]+\\)-\\([0-9]+\\):") ;4-5
- "Default regexp matching Moscow ML error messages.
-If you change this significantly you may also need to redefine
-`sml-mosml-error-parser' (qv).")
-
-;; File "puzz.ml", line 30-31, characters 10-70:
-;; ! ..........first 0 l = []
-;; ! | first n (h::t) = h::(first (n-1) t)
-;; ! Warning: pattern matching is not exhaustive
-
-;; ! Toplevel input:
-;; ditto
-
-(defconst sml-mosml-error-messages
- (concat "^! \\("
- (mapconcat 'identity
- (list "\\(Warning: .*\\)"
- "\\(Type clash\\):"
- "\\(Ill-formed infix expression\\)"
- "\\(Syntax error.*\\)")
- "\\|")
- "\\).*$")
- "RE to match Moscow ML type-of-error reports. This regular expression
-must follow the whole line pattern \"^! \\\\(%s\\\\).*$\", and the %s
-stands for a \"\\\\|\" separated list of regular expressions each of
-which must, I repeat *must*, contain at least one \"\\\\(%s\\\\)\" group.
-The %s regexp in the first such group will be the actual error report
-echoed to the user.")
-
-(defun sml-mosml-error-parser (pt)
- "This function looks for the next Moscow ML error message following PT
-and parses an error message into a 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 START-LINE where the error occurs
-
- END-OF-ERR is an Emacs Lisp expression that when evaluated at
- \(start-line,start-col\) moves point to the end of the errorful text
-
- MSG is the text of the error message given by the compiler, if such text
- can be found.
-
-The first three are mandatory return values for `sml-next-error'.
-See also `sml-error-parser'."
- (save-excursion
- (goto-char pt)
- (if (not (looking-at sml-mosml-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
- ;; char range is (n,m], 0 is column 1 of slin
- (scol (string-to-int (match-string 4))) ; the start col
- ;; get to the end by doing "forward-char m - n"
- (eoe `(forward-char ,(- (string-to-int (match-string 5)) scol)))
- (msg))
- ;; look for the error message at end of the chunk of "! " lines
- (forward-line 1)
- (while (and (looking-at "^! ")
- (not (looking-at sml-mosml-error-messages)))
- (forward-line 1))
- ;; found one if match-beginning 1 is non-nil.
- (if (match-beginning 1)
- (progn
- (setq msg (match-string 1))
- ;; refine since m-begin 1 implies m-begin N for some N>1 as
- ;; long as sml-mosml-error-messages is sane as advertised.
- ;; match-data is a list N+1 of pairs, consecutive elts being
- ;; beg and end markers for the \( \) in the match. 0 is the
- ;; whole match.
- (let ((matches (1- (/ (length (match-data)) 2))) ; ignore 0th
- (group 2)) ; & ignore 1st
- (while (and (not (match-beginning group))
- (<= group matches))
- (setq group (1+ group)))
- (if (<= group matches)
- (setq msg (match-string group))))))
- ;; 1+ scol because char 0 means column 1 of slin.
- (nconc (list file slin (1+ scol)) (list eoe) (list msg))))))
-
-;;;###autoload
-(defun sml-mosml (pfx)
- "Set up and run Moscow ML.
-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 \"mosml\"\)
- sml-default-arg <option> \(default \"\"\)
- sml-use-command \"use \\\"%s\\\"\"
- sml-cd-command \"load \"FileSys\"; FileSys.chDir \\\"%s\\\"\"
- sml-prompt-regexp \"^- *\"
- sml-error-regexp sml-mosml-error-regexp
- sml-error-parser 'sml-mosml-error-parser"
- (interactive "P")
- (let ((cmd (if pfx "mosml"
- (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 "load \"FileSys\"; FileSys.chDir \"%s\""
- sml-prompt-regexp "^- *"
- sml-error-regexp sml-mosml-error-regexp
- sml-error-parser 'sml-mosml-error-parser)
- (sml-run cmd sml-default-arg)))
-
-;;; Do the default setup on loading this file.
-
-;; setqing these two may override user's hooked defaults. users
-;; therefore need load this file before setting sml-program-name or
-;; sml-default-arg in their inferior-sml-load-hook. sorry.
-
-(setq sml-program-name "mosml"
- sml-default-arg "")
-
-;; same sort of problem here too: users should to setq-default these
-;; after this file is loaded, on inferior-sml-load-hook. as these are
-;; buffer-local, users can instead set them on inferior-sml-mode-hook.
-
-(setq-default sml-use-command "use \"%s\""
- sml-cd-command "load \"FileSys\"; FileSys.chDir \"%s\""
- sml-prompt-regexp "^- *"
- sml-error-regexp sml-mosml-error-regexp
- sml-error-parser 'sml-mosml-error-parser)
-
-;;; sml-mosml.el endeded
"Syntax table used for internal sml-mode operation."
:copy sml-mode-syntax-table)
+;;;
+;;; various macros
+;;;
+
+(defmacro sml-with-ist (&rest r)
+ (let ((ost-sym (make-symbol "oldtable")))
+ `(let ((,ost-sym (syntax-table))
+ (case-fold-search nil))
+ (unwind-protect
+ (progn (set-syntax-table sml-internal-syntax-table) . ,r)
+ (set-syntax-table ,ost-sym)))))
+(def-edebug-spec sml-with-ist t)
+
+(defmacro sml-move-if (f &optional c)
+ (let ((pt-sym (make-symbol "point"))
+ (res-sym (make-symbol "result")))
+ `(let* ((,pt-sym (point))
+ (,res-sym ,f))
+ (or ,(or c res-sym) (progn (goto-char ,pt-sym) nil)))))
+(def-edebug-spec sml-move-if t)
+
+(defmacro sml-move-read (&rest body)
+ (let ((pt-sym (make-symbol "point")))
+ `(let ((,pt-sym (point)))
+ ,@body
+ (when (/= (point) ,pt-sym)
+ (buffer-substring (point) ,pt-sym)))))
+(def-edebug-spec sml-move-read t)
+
+(defmacro sml-point-after (&rest body)
+ `(save-excursion
+ ,@body
+ (point)))
+(def-edebug-spec sml-point-after t)
+
+;;
+
(defun sml-op-prec (op dir)
"return the precedence of OP or nil if it's not an infix.
DIR should be set to BACK if you want to precedence w.r.t the left side
(cond
((not op) nil)
;;((or (string-match (sml-syms-re (appen
- ((or (string-equal ";" op) (string-equal "," op)) 10)
- ((or (string-equal "=>" op)
- (and (string-equal "=" op)
+ ((or (string= ";" op) (string= "," op)) 10)
+ ((or (string= "=>" op)
+ (and (string= "=" op)
;; not the polymorphic equlity
(> (sml-point-after (re-search-backward sml-=-starter-re nil 'top))
(sml-point-after (re-search-backward "=" nil 'top)))))
;; depending on the direction
(if (eq dir 'back) 65 40))
((or (string-match (sml-syms-re "case" "of" "fn") op)) 45)
- ((or (string-equal "|" op)) (if (eq dir 'back) 47 30))
+ ((or (string= "|" op)) (if (eq dir 'back) 47 30))
((or (string-match (sml-syms-re "if" "then" "else" "while" "do" "raise") op)) 50)
- ((or (string-equal "handle" op)) 60)
- ((or (string-equal "orelse" op)) 70)
- ((or (string-equal "andalso" op)) 80)
- ((or (string-equal ":" op) (string-equal ":>" op)) 90)
- ((or (string-equal "->" op)) 95)
+ ((or (string= "handle" op)) 60)
+ ((or (string= "orelse" op)) 70)
+ ((or (string= "andalso" op)) 80)
+ ((or (string= ":" op) (string= ":>" op)) 90)
+ ((or (string= "->" op)) 95)
;; standard infix ops: 10*(10 + prec) as defined in `the definition of SML'
- ((or (string-equal "!" op)) nil)
- ((or (string-equal "~" op)) nil)
- ((or (string-equal ":=" op)) 130)
- ((or (string-match "\\`[<>]?=?\\'" op)) 140)
- ((or (string-equal "::" op)) 150)
- ((or (string-equal "+" op) (string-equal "-" op)) 160)
- ((or (string-equal "/" op) (string-equal "*" op)
- (string-equal "div" op) (string-equal "mod" op)) 170)
+ ;;((or (string= "!" op)) nil)
+ ;;((or (string= "~" op)) nil)
+ ((or (string= "before" op)) 100)
+ ((or (string= ":=" op) (string= "o" op)) 130)
+ ((or (string= ">" op) (string= ">=" op) (string= "<>" op)
+ (string= "<" op) (string= "<=" op) (string= "=" op)) 140)
+ ((or (string= "::" op) (string= "@" op)) 150)
+ ((or (string= "+" op) (string= "-" op) (string= "^" op)) 160)
+ ((or (string= "/" op) (string= "*" op)
+ (string= "quot" op) (string= "rem" op)
+ (string= "div" op) (string= "mod" op)) 170)
;; default heuristic: alphanum symbols are not infix
- ((or (string-match "\\sw" op)) nil)
- (t 100)))
-
-
-(defmacro sml-with-ist (&rest r)
- `(let ((sml-ost (syntax-table))
- (case-fold-search nil))
- (unwind-protect
- (progn (set-syntax-table sml-internal-syntax-table) . ,r)
- (set-syntax-table sml-ost))))
-(def-edebug-spec sml-with-ist t)
-
-(defmacro sml-move-if (f &optional c)
- `(let* ((-sml-move-if-pt (point))
- (-sml-move-if-res ,f))
- (or ,(or c '-sml-move-if-res) (progn (goto-char -sml-move-if-pt) nil))))
-(def-edebug-spec sml-move-if t)
-
-(defmacro sml-move-read (&rest body)
- `(let ((-sml-move-read-pt (point)))
- ,@body
- (when (/= (point) -sml-move-read-pt)
- (buffer-substring (point) -sml-move-read-pt))))
-(def-edebug-spec sml-move-read t)
-
-(defmacro sml-point-after (&rest body)
- `(save-excursion
- ,@body
- (point)))
-(def-edebug-spec sml-point-after t)
+ ;;((or (string-match "\\sw" op)) nil)
+ ;;(t 100)
+ (t nil)
+ ))
;;
(t (error "Unbalanced")))))
t))
-;; (defun sml-forward-sexp (&optional count strict)
-;; "Moves one sexp forward if possible, or one char else.
-;; Returns T if the move indeed moved through one sexp and NIL if not."
-;; (let ((parse-sexp-lookup-properties t)
-;; (parse-sexp-ignore-comments t))
-;; (condition-case ()
-;; (progn
-;; (forward-sexp 1)
-;; (cond
-;; ((sml-looking-back-at
-;; (if strict sml-begin-symbols-re sml-user-begin-symbols-re))
-;; (sml-find-match-forward sml-begin-symbols-re "\\<end\\>") t)
-;; ((sml-looking-back-at "\\<end\\>") nil)
-;; (t t)))
-;; (error (forward-char 1) nil))))
-
-;; the terminators should be chosen more carefully:
-;; `let' isn't one while `=' may be
-;; (defun sml-forward-sexps (&optional end)
-;; (sml-forward-sexp)
-;; (while (not (sml-looking-back-at (or end (concat sml-keywords-regexp "\\|[])}|:;]"))))
-;; (sml-forward-sexp)))
-
;;
;; now backwards
;;
(ignore-errors (backward-sexp 1))
(if (/= point (point)) t (backward-char 1) nil)))
;; let...end atoms
- ((or (string-equal "end" op)
+ ((or (string= "end" op)
(and (not prec)
- (or (string-equal "in" op) (string-equal "with" op))))
+ (or (string= "in" op) (string= "with" op))))
(sml-find-match-backward "\\<end\\>" sml-begin-symbols-re))
;; don't forget the `op' special keyword
((sml-move-if (progn (sml-backward-spaces) (skip-syntax-backward "w_"))
((and (or (not prec) (and prec op-prec (< prec op-prec)))
(string-match (sml-syms-re sml-exptrail-syms) op))
(cond
- ((or (string-equal "else" op) (string-equal "then" op))
+ ((or (string= "else" op) (string= "then" op))
(sml-find-match-backward "\\<else\\>" "\\<if\\>"))
- ((string-equal "of" op)
+ ((string= "of" op)
(sml-find-match-backward "\\<of\\>" "\\<case\\>"))
- ((string-equal "do" op)
+ ((string= "do" op)
(sml-find-match-backward "\\<do\\>" "\\<while\\>"))
(t prec)))
;; infix ops precedence
;; let...end atoms
((or (string-match sml-begin-symbols-re op)
(and (not prec)
- (or (string-equal "in" op) (string-equal "with" op))))
+ (or (string= "in" op) (string= "with" op))))
(sml-find-match-forward sml-begin-symbols-re "\\<end\\>"))
;; don't forget the `op' special keyword
- ((string-equal "op" op) (sml-forward-sym))
+ ((string= "op" op) (sml-forward-sym))
;; infix ops precedence
((and prec op-prec) (< prec op-prec))
;; [ prec = nil ] if...then...else
- ;; ((or (string-equal "else" op) (string-equal "then" op))
+ ;; ((or (string= "else" op) (string= "then" op))
;; (sml-find-match-backward "\\<else\\>" "\\<if\\>"))
;; [ prec = nil ] case...of
- ;; ((string-equal "of" op)
+ ;; ((string= "of" op)
;; (sml-find-match-backward "\\<of\\>" "\\<case\\>"))
;; [ prec = nil ] while...do
- ;; ((string-equal "do" op)
+ ;; ((string= "do" op)
;; (sml-find-match-backward "\\<do\\>" "\\<while\\>"))
;; [ prec = nil ] a new operator, let's skip the sexps until the next
(op-prec (while (sml-move-if (sml-forward-sexp op-prec))) t)
(t t))))) ;(or (string-match "\\sw" op) (sml-backward-sexp prec))
(defun sml-in-word-p ()
- (and (eq ?w (char-syntax (char-before)))
- (eq ?w (char-syntax (char-after)))))
+ (and (eq ?w (char-syntax (or (char-before) ? )))
+ (eq ?w (char-syntax (or (char-after) ? )))))
(defun sml-user-backward-sexp (&optional count)
"Like `backward-sexp' but tailored to the SML syntax."
(defun sml-backward-arg () (sml-backward-sexp 1000))
(defun sml-forward-arg () (sml-forward-sexp 1000))
-;; (defun sml-backward-arg ()
-;; "Moves one sexp backward (and return T) if it is an argument."
-;; (let* ((point (point))
-;; (argp (and (sml-backward-sexp t)
-;; (not (looking-at sml-not-arg-re))
-;; (save-excursion
-;; (sml-forward-sexp 1 t)
-;; (sml-forward-spaces)
-;; (>= (point) point)))))
-;; (unless argp (goto-char point))
-;; argp))
-
-;; (defun sml-backward-sexps (&optional end)
-;; (sml-backward-spaces)
-;; (let ((eos (point)))
-;; (sml-backward-sexp t)
-;; (while (not (save-restriction
-;; (narrow-to-region (point) eos)
-;; (looking-at (or end sml-keywords-regexp))))
-;; (sml-backward-spaces)
-;; (setq eos (point))
-;; (sml-backward-sexp t))
-;; (if (looking-at "\\sw")
-;; (forward-word 1)
-;; (forward-char))
-;; (sml-forward-spaces)))
-
-;; (defun sml-up-list ()
-;; (save-excursion
-;; (condition-case ()
-;; (progn
-;; (up-list 1)
-;; (point))
-;; (error 0))))
-
;;
(provide 'sml-move)
+++ /dev/null
-;;; sml-poly-ml.el: Modifies inferior-sml-mode defaults for Poly/ML.
-
-;; Copyright (C) 1994,1997 Matthew J. Morley
-
-;; $Revision: 3.9 $
-;; $Date: 1997/06/23 09:21:25 $
-
-;; This file is not part of GNU Emacs, but it is distributed under the
-;; same conditions.
-
-;; ====================================================================
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or (at
-;; your option) any later version.
-
-;; This program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;; ====================================================================
-
-;;; DESCRIPTION
-
-;; To use this library just put
-
-;;(autoload 'sml-poly-ml "sml-poly-ml" "Set up and run Poly/ML." t)
-
-;; in your .emacs file. If you only ever use Poly/ML then you might as
-;; well put something like
-
-;;(setq sml-mode-hook
-;; '(lambda() "SML mode defaults to Poly/ML"
-;; (define-key sml-mode-map "\C-cp" 'sml-poly-ml)))
-
-;; for your sml-load-hook. The command prompts for the program name
-;; and the database to use, if any.
-
-;; If you need to reset the default value of sml-program-name, or any
-;; of the other compiler variables, put something like
-
-;;(eval-after-load "sml-poly-ml" '(setq sml-program-name "whatever"))
-
-;; in your .emacs -- or you can use the inferior-sml-{load,mode}-hooks
-;; to achieve the same ends.
-
-;;; CODE
-
-(require 'sml-proc)
-
-(defconst sml-poly-ml-error-regexp
- "^\\(Error\\|Warning:\\) in '\\(.*\\)', line \\([0-9]+\\)"
- "Default regexp matching Poly/ML error messages.")
-
-;; The reg-expression used when looking for errors. Poly/ML errors:
-
-;; Warning: in 'puzz.sml', line 28
-;; Matches are not exhaustive.
-
-;; Error
-;; Value or constructor (tl) has not been declared
-;; Found near tl(tl(tl(tl(N))))
-
-;; (when input is from std_in -- i.e. entered directly at the prompt).
-
-(defun sml-poly-ml-error-parser (pt)
- "This function parses a Poly/ML error message into a 3 element list.
- (file start-line start-col) required by `sml-next-error'."
- (save-excursion
- (goto-char pt)
- (if (not (looking-at sml-poly-ml-error-regexp))
- ;; the user loses big time.
- (list nil nil nil)
- (list (match-string 2) ; the file
- (string-to-int (match-string 3)) ; the start line
- 1)))) ; the start col
-
-;;;###autoload
-(defun sml-poly-ml (pfx)
- "Set up and run Poly/ML.
-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 \"poly\"\)
- sml-default-arg <option dbase> \(default \"\"\)
- sml-use-command \"PolyML.use \\\"%s\\\"\"
- sml-cd-command \"PolyML.cd \\\"%s\\\"\"
- sml-prompt-regexp \"^[>#] *\"
- sml-error-regexp sml-poly-ml-error-regexp
- sml-error-parser 'sml-poly-ml-error-parser"
- (interactive "P")
- (let ((cmd (if pfx "poly"
- (read-string "Command name: " sml-program-name)))
- (arg (if pfx ""
- (read-file-name "Poly database? (default none): " "" ""))))
- ;; sml-mode global variables
- (setq sml-program-name cmd)
- (setq sml-default-arg (if (equal arg "") "" (expand-file-name arg)))
- ;; buffer-local (compiler-local) variables
- (setq-default sml-use-command "PolyML.use \"%s\""
- sml-cd-command "PolyML.cd \"%s\""
- sml-prompt-regexp "^[>#] *"
- sml-error-regexp sml-poly-ml-error-regexp
- sml-error-parser 'sml-poly-ml-error-parser)
- (sml-run cmd sml-default-arg)))
-
-;;; Do the default setup on loading this file.
-
-;; setqing these two may override user's hooked defaults. users
-;; therefore need load this file before setting sml-program-name or
-;; sml-default-arg in their inferior-sml-load-hook. sorry.
-
-(setq sml-program-name "poly"
- sml-default-arg "")
-
-;; same sort of problem here too: users should to setq-default these
-;; after this file is loaded, on inferior-sml-load-hook. as these are
-;; buffer-local, users can instead set them on inferior-sml-mode-hook.
-
-(setq-default sml-use-command "PolyML.use \"%s\""
- sml-cd-command "PolyML.cd \"%s\""
- sml-prompt-regexp "^[>#] *"
- sml-error-regexp sml-poly-ml-error-regexp
- sml-error-parser 'sml-poly-ml-error-parser)
-
-;;; sml-poly-ml.el ended just there
;;; sml-proc.el. Comint based interaction mode for Standard ML.
+(defconst rcsid-sml-proc "@(#)$Name$:$Id$")
+
;; Copyright (C) 1989, Lars Bo Nielsen, 1994,1997 Matthew J. Morley
;; $Revision$
;; While small pieces of text can be fed quite happily into the ML
;; process directly, lager pieces should (probably) be sent via a
;; temporary file making use of the compiler's "use" command.
-
-;; CURRENT RATIONALE: you get sense out of the error messages if
-;; there's a real file associated with a block of code, and XEmacs is
-;; less likely to hang. These are likely to change.
-
-;; For more information see the variable sml-temp-threshold. You
-;; should set the variable sml-use-command appropriately for your ML
-;; compiler. By default things are set up to work for the SML/NJ
-;; compiler.
+;; To be safe, we always use a temp file (which also improves error
+;; reporting).
;;; FOR YOUR .EMACS
;; (define-key inferior-sml-mode-map "\C-cd" 'sml-cd)
;; (define-key sml-mode-map "\C-cd" 'sml-cd)
;; (define-key sml-mode-map "\C-c\C-f" 'sml-send-function)
-;; (setq sml-temp-threshold 0))) ; safe: always use tmp file
;; (setq inferior-sml-mode-hook
;; '(lambda() "Inferior SML mode defaults"
;;; INFERIOR ML MODE VARIABLES
(require 'sml-mode)
+(require 'sml-util)
(require 'comint)
-(provide 'sml-proc)
+(require 'compile)
(defvar sml-program-name "sml"
"*Program to run as ML.")
(defvar sml-default-arg ""
"*Default command line option to pass, if any.")
-(defvar sml-make-command "CM.make()"
+(defvar sml-compile-command "CM.make()"
"The command used by default by `sml-make'.")
(defvar sml-make-file-name "sources.cm"
;;(defvar sml-raise-on-error nil
;; "*When non-nil, `sml-next-error' will raise the ML process's frame.")
-(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\"\)")
-
(defvar inferior-sml-mode-hook nil
"*This hook is run when the inferior ML process is started.
All buffer local customisations for the interaction buffers go here.")
"*Hook run when inferior-sml-mode (sml-proc.el) is loaded into Emacs.
This is a good place to put your preferred key bindings.")
+(defvar sml-error-overlay nil
+ "*Non-nil means use an overlay to highlight errorful code in the buffer.
+The actual value is the name of a face to use for the overlay.
+Instead of setting this variable to 'region, you can also simply keep
+it NIL and use (transient-mark-mode) which will provide similar
+benefits (but with several side effects).")
+
(defvar sml-buffer nil
"*The current ML process buffer.
The format specifier \"%s\" will be converted into the directory name
specified when running the command \\[sml-cd].")
-(defvar sml-prompt-regexp "^[\-=] *"
+(defvar sml-prompt-regexp "^[-=>#] *"
"*Regexp used to recognise prompts in the inferior ML process.")
(defvar sml-error-parser 'sml-smlnj-error-parser
;; std_in:2.1-4.3 Error: operator and operand don't agree (tycon mismatch)
;; std_in:2.1 Error: operator and operand don't agree (tycon mismatch)
-(defconst sml-smlnj-error-regexp
- (concat
- "^[-= ]*\\(.+\\):" ;file name
- "\\([0-9]+\\)\\.\\([0-9]+\\)" ;start line.column
- "\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)?" ;end line.colum
- ".+\\(\\(Error\\|Warning\\): .*\\)") ;the message
-
- "Default regexp matching SML/NJ error and warning messages.
-
-There should be no need to customise this, though you might decide
-that you aren't interested in Warnings -- my advice would be to modify
-`sml-error-regexp' explicitly to do that though.
-
-If you do customise `sml-smlnj-error-regexp' you may need to modify
-the function `sml-smlnj-error-parser' (qv).")
-
-(defvar sml-error-regexp sml-smlnj-error-regexp
+(defconst sml-error-regexp-alist
+ '(;; Poly/ML messages
+ ("\\(Error\\|Warning:\\) in '\\(.+\\)', line \\([0-9]+\\)" 2 3)
+ ;; Moscow ML
+ ("File \"\\([^\"]+\\)\", line \\([0-9]+\\)\\(-\\([0-9]+\\)\\)?, characters \\([0-9]+\\)-\\([0-9]+\\):" 1 2 5)
+ ;; SML/NJ
+ ("[-= ]*\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warning\\): .*" 1 sml-make-error 2 3 5 6)
+ ;; SML/NJ's exceptions
+ (" +\\(raised at: \\)?\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2 sml-make-error 3 4 6 7)))
+
+(defvar sml-error-regexp nil
"*Regexp for matching \(the start of\) an error message.")
;; font-lock support
-(defvar inferior-sml-font-lock-keywords
- `((,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
+(defconst inferior-sml-font-lock-keywords
+ `(;; prompt and following interactive command
+ (,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
(1 font-lock-prompt-face)
(2 font-lock-command-face keep))
- (,sml-error-regexp . font-lock-warning-face)
+ ;; CM's messages
("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face)
- ("^GC #.*" . font-lock-comment-face)))
+ ;; SML/NJ's irritating GC messages
+ ("^GC #.*" . font-lock-comment-face)
+ ;; error messages
+ ,@(mapcar (lambda (ra) (cons (car ra) 'font-lock-warning-face))
+ sml-error-regexp-alist))
+ "Font-locking specification for inferior SML mode.")
;; default faces values
(defvar font-lock-prompt-face
(defvar inferior-sml-font-lock-defaults
'(inferior-sml-font-lock-keywords nil nil nil nil))
-(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)))
-
-
;;; CODE
(defmap inferior-sml-mode-map
;; buffer-local
+(defvar sml-temp-file nil)
(defvar sml-error-file nil) ; file from which the last error came
-(defvar sml-real-file nil) ; used for finding source errors
(defvar sml-error-cursor nil) ; ditto
(defun sml-proc-buffer ()
or the current buffer if it is in `inferior-sml-mode'. Raises an error
if the variable `sml-buffer' does not appear to point to an existing
buffer."
- (let ((buffer
- (cond ((eq major-mode 'inferior-sml-mode)
- ;; default to current buffer if it's in inferior-sml-mode
- (current-buffer))
- ((bufferp sml-buffer)
- ;; buffer-name returns nil if the buffer has been killed
- (buffer-name sml-buffer))
- ((stringp sml-buffer)
- ;; get-buffer returns nil if there's no buffer of that name
- (get-buffer sml-buffer)))))
- (or buffer
- (error "No current process buffer. See variable sml-buffer"))))
+ (or (and (eq major-mode 'inferior-sml-mode) (current-buffer))
+ (and sml-buffer
+ (let ((buf (get-buffer sml-buffer)))
+ ;; buffer-name returns nil if the buffer has been killed
+ (and buf (buffer-name buf) buf)))
+ ;; no buffer found, make a new one
+ (run-sml t)))
(defun sml-proc ()
"Returns the current ML process. See variable `sml-buffer'."
- (let ((proc (get-buffer-process (sml-proc-buffer))))
- (or proc
- (error "No current process. See variable sml-buffer"))))
+ (assert (eq major-mode 'inferior-sml-mode))
+ (or (get-buffer-process (current-buffer))
+ (progn (run-sml t) (get-buffer-process (current-buffer)))))
(defun sml-buffer (echo)
"Make the current buffer the current `sml-buffer' if that is sensible.
Lookup variable `sml-buffer' to see why this might be useful."
(interactive "P")
- (let ((current
- (cond ((bufferp sml-buffer) (or (buffer-name sml-buffer) "undefined"))
- ((stringp sml-buffer) sml-buffer)
- (t "undefined"))))
- (if echo (message (format "ML process buffer is %s." current))
- (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)))
+ (when (and (not echo) (eq major-mode 'inferior-sml-mode))
+ (setq sml-buffer (current-buffer)))
+ (message "ML process buffer is %s."
+ (or (ignore-errors (buffer-name (get-buffer sml-buffer)))
+ "undefined")))
(defun inferior-sml-mode ()
"Major mode for interacting with an inferior ML process.
`sml-prompt-regexp' (default \"^[\\-=] *\")
Regexp used to recognise prompts in the inferior ML process.
-`sml-temp-threshold' (default 0)
- Controls when emacs uses temporary files to communicate with ML.
- If an integer N, then emacs uses a temporary file whenever the
- text is longer than N chars.
-
-`sml-temp-file' (default (make-temp-name \"/tmp/ml\"))
- Temp file that emacs uses to communicate with the ML process.
-
`sml-error-regexp'
(default -- complicated)
Regexp for matching error messages from the compiler.
(sml-mode-variables)
;; For sequencing through error messages:
-
(set (make-local-variable 'sml-error-cursor) (point-max-marker))
- (set (make-local-variable 'sml-real-file) nil)
+ (set-marker-insertion-type sml-error-cursor nil)
(set (make-local-variable 'font-lock-defaults)
inferior-sml-font-lock-defaults)
- (make-local-variable 'sml-use-command)
- (make-local-variable 'sml-cd-command)
- (make-local-variable 'sml-prompt-regexp)
- (make-local-variable 'sml-error-parser)
- (make-local-variable 'sml-error-regexp)
+ ;; compilation support (used for next-error)
+ (set (make-local-variable 'compilation-error-regexp-alist)
+ sml-error-regexp-alist)
+ (compilation-shell-minor-mode 1)
+ ;; I'm sure people might kill me for that
+ (setq compilation-error-screen-columns nil)
+ (make-local-variable 'sml-endof-error-alist)
+ ;;(make-local-variable 'sml-error-overlay)
(setq major-mode 'inferior-sml-mode)
(setq mode-name "Inferior ML")
(setq mode-line-process '(": %s"))
(use-local-map inferior-sml-mode-map)
- (add-hook 'kill-emacs-hook 'sml-proc-tidy)
+ ;;(add-hook 'kill-emacs-hook 'sml-temp-tidy)
(run-hooks 'inferior-sml-mode-hook))
"Run the ML program CMD with given arguments ARGS.
This usually updates `sml-buffer' to a buffer named *CMD*."
(let* ((pname (file-name-nondirectory cmd))
- (bname (format "*%s*" pname))
(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))
- ;; and this -- to keep these as defaults even if
- ;; they're set in the mode hooks.
- (setq sml-program-name cmd)
- (setq sml-default-arg arg))))
+ ;; and this -- to keep these as defaults even if
+ ;; they're set in the mode hooks.
+ (setq sml-program-name cmd)
+ (setq sml-default-arg arg)
+ (setq sml-buffer (apply 'make-comint pname cmd nil args))
+
+ (set-buffer sml-buffer)
+ (message (format "Starting \"%s\" in background." pname))
+ (inferior-sml-mode)
+ (goto-char (point-max))
+ sml-buffer))
(defun sml-args-to-list (string)
(let ((where (string-match "[ \t]" string)))
(sml-args-to-list (substring string pos
(length string)))))))))
-(defun sml-temp-threshold (&optional thold)
- "Set the variable to the given prefix (nil, if no prefix given).
-This is really mainly here to help debugging sml-mode!"
- (interactive "P")
- (setq sml-temp-threshold
- (if current-prefix-arg (prefix-numeric-value thold)))
- (message "%s" sml-temp-threshold))
-
;;;###autoload
(defun switch-to-sml (eob-p)
"Switch to the ML process buffer.
With prefix argument, positions cursor at point, otherwise at end of buffer."
(interactive "P")
- (if (sml-noproc) (save-excursion (run-sml t)))
(pop-to-buffer (sml-proc-buffer))
(cond ((not eob-p)
(push-mark (point) t)
"Send current region to the inferior ML process.
Prefix argument means switch-to-sml afterwards.
-If the region is longer than `sml-temp-threshold' and the variable
-`sml-use-command' is defined, the region is written out to a temporary file
-and a \"use <temp-file>\" command is sent to the compiler\; otherwise the
-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'."
+The region is written out to a temporary file and a \"use <temp-file>\" command
+is sent to the compiler.
+See variables `sml-use-command'."
(interactive "r\nP")
- (if (sml-noproc) (save-excursion (run-sml t)))
- (cond ((equal start end)
- (message "The region is zero (ignored)"))
- ((and sml-use-command
- (numberp sml-temp-threshold)
- (< sml-temp-threshold (- end start)))
- ;; Just in case someone is still reading from sml-temp-file:
- (if (file-exists-p sml-temp-file)
- (delete-file sml-temp-file))
- (write-region start end sml-temp-file nil 'silently)
- (sml-update-barrier (buffer-file-name (current-buffer)) start)
- (sml-update-cursor (sml-proc-buffer))
- (comint-send-string (sml-proc)
- (concat (format sml-use-command sml-temp-file) ";\n")))
- (t
- (comint-send-region (sml-proc) start end)
- (comint-send-string (sml-proc) ";\n")))
- (if and-go (switch-to-sml nil)))
-
-;; Update the buffer-local variables sml-real-file
-;; 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))))
+ (if (= start end)
+ (message "The region is zero (ignored)")
+ (let* ((buf (sml-proc-buffer))
+ (file (buffer-file-name))
+ (marker (copy-marker start))
+ (tmp (make-temp-file "sml")))
+ (write-region start end tmp nil 'silently)
+ (with-current-buffer buf
+ (when sml-temp-file
+ (ignore-errors (delete-file (car sml-temp-file)))
+ (set-marker (cdr sml-temp-file) nil))
+ (setq sml-temp-file (cons tmp marker))
+ (sml-send-string (format sml-use-command tmp) nil and-go)))))
;; This is quite bogus, so it isn't bound to a key by default.
;; Anyone coming up with an algorithm to recognise fun & local
(sml-send-region (point) (mark)))
(if and-go (switch-to-sml nil)))
-(defvar sml-source-modes '(sml-mode)
- "*Used to determine if a buffer contains ML source code.
+(defvar sml-source-modes '(sml-mode)
+ "*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.")
;; simplified from frame.el in Emacs: special-display-popup-frame...
-(defun sml-proc-frame ()
- "Returns the current ML process buffer's frame, or creates one first."
- (let ((buffer (sml-proc-buffer)))
- (window-frame (display-buffer buffer))))
+;; (defun sml-proc-frame ()
+;; "Returns the current ML process buffer's frame, or creates one first."
+;; (let ((buffer (sml-proc-buffer)))
+;; (window-frame (display-buffer buffer))))
;;; H A C K A T T A C K ! X E M A C S V E R S U S E M A C S
;; Only these two functions have to dance around the inane differences
;; between Emacs and XEmacs (fortunately)
-(defun sml-warp-mouse (frame)
- "Warp the pointer across the screen to upper right corner of FRAME."
- (raise-frame frame)
- (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)
- ;; LUCID (19.10) or later... set-m-pos needs a WINDOW
- (set-mouse-position (frame-root-window frame) (1- (frame-width)) 0))
- (t
- ;; GNU, post circa 19.19... set-m-pos needs a FRAME
- (set-mouse-position frame (1- (frame-width)) 0)
- ;; probably not needed post 19.29
- (if (fboundp 'unfocus-frame) (unfocus-frame)))))
+;; (defun sml-warp-mouse (frame)
+;; "Warp the pointer across the screen to upper right corner of FRAME."
+;; (raise-frame frame)
+;; (cond ((string-match "\\(Lucid\\|XEmacs\\)" emacs-version)
+;; ;; LUCID (19.10) or later... set-m-pos needs a WINDOW
+;; (set-mouse-position (frame-root-window frame) (1- (frame-width)) 0))
+;; (t
+;; ;; GNU, post circa 19.19... set-m-pos needs a FRAME
+;; (set-mouse-position frame (1- (frame-width)) 0)
+;; ;; probably not needed post 19.29
+;; (if (fboundp 'unfocus-frame) (unfocus-frame)))))
(defun sml-drag-region (event)
"Highlight the text the mouse is dragged over, and send it to ML.
;;; LOADING AND IMPORTING SOURCE FILES:
-(defvar sml-prev-l/c-dir/file nil
+(defvar sml-prev-dir/file nil
"Caches the (directory . file) pair used in the last `sml-load-file'
or `sml-cd' command. Used for determining the default in the next one.")
the command to send to the ML process\; a trailing \"\;\\n\" will be added
automatically."
(interactive "P")
- (if (sml-noproc) (save-excursion (run-sml t)))
- (if sml-use-command
- (let ((file
- (car (comint-get-source "Load ML file: " sml-prev-l/c-dir/file
- sml-source-modes t))))
- ;; Check if buffer needs saved. Should (save-some-buffers) instead?
- (comint-check-source file)
- (setq sml-prev-l/c-dir/file
- (cons (file-name-directory file) (file-name-nondirectory file)))
- (sml-update-cursor (sml-proc-buffer))
- (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)))
+ (let ((file (car (comint-get-source
+ "Load ML file: " sml-prev-dir/file sml-source-modes t))))
+ (with-current-buffer (sml-proc-buffer)
+ ;; Check if buffer needs saved. Should (save-some-buffers) instead?
+ (comint-check-source file)
+ (setq sml-prev-dir/file
+ (cons (file-name-directory file) (file-name-nondirectory file)))
+ (sml-send-string (format sml-use-command file) nil and-go))))
(defun sml-cd (dir)
"Change the working directory of the inferior ML process.
be executed to change the compiler's working directory\; a trailing
\"\;\\n\" will be added automatically."
(interactive "DSML Directory: ")
- (let* ((buf (sml-proc-buffer))
- (proc (get-buffer-process buf))
- (dir (expand-file-name dir))
- (string (concat (format sml-cd-command dir) ";\n")))
- (save-excursion
- (set-buffer buf)
- (goto-char (point-max))
- (insert string)
- (set-marker (process-mark proc) (point))
- (if sml-cd-command (process-send-string proc string))
- (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)
- (when win (select-window win))
- (goto-char (point-max))
- (when print (insert string))
- (when my-dir (cd my-dir))
- (sml-update-cursor buf)
- (sml-update-barrier)
- (set-marker (process-mark proc) (point-max))
- (comint-send-string proc string))
- (switch-to-sml t)))
-
-(defun sml-make (command)
+ (let ((dir (expand-file-name dir)))
+ (with-current-buffer (sml-proc-buffer)
+ (sml-send-string (format sml-cd-command dir) t)
+ (setq default-directory dir))
+ (setq sml-prev-dir/file (cons dir nil))))
+
+(defun sml-send-string (str &optional print and-go)
+ (let ((proc (sml-proc))
+ (str (concat str ";\n"))
+ (win (get-buffer-window (current-buffer) 'visible)))
+ (when win (select-window win))
+ (goto-char (point-max))
+ (when print (insert str))
+ (sml-update-cursor)
+ (set-marker (process-mark proc) (point-max))
+ (setq compilation-last-buffer (current-buffer))
+ (comint-send-string proc str)
+ (when and-go (switch-to-sml nil))))
+
+(defun sml-compile (command)
"re-make a system using (by default) CM.
The exact command used can be specified by providing a prefix argument."
(interactive
;; code taken straight from compile.el
- (if (or current-prefix-arg (not sml-make-command))
+ (if (or compilation-read-command current-prefix-arg)
(list (read-from-minibuffer "Compile command: "
- sml-make-command nil nil
+ sml-compile-command nil nil
'(compile-history . 1)))
- (list sml-make-command)))
- (setq sml-make-command command)
- ;; try to find a makefile up the sirectory tree
- (let ((dir (and sml-make-file-name (expand-file-name default-directory))))
+ (list sml-compile-command)))
+ (setq sml-compile-command command)
+ (save-some-buffers (not compilation-ask-about-save) nil)
+ ;; try to find a makefile up the directory tree
+ (let ((dir (when sml-make-file-name default-directory)))
(while (and dir (not (file-exists-p (concat dir sml-make-file-name))))
(let ((newdir (file-name-directory (directory-file-name dir))))
- (setq dir (if (equal newdir dir) nil newdir))))
- (sml-send-command command dir t)))
+ (setq dir (unless (equal newdir dir) newdir))))
+ (unless dir (setq dir default-directory))
+ (with-current-buffer (sml-proc-buffer)
+ (setq default-directory dir)
+ (sml-send-string (concat (format sml-cd-command dir) "; " command) t t))))
;;; PARSING ERROR MESSAGES
;; This should need no modification to support other compilers.
-;;;###autoload
-(defun sml-next-error (skip)
- "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...?"
+;; Update the buffer-local error-cursor in proc-buffer to be its
+;; current proc mark.
+
+(defvar sml-endof-error-alist nil)
+
+(defun sml-update-cursor ()
+ ;; update buffer local variable
+ (set-marker sml-error-cursor (1- (process-mark (sml-proc))))
+ (setq sml-endof-error-alist nil)
+ (compilation-forget-errors)
+ (setq compilation-parsing-end sml-error-cursor))
+
+(defun sml-make-error (f c)
+ (let ((err (point-marker))
+ (linenum (string-to-number c))
+ (filename (list (first f) (second f)))
+ (column (string-to-number (compile-buffer-substring (third f)))))
+ ;; record the end of error, if any
+ (when (fourth f)
+ (let* ((endline (string-to-number (compile-buffer-substring (fourth f))))
+ (endcol (string-to-number (compile-buffer-substring (fifth f))))
+ (linediff (- endline linenum)))
+ (push (list err linediff (if (= 0 linediff) (- endcol column) endcol))
+ sml-endof-error-alist)))
+ ;; build the error descriptor
+ (if (string= (car sml-temp-file) (first f))
+ ;; special case for code sent via sml-send-region
+ (let ((marker (cdr sml-temp-file)))
+ (with-current-buffer (marker-buffer marker)
+ (goto-char marker)
+ (forward-line (1- linenum))
+ (forward-char (1- column))
+ (cons err (point-marker))))
+ ;; taken from compile.el
+ (list err filename linenum column))))
+
+(defadvice compilation-goto-locus (after sml-endof-error activate)
+ (let* ((next-error (ad-get-arg 0))
+ (err (car next-error))
+ (pos (cdr next-error))
+ (endof (with-current-buffer (marker-buffer err)
+ (assq err sml-endof-error-alist))))
+ (if (not endof) (sml-error-overlay 'undo)
+ (with-current-buffer (marker-buffer pos)
+ (goto-char pos)
+ (let ((linediff (second endof))
+ (coldiff (third endof)))
+ (when (> 0 linediff) (forward-line linediff))
+ (forward-char coldiff))
+ (sml-error-overlay nil pos (point))
+ (push-mark nil t (not sml-error-overlay))
+ (goto-char pos)))))
+
+(defun sml-error-overlay (undo &optional beg end)
+ "Move `sml-error-overlay' so it surrounds the text region in the
+current buffer. If the buffer-local variable `sml-error-overlay' is
+non-nil it should be an overlay \(or extent, in XEmacs speak\)\; this
+function moves the overlay over the current region. If the optional
+BUFFER argument is given, move the overlay in that buffer instead of
+the current buffer.
+
+Called interactively, the optional prefix argument UNDO indicates that
+the overlay should simply be removed: \\[universal-argument] \
+\\[sml-error-overlay]."
(interactive "P")
- (if skip (sml-skip-errors) (sml-do-next-error)))
-
-(defun sml-bottle (msg)
- "Function to let `sml-next-error' give up gracefully."
- (sml-warp-mouse (selected-frame))
- (error msg))
-
-(defun sml-do-next-error ()
- "The 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
-
-(defun sml-skip-errors ()
- "Skip past the rest of the errors."
- (interactive)
- (if (memq major-mode sml-source-modes) (sml-error-overlay 'undo))
- (sml-update-cursor (sml-proc-buffer))
- (if (eq major-mode 'sml-inferior-mode) (goto-char (point-max))))
+ (when sml-error-overlay
+ (unless (overlayp sml-error-overlay)
+ (let ((ol sml-error-overlay))
+ (setq sml-error-overlay (make-overlay 0 0))
+ (overlay-put sml-error-overlay 'face (if (symbolp ol) ol 'region))))
+ (if undo
+ (move-overlay sml-error-overlay 1 1 (current-buffer))
+ ;; if active regions, signals mark not active if no region set
+ (let ((beg (or beg (region-beginning)))
+ (end (or end (region-end))))
+ (move-overlay sml-error-overlay beg end (current-buffer))))))
+
+;; ;;;###autoload
+;; (defun sml-next-error (skip)
+;; "Find the next error by parsing the inferior ML buffer.
+;; A prefix argument means `sml-skip-errors' (qv) instead.
+
+;; Move the error message on the top line of the window\; put the cursor
+;; \(point\) at the beginning of the error source.
+
+;; If the error message specifies a range, and `sml-error-parser' returns
+;; the range, the mark is placed at the end of the range. If the variable
+;; `sml-error-overlay' is non-nil, the region will also be highlighted.
+
+;; If `sml-error-parser' returns a fifth component this is assumed to be
+;; a string to indicate the nature of the error: this will be echoed in
+;; the minibuffer.
+
+;; Error interaction only works if there is a real file associated with
+;; the input -- though of course it also depends on the compiler's error
+;; messages \(also see documantation for `sml-error-parser'\).
+
+;; However: if the last text sent went via `sml-load-file' (or the temp
+;; file mechanism), the next error reported will be relative to the start
+;; of the region sent, any error reports in the previous output being
+;; forgotten. If the text went directly to the compiler the succeeding
+;; error reported will be the next error relative to the location \(in
+;; the output\) of the last error. This odd behaviour may have a use...?"
+;; (interactive "P")
+;; (if skip (sml-skip-errors) (sml-do-next-error)))
+
+;; (defun sml-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 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))
+;; (error "Failed to parse/locate this error properly!"))
+;; ;; decide what to do depending on the file returned
+;; (when (string= file "std_in")
+;; ;; presently a fundamental limitation i'm afraid.
+;; (error "Sorry, can't locate errors on std_in."))
+;; ;; jump to the beginning
+;; (if (string= file (car sml-temp-file))
+;; (let* ((maker (cdr sml-temp-file))
+;; (buf (marker-buffer marker)))
+;; (display-buffer buf)
+;; (set-buffer buf)
+;; (goto-char marker))
+;; (unless (file-readable-p file) (error "Can't read %s" 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 (point-min)))
+;; ;; jump to the error
+;; (forward-line (1- line0))
+;; (forward-char (1- col0))
+;; ;; point is at start of error text; seek the end.
+;; (let ((start (point))
+;; (end (and line/col1
+;; (condition-case nil
+;; (progn (eval line/col1) (point))
+;; (error nil)))))
+;; ;; return to start anyway
+;; (goto-char start)
+;; ;; if point went to end, put mark there, and maybe highlight
+;; (if end (progn (push-mark end t)
+;; (sml-error-overlay nil start end)))
+;; (setq sml-error-file file) ; remember this for next time
+;; (if msg (message msg))))))) ; echo the error/warning message
+
+;; (defun sml-skip-errors ()
+;; "Skip past the rest of the errors."
+;; (interactive)
+;; (if (memq major-mode sml-source-modes) (sml-error-overlay 'undo))
+;; (with-current-buffer (sml-proc-buffer) (sml-update-cursor))
+;; (if (eq major-mode 'sml-inferior-mode) (goto-char (point-max))))
;;; 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
(run-hooks 'inferior-sml-load-hook)
;;; Here is where sml-proc.el ends
+(provide 'sml-proc)
+++ /dev/null
-;;; sml-site.el. Site initialisation for sml-mode
-
-;; Copyright (C) 1997, Matthew J. Morley
-;; Thanks to Ken Larsen <kla@it.dtu.dk> for his suggestions.
-
-;; This file is not part of GNU Emacs, but it is distributed under the
-;; same conditions.
-
-;; ====================================================================
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or (at
-;; your option) any later version.
-
-;; This program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;; ====================================================================
-
-;;; DESCRIPTION
-
-;; This file is provided for site administrators to install and
-;; configure sml-mode for the convenience of all their users. Even if
-;; you only install sml-mode for your private use, this is still a
-;; good place to do the necessary configuration.
-
-;; Follow the comments below to set the (few) necessary defaults; add
-;; any other configurations to the end of the file. Users just need to
-;; put
-
-;; (require 'sml-site)
-
-;; in their .emacs files (along with any personal customisations).
-;; Make sure this file is on the user's *default* load-path!
-
-;;; CODE
-
-;; *******************
-;; sml-lisp-directory:
-;; *******************
-
-;; This is where the sml-mode lisp (.el and/or .elc) files are to be
-;; kept. It is used for no purpose other than resetting the load-path
-;; variable. Site administrators might consider setqing this in their
-;; site-init.el file instead.
-
-;; A subdirectory of site-lisp directory seems a reasonable place...
-
-(defvar sml-lisp-directory "/usr/local/share/emacs/site-lisp/sml-mode"
- "*The directory where sml-mode lisp files are located.
-Used in sml-site.el in resetting the Emacs lisp `load-path' (qv).")
-
-(if (member sml-lisp-directory load-path)
- () ;take no prisoners
- (setq load-path (cons sml-lisp-directory load-path)))
-
-;; ****************
-;; auto-mode-alist:
-;; ****************
-
-;; Buffers for files that end with these extensions will be placed in
-;; sml-mode automatically.
-
-(if (rassoc 'sml-mode auto-mode-alist)
- () ;assume user has her own ideas
- (setq auto-mode-alist
- (append '(("\\.sml$" . sml-mode)
- ("\\.ML$" . sml-mode)
- ("\\.sig$" . sml-mode)) auto-mode-alist)))
-
-;; **************
-;; sml-mode-info:
-;; **************
-
-;; This is where sml-mode will look for it's online documentation.
-
-;; The default value in sml-mode.el is "sml-mode" which is correct if
-;; sml-mode.info is placed somewhere on Emacs' default info directory
-;; path. If you move sml-mode.info to the root of the site's info
-;; hierarchy don't forget to add a `dir' file menu entry like
-
-;; * SML: (sml-mode). Editing & Running Standard ML from Emacs
-
-;; If you can't (or won't) move the .info file onto the default info
-;; directory path, uncomment this defvar and set the full name here.
-
-;;(defvar sml-mode-info "/usr/???/sml-mode" "*Where to find sml-mode Info.")
-
-;; *****************
-;; sml-program-name:
-;; *****************
-
-;; sml-mode (sml-proc.el) defaults all its complier settings to SML/NJ
-;; (0.93, in this release of sml-mode). If the New Jersey compiler is
-;; called anything other than "sml" at your site, uncomment this
-;; defvar and set the correct name here.
-
-;;(defvar sml-program-name "sml" "*Program to run as ML.")
-
-;; The info file (Configuration) explains how to set up sml-mode for
-;; use with other ML compilers. Point users in that direction.
-
-;;; AUTOLOADS
-
-(autoload 'sml-mode "sml-mode" "Major mode for editing Standard ML." t)
-(autoload 'sml "sml-proc" "Run an inferior ML process." t)
-
-;; By all means set up Moscow ML and/or Poly/ML to autoload, but first
-;; check that "mosml" and/or "poly" appear on the user's default PATH.
-
-(autoload 'sml-mosml "sml-mosml" "Set up and run Moscow ML." t)
-(autoload 'sml-poly-ml "sml-poly-ml" "Set up and run Poly/ML." t)
-
-;; If they don't, users will winge until they discover how to change
-;; their PATH, or redefine sml-program-name, for themselves.
-
-;; Then
-
-(provide 'sml-site)
-
-;; and tell users to (require 'sml-site) in their .emacs files for the
-;; above to take effect. Byte compile this file or not, as you wish.
-
-;;; sml-site.el endeth.
-
+++ /dev/null
-;;; sml-nj.el: Modifies inferior-sml-mode defaults for SML/NJ.
-
-;; Copyright (C) 1997, Matthew J. Morley
-
-;; $Revision$
-;; $Date$
-
-;; This file is not part of GNU Emacs, but it is distributed under the
-;; same conditions.
-
-;; ====================================================================
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or (at
-;; your option) any later version.
-
-;; This program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;; ====================================================================
-
-;;; DESCRIPTION
-
-;; To use this library just put
-
-;;(autoload 'sml-smlnj "sml-nj" "Set up and run SML/NJ." t)
-
-;; in your .emacs file. If you only ever use the New Jersey compiler
-;; then you might as well put something like
-
-;;(setq sml-mode-hook
-;; '(lambda() "SML mode defaults to SML/NJ"
-;; (define-key sml-mode-map "\C-cp" 'sml-smlnj)))
-
-;; for your sml-mode-hook. The command prompts for the program name
-;; and any command line options.
-
-;; If you need to reset the default value of sml-program-name, or any
-;; of the other compiler variables, put something like
-
-;;(eval-after-load "sml-nj" '(setq sml-program-name "whatever"))
-
-;; in your .emacs -- or (better) you can use the inferior-sml-{load,
-;; mode}-hooks to achieve the same ends.
-
-;;; CODE
-
-(require 'sml-proc)
-
-;; std_in:2.1-4.3 Error: operator and operand don't agree (tycon mismatch)
-;; std_in:2.1 Error: operator and operand don't agree (tycon mismatch)
-
-(defconst sml-smlnj-error-regexp
- (concat
- "^[-= ]*\\(.+\\):" ;file name
- "\\([0-9]+\\)\\.\\([0-9]+\\)" ;start line.column
- "\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)?" ;end line.colum
- ".+\\(\\(Error\\|Warning\\): .*\\)") ;the message
-
- "Default regexp matching SML/NJ error and warning messages.
-
-There should be no need to customise this, though you might decide
-that you aren't interested in Warnings -- my advice would be to modify
-`sml-error-regexp' explicitly to do that though.
-
-If you do customise `sml-smlnj-error-regexp' you may need to modify
-the function `sml-smlnj-error-parser' (qv).")
-
-(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))))))))
-
-;;;###autoload
-(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.FieSys.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)))
-
-;;; Do the default setup on loading this file.
-
-;; setqing these two may override user's hooked defaults. users
-;; therefore need load this file before setting sml-program-name or
-;; sml-default-arg in their inferior-sml-load-hook. sorry.
-
-(setq sml-program-name "sml"
- sml-default-arg "")
-
-;; same sort of problem here too: users should to setq-default these
-;; after this file is loaded, on inferior-sml-load-hook. as these are
-;; buffer-local, users can instead set them on inferior-sml-mode-hook.
-
-(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-nj.el endeded
(flatten head rest)
(cons head rest)))))
+;;;
+;;; temp files
+;;;
+
+(defvar temp-file-dir temporary-file-directory
+ "Directory where to put temp files.")
+
+(defvar temp-directories ())
+
+(defun delete-temp-dirs ()
+ (dolist (dir temp-directories)
+ (when (file-directory-p dir)
+ (let ((default-directory dir))
+ (dolist (file (directory-files "."))
+ (ignore-errors (delete-file file))))
+ (delete-directory dir))))
+(add-hook 'kill-emacs-hook 'delete-temp-dirs)
+
+(defun make-temp-dir (s)
+ (let* ((prefix (expand-file-name s temp-file-dir))
+ (dir (make-temp-name prefix)))
+ (if (not (ignore-errors (make-directory dir t) t))
+ (make-temp-dir prefix)
+ (push dir temp-directories)
+ dir)))
+
+(defun make-temp-file (s)
+ (unless (file-name-absolute-p s)
+ (unless (equal (user-uid)
+ (third (file-attributes temporary-file-directory)))
+ (setq temporary-file-directory (make-temp-dir "emacs")))
+ (setq s (expand-file-name s temporary-file-directory)))
+ (let ((file (make-temp-name s)))
+ (write-region 1 1 file nil 'silent)
+ file))
+
+;; defmap ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
(defun custom-create-map (m bs args)
(unless (keymapp m)
(setq bs (append m bs))
(cond
((symbolp key)
(substitute-key-definition key binding m global-map))
- ((not (lookup-key m key))
+ ((let ((o (lookup-key m key))) (or (null o) (numberp o)))
(define-key m key binding)))))
(while args
(let ((key (first args))
((keymapp val) (set-keymap-parent m val))
(t (set-keymap-parents m val))))
(t (error "Uknown argument %s in defmap" key))))
- (setq args (cddr args))))
+ (setq args (cddr args)))
+ m)
(defmacro defmap (m bs doc &rest args)
- `(progn
- (defvar ,m (make-sparse-keymap) ,doc)
- (custom-create-map ,m ,bs ,(cons 'list args))))
+ `(defconst ,m
+ (custom-create-map (if (boundp ',m) ,m) ,bs ,(cons 'list args))
+ ,doc))
+
+;; defsyntax ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun custom-create-syntax (css args)
+ (let ((st (make-syntax-table (cadr (memq :copy args)))))
+ (dolist (cs css)
+ (let ((char (car cs))
+ (syntax (cdr cs)))
+ (if (sequencep char)
+ (mapcar* (lambda (c) (modify-syntax-entry c syntax st)) char)
+ (modify-syntax-entry char syntax st))))
+ st))
(defmacro defsyntax (st css doc &rest args)
- `(defvar ,st
- (let ((st (make-syntax-table ,(cadr (memq :copy args)))))
- (dolist (cs ,css)
- (let ((char (car cs))
- (syntax (cdr cs)))
- (if (sequencep char)
- (mapcar* (lambda (c) (modify-syntax-entry c syntax st))
- char)
- (modify-syntax-entry char syntax st))))
- st)
- doc))
+ `(defconst ,st (custom-create-syntax ,css ,(cons 'list args)) doc))
;;
(provide 'sml-util)