-;;; sml-mode.el. Major mode for editing (Standard) ML. Version 3.3(beta)
-
-;; Copyright (C) 1989, Lars Bo Nielsen; 1994,1997, Matthew J. Morley
-
+;;; sml-mode.el --- Major mode for editing (Standard) ML
+
+;; Copyright (C) 1989 Lars Bo Nielsen
+;; Copyright (C) 1994-1997 Matthew J. Morley
+;; Copyright (C) 1999-2000 Stefan Monnier
+
+;; Author: Lars Bo Nielsen
+;; Olin Shivers
+;; Fritz Knabe (?)
+;; Steven Gilmore (?)
+;; Matthew Morley <mjm@scs.leeds.ac.uk> (aka <matthew@verisity.com>)
+;; Matthias Blume <blume@cs.princeton.edu> (aka <blume@kurims.kyoto-u.ac.jp>)
+;; (Stefan Monnier) monnier@cs.yale.edu
+;; Maintainer: (Stefan Monnier) monnier+lists/emacs/sml@flint.cs.yale.edu
+;; Keywords: SML
;; $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
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;; ====================================================================
+;;; Commentary:
-;;; HISTORY
+;;; HISTORY
;; Still under construction: History obscure, needs a biographer as
;; well as a M-x doctor. Change Log on request.
;; font-lock patterns, some of Steven Gilmore's (reduced) easy-menus,
;; and numerous bugs and bug-fixes.
-;;; DESCRIPTION
+;;; DESCRIPTION
;; See accompanying info file: sml-mode.info
;;; FOR YOUR .EMACS FILE
-;; If sml-mode.el lives in some non-standard directory, you must tell
+;; If sml-mode.el lives in some non-standard directory, you must tell
;; emacs where to get it. This may or may not be necessary:
-;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path))
+;; (add-to-list 'load-path "~jones/lib/emacs/")
;; Then to access the commands autoload sml-mode with that command:
-;; (autoload 'sml-mode "sml-mode" "Major mode for editing ML programs." t)
-;;
-;; If files ending in ".sml" or ".ML" are hereafter considered to contain
-;; Standard ML source, put their buffers into sml-mode automatically:
-
-;; (setq auto-mode-alist
-;; (cons '(("\\.sml$" . sml-mode)
-;; ("\\.ML$" . sml-mode)) auto-mode-alist))
-
-;; Here's an example of setting things up in the sml-mode-hook:
-
-;; (setq sml-mode-hook
-;; '(lambda() "ML mode hacks"
-;; (setq sml-indent-level 2 ; conserve on horiz. space
-;; indent-tabs-mode nil))) ; whatever
+;; (load "sml-mode-startup")
;; sml-mode-hook is run whenever a new sml-mode buffer is created.
-;; There is an sml-load-hook too, which is only run when this file is
-;; loaded. One use for this hook is to select your preferred
-;; highlighting scheme, like this:
-
-;; (setq sml-load-hook
-;; '(lambda() "Highlights." (require 'sml-hilite)))
-
-;; hilit19 is the magic that actually does the highlighting. My set up
-;; for hilit19 runs something like this:
-
-;; (if window-system
-;; (setq hilit-background-mode t ; monochrome (alt: 'dark or 'light)
-;; hilit-inhibit-hooks nil
-;; hilit-inhibit-rebinding nil
-;; hilit-quietly t))
-
-;; Alternatively, you can (require 'sml-font) which uses the font-lock
-;; package instead.
;; Finally, there are inferior-sml-{mode,load}-hooks -- see comments
;; in sml-proc.el. For much more information consult the mode's *info*
;; tree.
-;;; VERSION STRING
-
-(defconst sml-mode-version-string
- "sml-mode, version 3.3(beta)")
+;;; Code:
-(require 'cl)
-(provide 'sml-mode)
+(eval-when-compile (require 'cl))
+(require 'sml-util)
+(require 'sml-move)
+(require 'sml-defs)
;;; VARIABLES CONTROLLING INDENTATION
-(defvar sml-indent-level 4
- "*Indentation of blocks in ML (see also `sml-structure-indent').")
+(defcustom sml-indent-level 4
+ "*Indentation of blocks in ML (see also `sml-structure-indent')."
+ :group 'sml
+ :type '(integer))
-(defvar sml-structure-indent 4 ; Not currently an option.
- "Indentation of signature/structure/functor declarations.")
+(defcustom sml-indent-args sml-indent-level
+ "*Indentation of args placed on a separate line."
+ :group 'sml
+ :type '(integer))
-(defvar sml-pipe-indent -2
- "*Extra (usually negative) indentation for lines beginning with |.")
+;; (defvar sml-indent-align-args t
+;; "*Whether the arguments should be aligned.")
-(defvar sml-case-indent nil
- "*How to indent case-of expressions.
- If t: case expr If nil: case expr of
- of exp1 => ... exp1 => ...
- | exp2 => ... | exp2 => ...
+;; (defvar sml-case-indent nil
+;; "*How to indent case-of expressions.
+;; If t: case expr If nil: case expr of
+;; of exp1 => ... exp1 => ...
+;; | exp2 => ... | exp2 => ...
-The first seems to be the standard in SML/NJ, but the second
-seems nicer...")
+;; 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 t
- "*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)")
+(defcustom sml-electric-semi-mode nil
+ "*If non-nil, `\;' will self insert, reindent the line, and do a newline.
+If nil, just insert a `\;'. (To insert while t, do: \\[quoted-insert] \;)."
+ :group 'sml
+ :type '(boolean))
;;; OTHER GENERIC MODE VARIABLES
(defvar sml-mode-info "sml-mode"
- "*Where to find Info file for sml-mode.
+ "*Where to find Info file for `sml-mode'.
The default assumes the info file \"sml-mode.info\" is on Emacs' info
-directory path. If it is not, either put the file on the standard path
-or set the variable sml-mode-info to the exact location of this file
-which is part of the sml-mode 3.2 (and later) distribution. E.g:
+directory path. If it is not, either put the file on the standard path
+or set the variable `sml-mode-info' to the exact location of this file
- (setq sml-mode-info \"/usr/me/lib/info/sml-mode\")
+ (setq sml-mode-info \"/usr/me/lib/info/sml-mode\")
in your .emacs file. You can always set it interactively with the
set-variable command.")
(defvar sml-mode-hook nil
- "*This hook is run when sml-mode is loaded, or a new sml-mode buffer created.
+ "*Run upon entering `sml-mode'.
This is a good place to put your preferred key bindings.")
-(defvar sml-load-hook nil
- "*This hook is run when sml-mode (sml-mode.el) is loaded into Emacs.")
-
-(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
+;;; CODE FOR SML-MODE
(defun sml-mode-info ()
- "Command to access the TeXinfo documentation for sml-mode.
-See doc for the variable sml-mode-info."
+ "Command to access the TeXinfo documentation for `sml-mode'.
+See doc for the variable `sml-mode-info'."
(interactive)
(require 'info)
(condition-case nil
- (funcall 'Info-goto-node (concat "(" sml-mode-info ")"))
+ (info sml-mode-info)
(error (progn
(describe-variable 'sml-mode-info)
(message "Can't find it... set this variable first!")))))
-(defun sml-indent-level (&optional indent)
- "Allow the user to change the block indentation level. Numeric prefix
-accepted in lieu of prompting."
- (interactive "NIndentation level: ")
- (setq sml-indent-level indent))
-
-(defun sml-pipe-indent (&optional indent)
- "Allow to change pipe indentation level (usually negative). Numeric prefix
-accepted in lieu of prompting."
- (interactive "NPipe Indentation level: ")
- (setq sml-pipe-indent indent))
-
-(defun sml-case-indent (&optional of)
- "Toggle sml-case-indent. Prefix means set it to nil."
- (interactive "P")
- (setq sml-case-indent (and (not of) (not sml-case-indent)))
- (if sml-case-indent (message "%s" "true") (message "%s" nil)))
-
-(defun sml-nested-if-indent (&optional of)
- "Toggle sml-nested-if-indent. Prefix means set it to nil."
- (interactive "P")
- (setq sml-nested-if-indent (and (not of) (not sml-nested-if-indent)))
- (if sml-nested-if-indent (message "%s" "true") (message "%s" nil)))
-
-(defun sml-type-of-indent (&optional of)
- "Toggle sml-type-of-indent. Prefix means set it to nil."
- (interactive "P")
- (setq sml-type-of-indent (and (not of) (not sml-type-of-indent)))
- (if sml-type-of-indent (message "%s" "true") (message "%s" nil)))
-
-(defun sml-electric-semi-mode (&optional of)
- "Toggle sml-electric-semi-mode. Prefix means set it to nil."
- (interactive "P")
- (setq sml-electric-semi-mode (and (not of) (not sml-electric-semi-mode)))
- (message "%s" (concat "Electric semi mode is "
- (if sml-electric-semi-mode "on" "off"))))
-
-;;; BINDINGS: these should be common to the source and process modes...
-
-(defun install-sml-keybindings (map)
- ;; Text-formatting commands:
- (define-key map "\C-c\C-m" 'sml-insert-form)
- (define-key map "\C-c\C-i" 'sml-mode-info)
- (define-key map "\M-|" 'sml-electric-pipe)
- (define-key map "\;" 'sml-electric-semi)
- (define-key map "\M-\t" 'sml-back-to-outer-indent)
- (define-key map "\C-j" 'newline-and-indent)
- (define-key map "\177" 'backward-delete-char-untabify)
- (define-key map "\C-\M-\\" 'sml-indent-region)
- (define-key map "\t" 'sml-indent-line) ; ...except this one
- ;; Process commands added to sml-mode-map -- these should autoload
- (define-key map "\C-c\C-l" 'sml-load-file)
- (define-key map "\C-c`" 'sml-next-error))
;;; Autoload functions -- no-doc is another idea cribbed from AucTeX!
-(defvar sml-no-doc
- "This function is part of sml-proc, and has not yet been loaded.
-Full documentation will be available after autoloading the function."
- "Documentation for autoloading functions.")
-
-(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)
-
-(defvar sml-mode-map nil "The keymap used in sml-mode.")
-(cond ((not sml-mode-map)
- (setq sml-mode-map (make-sparse-keymap))
- (install-sml-keybindings sml-mode-map)
- (define-key sml-mode-map "\C-c\C-c" 'sml-make)
- (define-key sml-mode-map "\C-c\C-s" 'switch-to-sml)
- (define-key sml-mode-map "\C-c\C-r" 'sml-send-region)
- (define-key sml-mode-map "\C-c\C-b" 'sml-send-buffer)))
+(let ((sml-no-doc
+ "This function is part of sml-proc, and has not yet been loaded.
+Full documentation will be available after autoloading the function."))
+
+ (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
-(defvar sml-font-lock-keywords
- '((sml-font-comments-and-strings)
- ("\\<\\(fun\\|and\\)\\s-+\\(\\sw+\\)"
+(defconst sml-keywords-regexp
+ (sml-syms-re "abstraction" "abstype" "and" "andalso" "as" "before" "case"
+ "datatype" "else" "end" "eqtype" "exception" "do" "fn"
+ "fun" "functor" "handle" "if" "in" "include" "infix"
+ "infixr" "let" "local" "nonfix" "of" "op" "open" "orelse"
+ "overload" "raise" "rec" "sharing" "sig" "signature"
+ "struct" "structure" "then" "type" "val" "where" "while"
+ "with" "withtype" "o")
+ "A regexp that matches any and all keywords of SML.")
+
+(defconst sml-font-lock-keywords
+ `(;;(sml-font-comments-and-strings)
+ ("\\<\\(fun\\|and\\)\\s-+\\('\\sw+\\s-+\\)*\\(\\sw+\\)"
(1 font-lock-keyword-face)
- (2 font-lock-function-def-face))
- ("\\<\\(\\(data\\|abs\\|with\\|eq\\)?type\\)\\s-+\\('\\s-*\\sw+\\s-+\\)*\\(\\sw+\\)"
+ (3 font-lock-function-name-face))
+ ("\\<\\(\\(data\\|abs\\|with\\|eq\\)?type\\)\\s-+\\('\\sw+\\s-+\\)*\\(\\sw+\\)"
(1 font-lock-keyword-face)
(4 font-lock-type-def-face))
- ("\\<\\(val\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*="
+ ("\\<\\(val\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
(1 font-lock-keyword-face)
;;(6 font-lock-variable-def-face nil t)
- (3 font-lock-variable-def-face))
+ (3 font-lock-variable-name-face))
("\\<\\(structure\\|functor\\|abstraction\\)\\s-+\\(\\sw+\\)"
(1 font-lock-keyword-face)
(2 font-lock-module-def-face))
(1 font-lock-keyword-face)
(2 font-lock-interface-def-face))
- ;; Generated with Simon Marshall's make-regexp:
- ;; (make-regexp
- ;; '("abstype" "and" "andalso" "as" "case" "datatype"
- ;; "else" "end" "eqtype" "exception" "do" "fn" "fun" "functor"
- ;; "handle" "if" "in" "include" "infix" "infixr" "let" "local"
- ;; "nonfix" "of" "op" "open" "orelse" "overload" "raise" "rec"
- ;; "sharing" "sig" "signature" "struct" "structure" "then" "type"
- ;; "val" "where" "while" "with" "withtype") t)
- ("\\<\\(a\\(bstype\\|nd\\(\\|also\\)\\|s\\)\\|case\\|d\\(atatype\\|o\\)\\|\
-e\\(lse\\|nd\\|qtype\\|xception\\)\\|f\\(n\\|un\\(\\|ctor\\)\\)\\|\handle\\|\
-i\\([fn]\\|n\\(clude\\|fixr?\\)\\)\\|l\\(et\\|ocal\\)\\|nonfix\\|\
-o\\([fp]\\|pen\\|relse\\|verload\\)\\|r\\(aise\\|ec\\)\\|\
-s\\(haring\\|ig\\(\\|nature\\)\\|truct\\(\\|ure\\)\\)\\|t\\(hen\\|ype\\)\\|\
-val\\|w\\(h\\(ere\\|ile\\)\\|ith\\(\\|type\\)\\)\\)\\>"
- . font-lock-keyword-face))
+ (,sml-keywords-regexp . font-lock-keyword-face))
"Regexps matching standard SML keywords.")
-;; default faces values
-(defvar font-lock-function-def-face
- (if (facep 'font-lock-function-def-face)
- 'font-lock-function-name-face
- 'font-lock-function-name-face))
-(defvar font-lock-type-def-face
- (if (facep 'font-lock-type-def-face)
- 'font-lock-type-def-face
- 'font-lock-type-face))
-(defvar font-lock-module-def-face
- (if (facep 'font-lock-module-def-face)
- 'font-lock-module-def-face
- 'font-lock-function-name-face))
-(defvar font-lock-interface-def-face
- (if (facep 'font-lock-interface-def-face)
- 'font-lock-interface-def-face
- 'font-lock-type-face))
-(defvar font-lock-variable-def-face
- (if (facep 'font-lock-variable-def-face)
- 'font-lock-variable-def-face
- 'font-lock-variable-name-face))
-
-(defvar sml-font-lock-defaults
- '(sml-font-lock-keywords t nil nil nil))
-
-;; 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)))
+(defface font-lock-type-def-face
+ '((t (:bold t)))
+ "Font Lock mode face used to highlight type definitions."
+ :group 'font-lock-highlighting-faces)
+(defvar font-lock-type-def-face 'font-lock-type-def-face
+ "Face name to use for type definitions.")
+
+(defface font-lock-module-def-face
+ '((t (:bold t)))
+ "Font Lock mode face used to highlight module definitions."
+ :group 'font-lock-highlighting-faces)
+(defvar font-lock-module-def-face 'font-lock-module-def-face
+ "Face name to use for module definitions.")
+
+(defface font-lock-interface-def-face
+ '((t (:bold t)))
+ "Font Lock mode face used to highlight interface definitions."
+ :group 'font-lock-highlighting-faces)
+(defvar font-lock-interface-def-face 'font-lock-interface-def-face
+ "Face name to use for interface definitions.")
+
+;;;
+;;; Code to handle nested comments and unusual string escape sequences
+;;;
+
+(defsyntax sml-syntax-prop-table
+ '((?\\ . ".") (?* . "."))
+ "Syntax table for text-properties")
+
+;; For Emacsen that have no built-in support for nested comments
+(defun sml-get-depth-st ()
+ (save-excursion
+ (let* ((disp (if (eq (char-before) ?\)) (progn (backward-char) -1) nil))
+ (foo (backward-char))
+ (disp (if (eq (char-before) ?\() (progn (backward-char) 0) disp))
+ (pt (point)))
+ (when disp
+ (let* ((depth
+ (save-match-data
+ (if (re-search-backward "\\*)\\|(\\*" nil t)
+ (+ (or (get-char-property (point) 'comment-depth) 0)
+ (case (char-after) (?\( 1) (?* 0))
+ disp)
+ 0)))
+ (depth (if (> depth 0) depth)))
+ (put-text-property pt (1+ pt) 'comment-depth depth)
+ (when depth sml-syntax-prop-table))))))
+
+(defconst sml-font-lock-syntactic-keywords
+ `(("^\\s-*\\(\\\\\\)" (1 ',sml-syntax-prop-table))
+ ,@(unless sml-builtin-nested-comments-flag
+ '(("(?\\(\\*\\))?" (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)))
+
+;;;;
+;;;; Imenu support
+;;;;
+
+(defvar sml-imenu-regexp
+ (concat "^[ \t]*\\(let[ \t]+\\)?"
+ (regexp-opt (append sml-module-head-syms
+ '("and" "fun" "datatype" "abstype" "type")) t)
+ "\\>"))
+
+(defun sml-imenu-create-index ()
+ (let (alist)
+ (goto-char (point-max))
+ (while (re-search-backward sml-imenu-regexp nil t)
+ (save-excursion
+ (let ((kind (match-string 2))
+ (column (progn (goto-char (match-beginning 2)) (current-column)))
+ (location
+ (progn (goto-char (match-end 0)) (sml-forward-spaces) (point)))
+ (name (sml-forward-sym)))
+ ;; Eliminate trivial renamings.
+ (when (or (not (member kind '("structure" "signature")))
+ (progn (search-forward "=")
+ (sml-forward-spaces)
+ (looking-at "sig\\|struct")))
+ (push (cons (concat (make-string (/ column 2) ?\ ) name) location)
+ alist)))))
+ alist))
;;; MORE CODE FOR SML-MODE
-(defun sml-mode-version ()
- "This file's version number (sml-mode)."
- (interactive)
- (message sml-mode-version-string))
-
-(defvar sml-mode-syntax-table nil "The syntax table used in sml-mode.")
-(if sml-mode-syntax-table
- ()
- (setq sml-mode-syntax-table (make-syntax-table))
- ;; Set everything to be "." (punctuation) except for [A-Za-z0-9],
- ;; which will default to "w" (word-constituent).
- (let ((i 0))
- (while (< i ?0)
- (modify-syntax-entry i "." sml-mode-syntax-table)
- (setq i (1+ i)))
- (setq i (1+ ?9))
- (while (< i ?A)
- (modify-syntax-entry i "." sml-mode-syntax-table)
- (setq i (1+ i)))
- (setq i (1+ ?Z))
- (while (< i ?a)
- (modify-syntax-entry i "." sml-mode-syntax-table)
- (setq i (1+ i)))
- (setq i (1+ ?z))
- (while (< i 128)
- (modify-syntax-entry i "." sml-mode-syntax-table)
- (setq i (1+ i))))
-
- ;; Now we change the characters that are meaningful to us.
- (modify-syntax-entry ?\\ "\\" sml-mode-syntax-table)
- (modify-syntax-entry ?\( "()1" sml-mode-syntax-table)
- (modify-syntax-entry ?\) ")(4" sml-mode-syntax-table)
- (modify-syntax-entry ?\[ "(]" sml-mode-syntax-table)
- (modify-syntax-entry ?\] ")[" sml-mode-syntax-table)
- (modify-syntax-entry ?{ "(}" sml-mode-syntax-table)
- (modify-syntax-entry ?} "){" sml-mode-syntax-table)
- (modify-syntax-entry ?\* ". 23" sml-mode-syntax-table)
- (modify-syntax-entry ?\" "\"" sml-mode-syntax-table)
- (modify-syntax-entry ? " " sml-mode-syntax-table)
- (modify-syntax-entry ?\t " " sml-mode-syntax-table)
- (modify-syntax-entry ?\n " " sml-mode-syntax-table)
- (modify-syntax-entry ?\f " " sml-mode-syntax-table)
- (modify-syntax-entry ?\' "w" sml-mode-syntax-table)
- (modify-syntax-entry ?\_ "w" sml-mode-syntax-table))
-
;;;###Autoload
-(defun sml-mode ()
- "Major mode for editing ML code.
-Tab indents for ML code.
-Comments are delimited with (* ... *).
-Blank lines and form-feeds separate paragraphs.
-Delete converts tabs to spaces as it moves back.
-
-For information on running an inferior ML process, see the documentation
-for inferior-sml-mode (set this up with \\[sml]).
-
-Customisation: Entry to this mode runs the hooks on sml-mode-hook.
-
-Variables controlling the indentation
-=====================================
-
-Seek help (\\[describe-variable]) on individual variables to get current settings.
-
-sml-indent-level (default 4)
- The indentation of a block of code.
-
-sml-pipe-indent (default -2)
- Extra indentation of a line starting with \"|\".
-
-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 t)
- 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.
+(add-to-list 'auto-mode-alist '("\\.s\\(ml\\|ig\\)\\'" . sml-mode))
-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
-========
+;;;###Autoload
+(define-derived-mode sml-mode fundamental-mode "SML"
+ "\\<sml-mode-map>Major mode for editing ML code.
+This mode runs `sml-mode-hook' just before exiting.
\\{sml-mode-map}"
-
- (interactive)
- (kill-all-local-variables)
- (sml-mode-variables)
- (use-local-map sml-mode-map)
- (setq major-mode 'sml-mode)
- (setq mode-name "SML")
- (run-hooks 'sml-mode-hook)) ; Run the hook last
+ (set (make-local-variable 'font-lock-defaults) sml-font-lock-defaults)
+ (set (make-local-variable 'outline-regexp) sml-outline-regexp)
+ (set (make-local-variable 'imenu-create-index-function)
+ 'sml-imenu-create-index)
+ (set (make-local-variable 'add-log-current-defun-function)
+ 'sml-current-fun-name)
+ ;; forward-sexp-function is an experimental variable in my hacked Emacs.
+ (set (make-local-variable 'forward-sexp-function) 'sml-user-forward-sexp)
+ (sml-mode-variables))
(defun sml-mode-variables ()
(set-syntax-table sml-mode-syntax-table)
(set (make-local-variable 'indent-line-function) 'sml-indent-line)
(set (make-local-variable 'comment-start) "(* ")
(set (make-local-variable 'comment-end) " *)")
+ (set (make-local-variable 'comment-nested) t)
+ ;;(set (make-local-variable 'block-comment-start) "* ")
+ ;;(set (make-local-variable 'block-comment-end) "")
(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)
- (setq sml-error-overlay (and sml-error-overlay (sml-make-overlay))))
-
- ;; Adding these will fool the matching of parens -- because of a
- ;; bug in Emacs (in scan_lists, i think)... it would be nice to
- ;; have comments treated as white-space.
- ;;(make-local-variable 'parse-sexp-ignore-comments)
- ;;(setq parse-sexp-ignore-comments t)
-
-(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))))))
-
-(defconst sml-pipe-matchers-reg
- "\\bcase\\b\\|\\bfn\\b\\|\\bfun\\b\\|\\bhandle\\b\
-\\|\\bdatatype\\b\\|\\babstype\\b\\|\\band\\b"
- "The keywords a `|' can follow.")
+ (set (make-local-variable 'comment-start-skip) "(\\*+\\s-*")
+ (set (make-local-variable 'comment-indent-function) 'sml-comment-indent))
(defun sml-electric-pipe ()
- "Insert a \"|\".
+ "Insert a \"|\".
Depending on the context insert the name of function, a \"=>\" etc."
(interactive)
- (let ((case-fold-search nil) ; Case sensitive
- (here (point))
- (match (save-excursion
- (sml-find-matching-starter sml-pipe-matchers-reg)
- (point)))
- (tmp " => ")
- (case-or-handle-exp t))
- (if (/= (save-excursion (beginning-of-line) (point))
- (save-excursion (skip-chars-backward "\t ") (point)))
- (insert "\n"))
- (insert "|")
- (save-excursion
- (goto-char match)
- (cond
- ;; It was a function, insert the function name
- ((looking-at "fun\\b")
- (setq tmp (concat " " (buffer-substring
- (progn (forward-char 3)
- (skip-chars-forward "\t\n ") (point))
- (progn (forward-word 1) (point))) " "))
- (setq case-or-handle-exp nil))
- ;; It was a datatype, insert nothing
- ((looking-at "datatype\\b\\|abstype\\b")
- (setq tmp " ") (setq case-or-handle-exp nil))
- ;; If it is an and, then we have to see what is was
- ((looking-at "and\\b")
- (let (isfun)
- (save-excursion
- (condition-case ()
- (progn
- (re-search-backward "datatype\\b\\|abstype\\b\\|fun\\b")
- (setq isfun (looking-at "fun\\b")))
- (error (setq isfun nil))))
- (if isfun
- (progn
- (setq tmp
- (concat " " (buffer-substring
- (progn (forward-char 3)
- (skip-chars-forward "\t\n ") (point))
- (progn (forward-word 1) (point))) " "))
- (setq case-or-handle-exp nil))
- (setq tmp " ") (setq case-or-handle-exp nil))))))
- (insert tmp)
- (sml-indent-line)
- (beginning-of-line)
- (skip-chars-forward "\t ")
- (forward-char (1+ (length tmp)))
- (if case-or-handle-exp
- (forward-char -4))))
+ (sml-with-ist
+ (unless (save-excursion (skip-chars-backward "\t ") (bolp)) (insert "\n"))
+ (insert "| ")
+ (let ((text
+ (save-excursion
+ (backward-char 2) ;back over the just inserted "| "
+ (let ((sym (sml-find-matching-starter sml-pipeheads
+ (sml-op-prec "|" 'back))))
+ (sml-forward-sym)
+ (sml-forward-spaces)
+ (cond
+ ((string= sym "|")
+ (let ((f (sml-forward-sym)))
+ (sml-find-forward "\\(=>\\|=\\||\\)\\S.")
+ (cond
+ ((looking-at "|") "") ;probably a datatype
+ ((looking-at "=>") " => ") ;`case', or `fn' or `handle'
+ ((looking-at "=") (concat f " = "))))) ;a function
+ ((string= sym "and")
+ ;; could be a datatype or a function
+ (while (and (setq sym (sml-forward-sym))
+ (string-match "^'" sym))
+ (sml-forward-spaces))
+ (sml-forward-spaces)
+ (if (or (not sym)
+ (equal (sml-forward-sym) "d="))
+ ""
+ (concat sym " = ")))
+ ;; trivial cases
+ ((string= sym "fun")
+ (while (and (setq sym (sml-forward-sym))
+ (string-match "^'" sym))
+ (sml-forward-spaces))
+ (concat sym " = "))
+ ((member sym '("case" "handle" "fn" "of")) " => ")
+ ;;((member sym '("abstype" "datatype")) "")
+ (t ""))))))
+
+ (insert text)
+ (indent-according-to-mode)
+ (beginning-of-line)
+ (skip-chars-forward "\t |")
+ (skip-syntax-forward "w")
+ (skip-chars-forward "\t ")
+ (when (= ?= (char-after)) (backward-char)))))
(defun sml-electric-semi ()
- "Inserts a \;.
-If variable sml-electric-semi-mode is t, indent the current line, insert
+ "Insert a \;.
+If variable `sml-electric-semi-mode' is t, indent the current line, insert
a newline, and indent."
(interactive)
(insert "\;")
;;; INDENTATION !!!
(defun sml-mark-function ()
- "Synonym for mark-paragraph -- sorry.
+ "Synonym for `mark-paragraph' -- sorry.
If anyone has a good algorithm for this..."
(interactive)
(mark-paragraph))
-(defun sml-indent-region (begin end)
- "Indent region of ML code."
- (interactive "r")
- (message "Indenting region...")
- (save-excursion
- (goto-char end) (setq end (point-marker)) (goto-char begin)
- (while (< (point) end)
- (skip-chars-forward "\t\n ")
- (sml-indent-line)
- (end-of-line))
- (move-marker end nil))
- (message "Indenting region... done"))
+;; (defun sml-indent-region (begin end)
+;; "Indent region of ML code."
+;; (interactive "r")
+;; (message "Indenting region...")
+;; (save-excursion
+;; (goto-char end) (setq end (point-marker)) (goto-char begin)
+;; (while (< (point) end)
+;; (skip-chars-forward "\t\n ")
+;; (indent-according-to-mode)
+;; (end-of-line))
+;; (move-marker end nil))
+;; (message "Indenting region... done"))
(defun sml-indent-line ()
"Indent current line of ML code."
(interactive)
- (let ((indent (sml-calculate-indentation)))
- (if (/= (current-indentation) indent)
- (save-excursion ;; Added 890601 (point now stays)
- (let ((beg (progn (beginning-of-line) (point))))
- (skip-chars-forward "\t ")
- (delete-region beg (point))
- (indent-to indent))))
- ;; If point is before indentation, move point to indentation
- (if (< (current-column) (current-indentation))
- (skip-chars-forward "\t "))))
+ (let ((savep (> (current-column) (current-indentation)))
+ (indent (max (or (ignore-errors (sml-calculate-indentation)) 0) 0)))
+ (if savep
+ (save-excursion (indent-line-to indent))
+ (indent-line-to indent))))
(defun sml-back-to-outer-indent ()
"Unindents to the next outer level of indentation."
(setq indent 0))))
(backward-delete-char-untabify (- start-column indent)))))))
-(defconst sml-indent-starters-reg
- "abstraction\\b\\|abstype\\b\\|and\\b\\|case\\b\\|datatype\\b\
-\\|else\\b\\|fun\\b\\|functor\\b\\|if\\b\\|sharing\\b\
-\\|in\\b\\|infix\\b\\|infixr\\b\\|let\\b\\|local\\b\
-\\|nonfix\\b\\|of\\b\\|open\\b\\|raise\\b\\|sig\\b\\|signature\\b\
-\\|struct\\b\\|structure\\b\\|then\\b\\|\\btype\\b\\|val\\b\
-\\|while\\b\\|with\\b\\|withtype\\b"
- "The indentation starters. The next line will be indented.")
-
-(defconst sml-starters-reg
- "\\babstraction\\b\\|\\babstype\\b\\|\\bdatatype\\b\
-\\|\\bexception\\b\\|\\bfun\\b\\|\\bfunctor\\b\\|\\blocal\\b\
-\\|\\binfix\\b\\|\\binfixr\\b\\|\\bsharing\\b\
-\\|\\bnonfix\\b\\|\\bopen\\b\\|\\bsignature\\b\\|\\bstructure\\b\
-\\|\\btype\\b\\|\\bval\\b\\|\\bwithtype\\b\\|\\bwith\\b"
- "The starters of new expressions.")
-
-(defconst sml-end-starters-reg
- "\\blet\\b\\|\\blocal\\b\\|\\bsig\\b\\|\\bstruct\\b\\|\\bwith\\b"
- "Matching reg-expression for the \"end\" keyword.")
-
-(defconst sml-starters-indent-after
- "let\\b\\|local\\b\\|struct\\b\\|in\\b\\|sig\\b\\|with\\b"
- "Indent after these.")
+(defun sml-find-comment-indent ()
+ (save-excursion
+ (let ((depth 1))
+ (while (> depth 0)
+ (if (re-search-backward "(\\*\\|\\*)" nil t)
+ (cond
+ ((looking-at "*)") (incf depth))
+ ((looking-at comment-start-skip) (decf depth)))
+ (setq depth -1)))
+ (if (= depth 0)
+ (1+ (current-column))
+ nil))))
(defun sml-calculate-indentation ()
(save-excursion
- (let ((case-fold-search nil))
- (beginning-of-line)
- (if (bobp) ; Beginning of buffer
- 0 ; Indentation = 0
- (skip-chars-forward "\t ")
- (cond
- ;; Indentation for comments alone on a line, matches the
- ;; proper indentation of the next line. Search only for the
- ;; next "*)", not for the matching.
- ((looking-at "(\\*")
- (if (not (search-forward "*)" nil t))
- (error "Comment not ended."))
- (end-of-line)
- (skip-chars-forward "\n\t ")
- ;; If we are at eob, just indent 0
- (if (eobp) 0 (sml-calculate-indentation)))
- ;; Continued string ? (Added 890113 lbn)
- ((looking-at "\\\\")
- (save-excursion
- (if (save-excursion (previous-line 1)
- (beginning-of-line)
- (looking-at "[\t ]*\\\\"))
- (progn (previous-line 1) (current-indentation))
- (if (re-search-backward "[^\\\\]\"" nil t)
- (1+ (current-indentation))
- 0))))
- ;; Are we looking at a case expression ?
- ((looking-at "|.*=>")
- (sml-skip-block)
- (sml-re-search-backward "=>")
- ;; Dont get fooled by fn _ => in case statements (890726)
- ;; Changed the regexp a bit, so fn has to be first on line,
- ;; in order to let the loop continue (Used to be ".*\bfn....")
- ;; (900430).
- (let ((loop t))
- (while (and loop (save-excursion
- (beginning-of-line)
- (looking-at "[^ \t]+\\bfn\\b.*=>")))
- (setq loop (sml-re-search-backward "=>"))))
- (beginning-of-line)
- (skip-chars-forward "\t ")
- (cond
- ((looking-at "|") (current-indentation))
- ((looking-at "of\\b")
- (1+ (current-indentation)))
- ((looking-at "fn\\b") (1+ (current-indentation)))
- ((looking-at "handle\\b") (+ (current-indentation) 5))
- (t (+ (current-indentation) sml-pipe-indent))))
- ((looking-at "and\\b")
- (if (sml-find-matching-starter sml-starters-reg)
- (current-column)
- 0))
- ((looking-at "in\\b") ; Match the beginning let/local
- (sml-find-match-indent "in" "\\bin\\b" "\\blocal\\b\\|\\blet\\b"))
- ((looking-at "end\\b") ; Match the beginning
- (sml-find-match-indent "end" "\\bend\\b" sml-end-starters-reg))
- ((and sml-nested-if-indent (looking-at "else\\b"))
- (sml-re-search-backward "\\bif\\b\\|\\belse\\b")
- (current-indentation))
- ((looking-at "else\\b") ; Match the if
- (sml-find-match-indent "else" "\\belse\\b" "\\bif\\b" t))
- ((looking-at "then\\b") ; Match the if + extra indentation
- (+ (sml-find-match-indent "then" "\\bthen\\b" "\\bif\\b" t)
- sml-indent-level))
- ((looking-at "of\\b")
- (sml-re-search-backward "\\bcase\\b")
- (+ (current-column) 2))
- ((looking-at sml-starters-reg)
- (let ((start (point)))
- (sml-backward-sexp)
- (if (and (looking-at sml-starters-indent-after)
- (/= start (point)))
- (+ (if sml-type-of-indent
- (current-column)
- (if (progn (beginning-of-line)
- (skip-chars-forward "\t ")
- (looking-at "|"))
- (- (current-indentation) sml-pipe-indent)
- (current-indentation)))
- sml-indent-level)
- (beginning-of-line)
- (skip-chars-forward "\t ")
- (if (and (looking-at sml-starters-indent-after)
- (/= start (point)))
- (+ (if sml-type-of-indent
- (current-column)
- (current-indentation))
- sml-indent-level)
- (goto-char start)
- (if (sml-find-matching-starter sml-starters-reg)
- (current-column)
- 0)))))
- (t
- (let ((indent (sml-get-indent)))
- (cond
- ((looking-at "|")
- ;; Lets see if it is the follower of a function definition
- (if (sml-find-matching-starter
- "\\bfun\\b\\|\\bfn\\b\\|\\band\\b\\|\\bhandle\\b")
- (cond
- ((looking-at "fun\\b") (- (current-column) sml-pipe-indent))
- ((looking-at "fn\\b") (1+ (current-column)))
- ((looking-at "and\\b") (1+ (1+ (current-column))))
- ((looking-at "handle\\b") (+ (current-column) 5)))
- (+ indent sml-pipe-indent)))
- (t
- (if sml-paren-lookback ; Look for open parenthesis ?
- (max indent (sml-get-paren-indent))
- indent))))))))))
-
-(defun sml-get-indent ()
+ (beginning-of-line) (skip-chars-forward "\t ")
+ (sml-with-ist
+ ;; Indentation for comments alone on a line, matches the
+ ;; proper indentation of the next line.
+ (when (looking-at "(\\*") (sml-forward-spaces))
+ (let (data
+ (sml-point (point))
+ (sym (save-excursion (sml-forward-sym))))
+ (or
+ ;; allow the user to override the indentation
+ (when (looking-at (concat ".*" (regexp-quote comment-start)
+ "[ \t]*fixindent[ \t]*"
+ (regexp-quote comment-end)))
+ (current-indentation))
+
+ ;; continued comment
+ (and (looking-at "\\*") (sml-find-comment-indent))
+
+ ;; Continued string ? (Added 890113 lbn)
+ (and (looking-at "\\\\")
+ (save-excursion
+ (if (save-excursion (previous-line 1)
+ (beginning-of-line)
+ (looking-at "[\t ]*\\\\"))
+ (progn (previous-line 1) (current-indentation))
+ (if (re-search-backward "[^\\\\]\"" nil t)
+ (1+ (current-column))
+ 0))))
+
+ (and (setq data (assoc sym sml-close-paren))
+ (sml-indent-relative sym data))
+
+ (and (member (save-excursion (sml-forward-sym)) sml-starters-syms)
+ (let ((sym (unless (save-excursion (sml-backward-arg))
+ (sml-backward-spaces)
+ (sml-backward-sym))))
+ (if sym (sml-get-sym-indent sym)
+ ;; FIXME: this can take a *long* time !!
+ (sml-find-matching-starter sml-starters-syms)
+ (current-column))))
+
+ (and (string= sym "|") (sml-indent-pipe))
+
+ (sml-indent-arg)
+ (sml-indent-default))))))
+
+(defun sml-indent-relative (sym data)
(save-excursion
- (let ((case-fold-search nil))
- (beginning-of-line)
- (skip-chars-backward "\t\n; ")
- (if (looking-at ";") (sml-backward-sexp))
- (cond
- ((save-excursion (sml-backward-sexp) (looking-at "end\\b"))
- (- (current-indentation) sml-indent-level))
- (t
- (while (/= (current-column) (current-indentation))
- (sml-backward-sexp))
- (skip-chars-forward "\t |")
- (let ((indent (current-column)))
- (skip-chars-forward "\t (")
- (cond
- ;; a "let fun" or "let val"
- ((looking-at "let \\(fun\\|val\\)\\b")
- (+ (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 ".*\\bfn\\b.*=>")
- indent
- (+ indent sml-indent-level)))
- ;; else keep the same indentation as previous line
- (t indent))))))))
-
-(defun sml-get-paren-indent ()
+ (sml-forward-sym) (sml-backward-sexp nil)
+ (unless (second data) (sml-backward-spaces) (sml-backward-sym))
+ (+ (or (cdr (assoc sym sml-symbol-indent)) 0)
+ (sml-delegated-indent))))
+
+(defun sml-indent-pipe ()
+ (let ((sym (sml-find-matching-starter sml-pipeheads
+ (sml-op-prec "|" 'back))))
+ (when sym
+ (if (string= sym "|")
+ (if (sml-bolp) (current-column) (sml-indent-pipe))
+ (let ((pipe-indent (or (cdr (assoc "|" sml-symbol-indent)) -2)))
+ (when (member sym '("datatype" "abstype"))
+ (re-search-forward "="))
+ (sml-forward-sym)
+ (sml-forward-spaces)
+ (+ pipe-indent (current-column)))))))
+
+(defun sml-find-forward (re)
+ (sml-forward-spaces)
+ (while (and (not (looking-at re))
+ (progn
+ (or (ignore-errors (forward-sexp 1) t) (forward-char 1))
+ (sml-forward-spaces)
+ (not (looking-at re))))))
+
+(defun sml-indent-arg ()
+ (and (save-excursion (ignore-errors (sml-forward-arg)))
+ ;;(not (looking-at sml-not-arg-re))
+ ;; looks like a function or an argument
+ (sml-move-if (sml-backward-arg))
+ ;; an argument
+ (if (save-excursion (not (sml-backward-arg)))
+ ;; a first argument
+ (+ (current-column) sml-indent-args)
+ ;; not a first arg
+ (while (and (/= (current-column) (current-indentation))
+ (sml-move-if (sml-backward-arg))))
+ (unless (save-excursion (sml-backward-arg))
+ ;; all earlier args are on the same line
+ (sml-forward-arg) (sml-forward-spaces))
+ (current-column))))
+
+(defun sml-get-indent (data sym)
+ (let ((head-sym (pop data)) d)
+ (cond
+ ((not (listp data)) data)
+ ((setq d (member sym data)) (second d))
+ ((and (consp data) (not (stringp (car data)))) (car data))
+ (t sml-indent-level))))
+
+(defun sml-dangling-sym ()
(save-excursion
- (let ((levelpar 0) ; Level of "()"
- (levelcurl 0) ; Level of "{}"
- (levelsqr 0) ; Level of "[]"
- (backpoint (max (- (point) sml-paren-lookback) (point-min))))
- (catch 'loop
- (while (and (/= levelpar 1) (/= levelsqr 1) (/= levelcurl 1))
- (if (re-search-backward "[][{}()]" backpoint t)
- (if (not (sml-inside-comment-or-string-p))
- (cond
- ((looking-at "(") (setq levelpar (1+ levelpar)))
- ((looking-at ")") (setq levelpar (1- levelpar)))
- ((looking-at "\\[") (setq levelsqr (1+ levelsqr)))
- ((looking-at "\\]") (setq levelsqr (1- levelsqr)))
- ((looking-at "{") (setq levelcurl (1+ levelcurl)))
- ((looking-at "}") (setq levelcurl (1- levelcurl)))))
- (throw 'loop 0))) ; Exit with value 0
- (if (save-excursion
- (forward-char 1)
- (looking-at sml-indent-starters-reg))
- (1+ (+ (current-column) sml-indent-level))
- (1+ (current-column)))))))
-
-(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-skip-block ()
- (let ((case-fold-search nil))
- (sml-backward-sexp)
- (if (looking-at "end\\b")
- (progn
- (goto-char (sml-find-match-backward "end" "\\bend\\b"
- sml-end-starters-reg))
- (skip-chars-backward "\n\t "))
- ;; Here we will need to skip backward past if-then-else
- ;; and case-of expression. Please - tell me how !!
- )))
-
-(defun sml-find-match-backward (unquoted-this this match &optional start)
+ (and (not (sml-bolp))
+ (< (sml-point-after (end-of-line))
+ (sml-point-after (sml-forward-sym)
+ (sml-forward-spaces))))))
+
+(defun sml-delegated-indent ()
+ (if (sml-dangling-sym)
+ (sml-indent-default 'noindent)
+ (sml-move-if (backward-word 1)
+ (looking-at sml-agglomerate-re))
+ (current-column)))
+
+(defun sml-get-sym-indent (sym &optional style)
+ "Find the indentation for the SYM we're `looking-at'.
+If indentation is delegated, the point will be at the start of
+the parent at the end of this function.
+Optional argument STYLE is currently ignored"
+ (assert (equal sym (save-excursion (sml-forward-sym))))
(save-excursion
- (let ((case-fold-search nil)
- (level 1)
- (pattern (concat this "\\|" match)))
- (if start (goto-char start))
- (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))))
- (point))))
-
-(defun sml-find-match-indent (unquoted-this this match &optional indented)
+ (let ((delegate (assoc sym sml-close-paren))
+ (head-sym sym))
+ (when (and delegate (not (eval (third delegate))))
+ ;;(sml-find-match-backward sym delegate)
+ (sml-forward-sym) (sml-backward-sexp nil)
+ (setq head-sym
+ (if (second delegate)
+ (save-excursion (sml-forward-sym))
+ (sml-backward-spaces) (sml-backward-sym))))
+
+ (let ((idata (assoc head-sym sml-indent-rule)))
+ (when idata
+ ;;(if (or style (not delegate))
+ ;; normal indentation
+ (let ((indent (sml-get-indent idata sym)))
+ (when indent (+ (sml-delegated-indent) indent)))
+ ;; delgate indentation to the parent
+ ;;(sml-forward-sym) (sml-backward-sexp nil)
+ ;;(let* ((parent-sym (save-excursion (sml-forward-sym)))
+ ;; (parent-indent (cdr (assoc parent-sym sml-indent-starters))))
+ ;; check the special rules
+ ;;(+ (sml-delegated-indent)
+ ;; (or (sml-get-indent indent-data 1 'strict)
+ ;; (sml-get-indent parent-indent 1 'strict)
+ ;; (sml-get-indent indent-data 0)
+ ;; (sml-get-indent parent-indent 0))))))))
+ )))))
+
+(defun sml-indent-default (&optional noindent)
+ (let* ((sym-after (save-excursion (sml-forward-sym)))
+ (_ (sml-backward-spaces))
+ (sym-before (sml-backward-sym))
+ (sym-indent (and sym-before (sml-get-sym-indent sym-before))))
+ (if sym-indent
+ ;; the previous sym is an indentation introducer: follow the rule
+ (let ((indent-after (or (cdr (assoc sym-after sml-symbol-indent)) 0)))
+ (if noindent
+ ;;(current-column)
+ sym-indent
+ (+ sym-indent indent-after)))
+ ;; default-default
+ (let* ((prec-after (sml-op-prec sym-after 'back))
+ (prec (or (sml-op-prec sym-before 'back) prec-after 100)))
+ ;; go back until you hit a symbol that has a lower prec than the
+ ;; "current one", or until you backed over a sym that has the same prec
+ ;; but is at the beginning of a line.
+ (while (and (not (sml-bolp))
+ (sml-move-if (sml-backward-sexp (1- prec)))
+ (not (sml-bolp)))
+ (while (sml-move-if (sml-backward-sexp prec))))
+ ;; the `noindent' case does back over an introductory symbol
+ ;; such as `fun', ...
+ (when noindent
+ (sml-move-if
+ (sml-backward-spaces)
+ (member (sml-backward-sym) sml-starters-syms)))
+ (current-column)))))
+
+
+(defun sml-bolp ()
(save-excursion
- (goto-char (sml-find-match-backward unquoted-this this match))
- (if (or sml-type-of-indent indented)
- (current-column)
- (if (progn
- (beginning-of-line)
- (skip-chars-forward "\t ")
- (looking-at "|"))
- (- (current-indentation) sml-pipe-indent)
- (current-indentation)))))
-
-(defun sml-find-matching-starter (regexp)
- (let ((case-fold-search nil)
- (start-let-point (sml-point-inside-let-etc))
- (start-up-list (sml-up-list))
- (found t))
- (if (sml-re-search-backward regexp)
- (progn
- (condition-case ()
- (while (or (/= start-up-list (sml-up-list))
- (/= start-let-point (sml-point-inside-let-etc)))
- (re-search-backward regexp))
- (error (setq found nil)))
- found)
- nil)))
-
-(defun sml-point-inside-let-etc ()
- (let ((case-fold-search nil) (last nil) (loop t) (found t) (start (point)))
- (save-excursion
- (while loop
- (condition-case ()
- (progn
- (re-search-forward "\\bend\\b")
- (while (sml-inside-comment-or-string-p)
- (re-search-forward "\\bend\\b"))
- (forward-char -3)
- (setq last (sml-find-match-backward "end" "\\bend\\b"
- sml-end-starters-reg last))
- (if (< last start)
- (setq loop nil)
- (forward-char 3)))
- (error (progn (setq found nil) (setq loop nil)))))
- (if found
- last
- 0))))
-
-(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-up-list ()
+ (skip-chars-backward " \t|") (bolp)))
+
+
+;; maybe `|' should be set to word-syntax in our temp syntax table ?
+(defun sml-current-indentation ()
+ (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward " \t|")
+ (current-column)))
+
+
+(defun sml-find-matching-starter (syms &optional prec)
+ (let (sym)
+ (ignore-errors
+ (while
+ (progn (sml-backward-sexp prec)
+ (setq sym (save-excursion (sml-forward-sym)))
+ (not (or (member sym syms) (bobp)))))
+ (unless (bobp) sym))))
+
+(defun sml-skip-siblings ()
+ (while (and (not (bobp)) (sml-backward-arg))
+ (sml-find-matching-starter sml-starters-syms))
+ (when (looking-at "in\\>\\|local\\>")
+ ;;skip over `local...in' and continue
+ (forward-word 1)
+ (sml-backward-sexp nil)
+ (sml-skip-siblings)))
+
+(defun sml-beginning-of-defun ()
+ (let ((sym (sml-find-matching-starter sml-starters-syms)))
+ (if (member sym '("fun" "and" "functor" "signature" "structure"
+ "abstraction" "datatype" "abstype"))
+ (save-excursion (sml-forward-sym) (sml-forward-spaces)
+ (sml-forward-sym))
+ ;; We're inside a "non function declaration": let's skip all other
+ ;; declarations that we find at the same level and try again.
+ (sml-skip-siblings)
+ ;; Obviously, let's not try again if we're at bobp.
+ (unless (bobp) (sml-beginning-of-defun)))))
+
+(defcustom sml-max-name-components 3
+ "Maximum number of components to use for the current function name."
+ :group 'sml
+ :type 'integer)
+
+(defun sml-current-fun-name ()
(save-excursion
- (condition-case ()
- (progn
- (up-list 1)
- (point))
- (error 0))))
-
-(defun sml-backward-sexp ()
- (condition-case ()
- (progn
- (let ((start (point)))
- (backward-sexp 1)
- (while (and (/= start (point)) (looking-at "(\\*"))
- (setq start (point))
- (backward-sexp 1))))
- (error (forward-char -1))))
+ (let ((count sml-max-name-components)
+ fullname name)
+ (end-of-line)
+ (while (and (> count 0)
+ (setq name (sml-beginning-of-defun)))
+ (decf count)
+ (setq fullname (if fullname (concat name "." fullname) name))
+ ;; Skip all other declarations that we find at the same level.
+ (sml-skip-siblings))
+ fullname)))
+
(defun sml-comment-indent ()
(if (looking-at "^(\\*") ; Existing comment at beginning
0 ; of line stays there.
- (save-excursion
- (skip-chars-backward " \t")
- (max (1+ (current-column)) ; Else indent at comment column
- comment-column)))) ; except leave at least one space.
-
-;;; INSERTING PROFORMAS (COMMON SML-FORMS)
+ comment-column))
-(defvar sml-forms-alist
- '(("let") ("local") ("case") ("abstype") ("datatype")
- ("signature") ("structure") ("functor"))
- "*The list of templates to auto-insert.
+;;; INSERTING PROFORMAS (COMMON SML-FORMS)
-You can extend this alist to your heart's content. For each additional
+(defvar sml-forms-alist nil
+ "*Alist of code templates.
+You can extend this alist to your heart's content. For each additional
template NAME in the list, declare a keyboard macro or function (or
interactive command) called 'sml-form-NAME'.
-
If 'sml-form-NAME' is a function it takes no arguments and should
insert the template at point\; if this is a command it may accept any
sensible interactive call arguments\; keyboard macros can't take
-arguments at all. Apropos keyboard macros, see `name-last-kbd-macro'
+arguments at all. Apropos keyboard macros, see `name-last-kbd-macro'
and `sml-addto-forms-alist'.
-
`sml-forms-alist' understands let, local, case, abstype, datatype,
signature, structure, and functor by default.")
+(defmacro sml-def-skeleton (name interactor &rest elements)
+ (let ((fsym (intern (concat "sml-form-" name))))
+ `(progn
+ (add-to-list 'sml-forms-alist ',(cons name fsym))
+ (define-abbrev sml-mode-abbrev-table ,name "" ',fsym)
+ (define-skeleton ,fsym
+ ,(format "SML-mode skeleton for `%s..' expressions" name)
+ ,interactor
+ ,(concat name " ") >
+ ,@elements))))
+(put 'sml-def-skeleton 'lisp-indent-function 2)
+
+(sml-def-skeleton "let" nil
+ _ "\nin" > "\nend" >)
+
+(sml-def-skeleton "if" nil
+ _ " then " > "\nelse " >)
+
+(sml-def-skeleton "local" nil
+ _ "\nin" > "\nend" >)
+
+(sml-def-skeleton "case" "Case expr: "
+ str "\nof " > _ " => ")
+
+(sml-def-skeleton "signature" "Signature name: "
+ str " =\nsig" > "\n" > _ "\nend" >)
+
+(sml-def-skeleton "structure" "Structure name: "
+ str " =\nstruct" > "\n" > _ "\nend" >)
+
+(sml-def-skeleton "functor" "Functor name: "
+ str " () : =\nstruct" > "\n" > _ "\nend" >)
+
+(sml-def-skeleton "datatype" "Datatype name and type params: "
+ str " =" \n)
+
+(sml-def-skeleton "abstype" "Abstype name and type params: "
+ str " =" \n _ "\nwith" > "\nend" >)
+
+;;
+
+(sml-def-skeleton "struct" nil
+ _ "\nend" >)
+
+(sml-def-skeleton "sig" nil
+ _ "\nend" >)
+
+(sml-def-skeleton "val" nil
+ _ " = " >)
+
+(sml-def-skeleton "fn" nil
+ _ " =>" >)
+
+(sml-def-skeleton "fun" nil
+ _ " =" >)
+
+;;
+
+(defun sml-forms-menu (menu)
+ (easy-menu-filter-return
+ (easy-menu-create-menu "Forms"
+ (mapcar (lambda (x)
+ (let ((name (car x))
+ (fsym (cdr x)))
+ (vector name fsym t)))
+ sml-forms-alist))))
+
+(defvar sml-last-form "let")
+
+(defun sml-electric-space ()
+ "Expand a symbol into an SML form, or just insert a space.
+If the point directly precedes a symbol for which an SML form exists,
+the corresponding form is inserted."
+ (interactive)
+ (let ((abbrev-mode (not abbrev-mode))
+ (last-command-char ?\ )
+ ;; Bind `this-command' to fool skeleton's special abbrev handling.
+ (this-command 'self-insert-command))
+ (call-interactively 'self-insert-command)))
+
+(defun sml-insert-form (name newline)
+ "Interactive short-cut to insert the NAME common ML form.
+If a prefix argument is given insert a NEWLINE and indent first, or
+just move to the proper indentation if the line is blank\; otherwise
+insert at point (which forces indentation to current column).
+
+The default form to insert is 'whatever you inserted last time'
+\(just hit return when prompted\)\; otherwise the command reads with
+completion from `sml-forms-alist'."
+ (interactive
+ (list (completing-read
+ (format "Form to insert: (default %s) " sml-last-form)
+ sml-forms-alist nil t nil)
+ current-prefix-arg))
+ ;; default is whatever the last insert was...
+ (if (string= name "") (setq name sml-last-form) (setq sml-last-form name))
+ (unless (or (not newline)
+ (save-excursion (beginning-of-line) (looking-at "\\s-*$")))
+ (insert "\n"))
+ (unless (/= ?w (char-syntax (char-before))) (insert " "))
+ (let ((f (cdr (assoc name sml-forms-alist))))
+ (cond
+ ((commandp f) (command-execute f))
+ (f (funcall f))
+ (t (error "Undefined form: %s" name)))))
+
;; See also macros.el in emacs lisp dir.
(defun sml-addto-forms-alist (name)
"Assign a name to the last keyboard macro defined.
Argument NAME is transmogrified to sml-form-NAME which is the symbol
-actually defined.
+actually defined.
The symbol's function definition becomes the keyboard macro string.
If that works, NAME is added to `sml-forms-alist' so you'll be able to
-reinvoke the macro through \\[sml-insert-form]. You might want to save
+reinvoke the macro through \\[sml-insert-form]. You might want to save
the macro to use in a later editing session -- see `insert-kbd-macro'
and add these macros to your .emacs file.
See also `edit-kbd-macro' which is bound to \\[edit-kbd-macro]."
(interactive "sName for last kbd macro (\"sml-form-\" will be added): ")
- (if (string-equal name "")
- (error "No command name given")
- (name-last-kbd-macro (intern (concat "sml-form-" name)))
- (message (concat "Macro bound to sml-form-" name))
- (or (assoc name sml-forms-alist)
- (setq sml-forms-alist (cons (list name) sml-forms-alist)))))
-
-;; at a pinch these could be added to SML/Forms menu through the good
-;; offices of activate-menubar-hook or something... but documentation
-;; of this and/or menu-bar-update-hook is sparse in 19.33. anyway, use
-;; completing read for sml-insert-form prompt...
-
-(defvar sml-last-form "let"
- "The most recent sml form inserted.")
-
-(defun sml-insert-form (arg)
- "Interactive short-cut to insert a common ML form.
-If a perfix argument is given insert a newline and indent first, or
-just move to the proper indentation if the line is blank\; otherwise
-insert at point (which forces indentation to current column).
+ (when (string= name "") (error "No command name given"))
+ (let ((fsym (intern (concat "sml-form-" name))))
+ (name-last-kbd-macro fsym)
+ (message "Macro bound to %s" fsym)
+ (add-to-list 'sml-forms-alist (cons name fsym))))
+
+;;;;
+;;;; SML/NJ's Compilation Manager support
+;;;;
+
+;;;###autoload
+(add-to-list 'completion-ignored-extensions "CM/")
+;;;###autoload
+(add-to-list 'auto-mode-alist '("\\.cm\\'" . sml-cm-mode))
+;;;###autoload
+(define-generic-mode 'sml-cm-mode
+ '(("(*" . "*)"))
+ '("library" "Library" "LIBRARY" "group" "Group" "GROUP" "is" "IS"
+ "structure" "functor" "signature" "funsig")
+ nil '("\\.cm\\'")
+ (list (lambda () (local-set-key "\C-c\C-c" 'sml-compile)))
+ "Generic mode for SML/NJ's Compilation Manager configuration files.")
+
+;;;;
+;;;; ML-Yacc (and ML-lex) support
+;;;;
+
+;; That seems to be good enough for now ;-)
+;;;###autoload
+(define-derived-mode sml-lex-mode sml-mode "SML-Lex")
+
+(defface sml-yacc-bnf-face
+ '((t (:foreground "darkgreen")))
+ "Face used to highlight (non)terminals in `sml-yacc-mode'.")
+(defvar sml-yacc-bnf-face 'sml-yacc-bnf-face)
+
+(defcustom sml-yacc-indent-action 16
+ "Indentation column of the opening paren of actions."
+ :group 'sml
+ :type 'integer)
+
+(defcustom sml-yacc-indent-pipe nil
+ "Indentation column of the pipe char in the BNF.
+If nil, align it with `:' or with previous cases."
+ :group 'sml
+ :type 'integer)
+
+(defcustom sml-yacc-indent-term nil
+ "Indentation column of the (non)term part.
+If nil, align it with previous cases."
+ :group 'sml
+ :type 'integer)
+
+(defvar sml-yacc-font-lock-keywords
+ (cons '("^\\(\\sw+\\s-*:\\|\\s-*|\\)\\(\\s-*\\sw+\\)*"
+ (0 (save-excursion
+ (save-match-data
+ (goto-char (match-beginning 0))
+ (unless (or (re-search-forward "\\<of\\>" (match-end 0) 'move)
+ (progn (sml-forward-spaces)
+ (not (looking-at "("))))
+ sml-yacc-bnf-face)))))
+ sml-font-lock-keywords))
+(defconst sml-yacc-font-lock-defaults
+ (cons sml-yacc-font-lock-keywords (cdr sml-font-lock-defaults)))
+
+(defun sml-yacc-bnf-p ()
+
-The default form to insert is 'whatever you inserted last time'
-\(just hit return when prompted\)\; otherwise the command reads with
-completion from `sml-forms-alist'."
- (interactive "P")
- (let ((name (completing-read
- (format "Form to insert: (default %s) " sml-last-form)
- sml-forms-alist nil t nil)))
- ;; default is whatever the last insert was...
- (if (string= name "") (setq name sml-last-form))
- (setq sml-last-form name)
- (if arg
- (if (save-excursion (beginning-of-line) (looking-at "[ \t]*$"))
- (sml-indent-line)
- (newline-and-indent)))
- (cond ((string= name "let") (sml-form-let))
- ((string= name "local") (sml-form-local))
- ((string= name "case") (sml-form-case))
- ((string= name "abstype") (sml-form-abstype))
- ((string= name "datatype") (sml-form-datatype))
- ((string= name "functor") (sml-form-functor))
- ((string= name "structure") (sml-form-structure))
- ((string= name "signature") (sml-form-signature))
- (t
- (let ((template (intern (concat "sml-form-" name))))
- (if (fboundp template)
- (if (commandp template)
- ;; it may be a named kbd macro too
- (command-execute template)
- (funcall template))
- (error
- (format "Undefined format function: %s" template))))))))
-
-(defun sml-form-let ()
- "Insert a `let in end' template."
- (interactive)
- (sml-let-local "let"))
+(defun sml-yacc-indent-line ()
+ "Indent current line of ML-Yacc code."
+ (let ((savep (> (current-column) (current-indentation)))
+ (indent (max (or (ignore-errors (sml-yacc-indentation)) 0) 0)))
+ (if savep
+ (save-excursion (indent-line-to indent))
+ (indent-line-to indent))))
-(defun sml-form-local ()
- "Insert a `local in end' template."
- (interactive)
- (sml-let-local "local"))
-
-(defun sml-let-local (starter)
- "Insert a let or local template, depending on STARTER string."
- (let ((indent (current-column)))
- (insert starter)
- (insert "\n") (indent-to (+ sml-indent-level indent))
- (save-excursion ; so point returns here
- (insert "\n")
- (indent-to indent)
- (insert "in\n")
- (indent-to (+ sml-indent-level indent))
- (insert "\n")
- (indent-to indent)
- (insert "end"))))
-
-(defun sml-form-case ()
- "Insert a case expression template, prompting for the case-expresion."
- (interactive)
- (let ((expr (read-string "Case expr: "))
- (indent (current-column)))
- (insert (concat "case " expr))
- (if sml-case-indent
- (progn
- (insert "\n")
- (indent-to (+ 2 indent))
- (insert "of "))
- (insert " of\n")
- (indent-to (+ indent sml-indent-level)))
- (save-excursion (insert " => "))))
-
-(defun sml-form-signature ()
- "Insert a generative signature binding, prompting for the name."
- (interactive)
- (let ((indent (current-column))
- (name (read-string "Signature name: ")))
- (insert (concat "signature " name " ="))
- (insert "\n")
- (indent-to (+ sml-structure-indent indent))
- (insert "sig\n")
- (indent-to (+ sml-structure-indent sml-indent-level indent))
- (save-excursion
- (insert "\n")
- (indent-to (+ sml-structure-indent indent))
- (insert "end"))))
-
-(defun sml-form-structure ()
- "Insert a generative structure binding, prompting for the name.
-The command also prompts for any signature constraint -- you should
-specify \":\" or \":>\" and the constraining signature."
- (interactive)
- (let ((indent (current-column))
- (name (read-string (concat "Structure name: ")))
- (signame (read-string "Signature constraint (default none): ")))
- (insert (concat "structure " name " "))
- (insert (if (string= "" signame) "=" (concat signame " =")))
- (insert "\n")
- (indent-to (+ sml-structure-indent indent))
- (insert "struct\n")
- (indent-to (+ sml-structure-indent sml-indent-level indent))
- (save-excursion
- (insert "\n")
- (indent-to (+ sml-structure-indent indent))
- (insert "end"))))
-
-(defun sml-form-functor ()
- "Insert a genarative functor binding, prompting for the name.
-The command also prompts for the required signature constraint -- you
-should specify \":\" or \":>\" and the constraining signature."
- (interactive)
- (let ((indent(current-indentation))
- (name (read-string "Name of functor: "))
- (signame (read-string "Signature constraint: " ":" )))
- (insert (concat "functor " name " () " signame " ="))
- (insert "\n")
- (indent-to (+ sml-structure-indent indent))
- (insert "struct\n")
- (indent-to (+ sml-structure-indent sml-indent-level indent))
- (save-excursion ; return to () instead?
- (insert "\n")
- (indent-to (+ sml-structure-indent indent))
- (insert "end"))))
-
-(defun sml-form-datatype ()
- "Insert a datatype declaration, prompting for name and type parameter."
- (interactive)
- (let ((indent (current-indentation))
- (type (read-string "Datatype type parameter (default none): "))
- (name (read-string (concat "Name of datatype: "))))
- (insert (concat "datatype "
- (if (string= type "") "" (concat type " "))
- name " ="))
- (insert "\n")
- (indent-to (+ sml-indent-level indent))))
-
-(defun sml-form-abstype ()
- "Insert an abstype declaration, prompting for name and type parameter."
- (interactive)
- (let ((indent(current-indentation))
- (type (read-string "Abstype type parameter (default none): "))
- (name (read-string "Name of abstype: ")))
- (insert (concat "abstype "
- (if (string= type "") "" (concat type " "))
- name " ="))
- (insert "\n")
- (indent-to (+ sml-indent-level indent))
- (save-excursion
- (insert "\n")
- (indent-to indent)
- (insert "with\n")
- (indent-to (+ sml-indent-level indent))
- (insert "\n")
- (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.
+(defun sml-yacc-indentation ()
+ (save-excursion
+ (back-to-indentation)
+ (or (and (looking-at "%\\|\\(\\sw\\|\\s_\\)+\\s-*:") 0)
+ (when (save-excursion
+ (condition-case nil (progn (up-list -1) nil) (scan-error t)))
+ ;; We're outside an action.
+ (cond
+ ;; Special handling of indentation inside %term and %nonterm
+ ((save-excursion
+ (and (re-search-backward "^%\\(\\sw+\\)" nil t)
+ (member (match-string 1) '("term" "nonterm"))))
+ (if (numberp sml-yacc-indent-term) sml-yacc-indent-term
+ (let ((offset (if (looking-at "|") -2 0)))
+ (forward-line -1)
+ (looking-at "\\s-*\\(%\\sw*\\||\\)?\\s-*")
+ (goto-char (match-end 0))
+ (+ offset (current-column)))))
+ ((looking-at "(") sml-yacc-indent-action)
+ ((looking-at "|")
+ (if (numberp sml-yacc-indent-pipe) sml-yacc-indent-pipe
+ (backward-sexp 1)
+ (while (progn (sml-backward-spaces)
+ (/= 0 (skip-syntax-backward "w_"))))
+ (sml-backward-spaces)
+ (if (not (looking-at "\\s-$"))
+ (1- (current-column))
+ (skip-syntax-forward " ")
+ (- (current-column) 2))))))
+ ;; default to SML rules
+ (sml-calculate-indentation))))
+
+;;;###autoload
+(add-to-list 'auto-mode-alist '("\\.grm\\'" . sml-yacc-mode))
+;;;###autoload
+(define-derived-mode sml-yacc-mode sml-mode "SML-Yacc"
+ (set (make-local-variable 'indent-line-function) 'sml-yacc-indent-line)
+ (set (make-local-variable 'font-lock-defaults) sml-yacc-font-lock-defaults))
+
+(provide 'sml-mode)
+
+;;; sml-mode.el ends here