diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/authors.el | 82 | ||||
| -rw-r--r-- | lisp/emacs-lisp/autoload.el | 150 | ||||
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 40 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-extra.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-loaddefs.el | 7 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 63 | ||||
| -rw-r--r-- | lisp/emacs-lisp/derived.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/easy-mmode.el | 80 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eldoc.el | 14 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp-mnt.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp-mode.el | 17 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp.el | 41 | ||||
| -rw-r--r-- | lisp/emacs-lisp/smie.el | 877 |
13 files changed, 1220 insertions, 159 deletions
diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index 7728215bb91..020729e2c76 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -220,6 +220,9 @@ If REALNAME is nil, ignore that author.") '("vc-\\*\\.el$" "spec.txt$" ".*loaddefs.el$" ; not obsolete, but auto-generated + "\\.\\(cvs\\|git\\)ignore$" ; obsolete or uninteresting + "\\.arch-inventory$" + "preferences\\.\\(nib\\|gorm\\)" "vc-\\(rcs\\|cvs\\|sccs\\)-hooks\\.el$") "List of regexps matching obsolete files. Changes to files matching one of the regexps in this list are not @@ -244,6 +247,14 @@ listed.") "Imakefile" "icons/sink.ico" "aixcc.lex" "nxml/char-name/unicode" "js2-mode.el" ; only installed very briefly, replaced by js.el + "cedet/tests/testtemplates.cpp" + "cedet/tests/testusing.cpp" + "cedet/tests/scopetest.cpp" + "cedet/tests/scopetest.java" + "cedet/tests/test.cpp" + "cedet/tests/test.py" + "cedet/tests/teststruct.cpp" + "*.el" ;; Autogen: "cus-load.el" "finder-inf.el" "ldefs-boot.el" ;; Never had any meaningful changes logged, now deleted: @@ -255,7 +266,7 @@ listed.") "3B-MAXMEM" "AIX.DUMP" "SUN-SUPPORT" "XENIX" "CODINGS" "CHARSETS" "calc/INSTALL" "calc/Makefile" - "vms-pp.trans" "_emacs" "batcomp.com" + "vms-pp.trans" "_emacs" "batcomp.com" "notes/cpp" ; admin/ ;; MH-E stuff not in Emacs: "import-emacs" "release-utils" ;; Erc stuff not in Emacs: @@ -286,6 +297,42 @@ listed.") "List of files and directories to ignore. Changes to files in this list are not listed.") +;; List via: find . -name '*.el' | sed 's/.*\///g' | sort | uniq -d +;; FIXME It would be better to discover these dynamically. +;; Note that traditionally "Makefile.in" etc have not been in this list. +;; Ditto for "abbrev.texi" etc. +(defconst authors-ambiguous-files + '("chart.el" + "compile.el" + "complete.el" + "cpp.el" + "ctxt.el" + "debug.el" + "dired.el" + "el.el" + "files.el" + "find.el" + "format.el" + "grep.el" + "imenu.el" + "java.el" + "linux.el" + "locate.el" + "make.el" + "mode.el" + "python.el" + "semantic.el" + "shell.el" + "simple.el" + "sort.el" + "speedbar.el" + "srecode.el" + "table.el" + "texi.el" + "util.el" + "wisent.el") + "List of basenames occurring more than once in the source.") + ;; FIXME :cowrote entries here can be overwritten by :wrote entries ;; derived from a file's Author: header (eg mh-e). This really means ;; the Author: header is erroneous. @@ -427,6 +474,7 @@ Changes to files in this list are not listed.") ("Geoff Voelker" :wrote "w32-fns.el" "w32.c" "w32.h" "w32heap.c" "w32heap.h" "w32inevt.c" "w32proc.c" "w32term.c" "ms-w32.h") ("Morten Welinder" :wrote "dosfns.c" "[many MS-DOS files]" "msdos.h") + ("Eli Zaretskii" :wrote "bidi.c" "[bidirectional display in xdisp.c]") ;; Not using this version any more. ;;; ("Pace Willisson" :wrote "ispell.el") ;; FIXME overwritten by Author:. @@ -457,17 +505,21 @@ Changes to files in this list are not listed.") "getdate.y" "ymakefile" "permute-index" "index.perm" + "ibmrs6000.inp" "emacs.ico" "emacs21.ico" "LPF" "LEDIT" "OTHER.EMACSES" "emacs16_mac.png" "emacs24_mac.png" "emacs256_mac.png" "emacs32_mac.png" "emacs48_mac.png" "emacs512_mac.png" + "revdiff" ; admin/ + "mainmake" "sed1.inp" "sed2.inp" "sed3.inp" ; msdos/ + "mac-fix-env.m" ;; Deleted vms stuff: "temacs.opt" "descrip.mms" "compile.com" "link.com" ) - "File names which are valid, but no longer exist (or cannot be -found) in the repository.") + "File names which are valid, but no longer exist (or cannot be found) +in the repository.") (defconst authors-renamed-files-alist '(("nt.c" . "w32.c") ("nt.h" . "w32.h") @@ -504,6 +556,7 @@ found) in the repository.") ;; index and pick merged into search. ("mh-index.el" . "mh-search.el") ("mh-pick.el" . "mh-search.el") + ("font-setting.el" . "dynamic-setting.el") ;; INSTALL-CVS -> .CVS -> .BZR ("INSTALL-CVS" . "INSTALL.BZR") ("INSTALL.CVS" . "INSTALL.BZR") @@ -529,6 +582,7 @@ found) in the repository.") ("schema/docbook-dyntbl.rnc" . "schema/docbk-dyntbl.rnc") ("schema/docbook-soextbl.rnc" . "schema/docbk-soextbl.rn" ) ("texi/url.txi" . "url.texi") + ("edt-user.doc" . "edt.texi") ;; Moved to different directories. ("ctags.1" . "ctags.1") ("etags.1" . "etags.1") @@ -573,10 +627,25 @@ Otherwise, the file name is accepted as is.") (defvar authors-checked-files-alist) (defvar authors-invalid-file-names) +(defun authors-disambiguate-file-name (fullname) + "Convert FULLNAME to an unambiguous relative-name." + (let ((relname (file-name-nondirectory fullname)) + parent) + (if (member relname authors-ambiguous-files) + ;; In case of ambiguity, just prepend the parent directory. + ;; FIXME obviously this is not a perfect solution. + (if (string-equal "lisp" + (setq parent (file-name-nondirectory + (directory-file-name + (file-name-directory fullname))))) + relname + (format "%s/%s" parent relname)) + relname))) + (defun authors-canonical-file-name (file log-file pos author) "Return canonical file name for FILE found in LOG-FILE. Checks whether FILE is a valid (existing) file name, has been renamed, -or is on the list of removed files. Returns the non-diretory part of +or is on the list of removed files. Returns the non-directory part of the file name. Only uses the LOG-FILE position POS and associated AUTHOR to print a message if FILE is not found." ;; FILE should be re-checked in every different directory associated @@ -593,7 +662,7 @@ to print a message if FILE is not found." (file-exists-p file) (file-exists-p relname) (file-exists-p (concat "etc/" relname))) - (setq valid relname) + (setq valid (authors-disambiguate-file-name fullname)) (setq valid (assoc file authors-renamed-files-alist)) (if valid (setq valid (cdr valid)) @@ -610,6 +679,7 @@ to print a message if FILE is not found." (cons (cons fullname valid) authors-checked-files-alist)) (unless (or valid (member file authors-ignored-files) + (authors-obsolete-file-p file) (string-match "[*]" file) (string-match "^[0-9.]+$" file)) (setq authors-invalid-file-names @@ -758,7 +828,7 @@ TABLE is a hash table to add author information to." (enable-local-variables :safe) ; for find-file, hence let* (enable-local-eval nil) (buffer (find-file-noselect file))) - (setq file (file-name-nondirectory file)) + (setq file (authors-disambiguate-file-name (expand-file-name file))) (with-current-buffer buffer (save-restriction (widen) diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index c985aae07b6..c5316d06429 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1,7 +1,8 @@ ;; autoload.el --- maintain autoloads in loaddefs.el ;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> ;; Keywords: maint @@ -258,14 +259,17 @@ put the output in." TYPE (default \"autoloads\") is a string stating the type of information contained in FILE. If FEATURE is non-nil, FILE will provide a feature. FEATURE may be a string naming the -feature, otherwise it will be based on FILE's name." +feature, otherwise it will be based on FILE's name. + +At present, a feature is in fact always provided, but this should +not be relied upon." (let ((basename (file-name-nondirectory file))) (concat ";;; " basename " --- automatically extracted " (or type "autoloads") "\n" ";;\n" ";;; Code:\n\n" " \n" - ;; This is used outside of autoload.el. + ;; This is used outside of autoload.el, eg cus-dep, finder. "(provide '" (if (stringp feature) feature @@ -324,7 +328,29 @@ which lists the file name and which functions are in it, etc." "File local variable to prevent scanning this file for autoload cookies.") (defun autoload-file-load-name (file) - (let ((name (file-name-nondirectory file))) + "Compute the name that will be used to load FILE." + ;; OUTFILE should be the name of the global loaddefs.el file, which + ;; is expected to be at the root directory of the files we're + ;; scanning for autoloads and will be in the `load-path'. + (let* ((outfile (default-value 'generated-autoload-file)) + (name (file-relative-name file (file-name-directory outfile))) + (names '()) + (dir (file-name-directory outfile))) + ;; If `name' has directory components, only keep the + ;; last few that are really needed. + (while name + (setq name (directory-file-name name)) + (push (file-name-nondirectory name) names) + (setq name (file-name-directory name))) + (while (not name) + (cond + ((null (cdr names)) (setq name (car names))) + ((file-exists-p (expand-file-name "subdirs.el" dir)) + ;; FIXME: here we only check the existence of subdirs.el, + ;; without checking its content. This makes it generate wrong load + ;; names for cases like lisp/term which is not added to load-path. + (setq dir (expand-file-name (pop names) dir))) + (t (setq name (mapconcat 'identity names "/"))))) (if (string-match "\\.elc?\\(\\.\\|\\'\\)" name) (substring name 0 (match-beginning 0)) name))) @@ -339,6 +365,8 @@ Return non-nil in the case where no autoloads were added at point." (interactive "fGenerate autoloads for file: ") (autoload-generate-file-autoloads file (current-buffer))) +(defvar print-readably) + ;; When called from `generate-file-autoloads' we should ignore ;; `generated-autoload-file' altogether. When called from ;; `update-file-autoloads' we don't know `outbuf'. And when called from @@ -369,9 +397,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (visited (get-file-buffer file)) (otherbuf nil) (absfile (expand-file-name file)) - relfile ;; nil until we found a cookie. - output-start) + output-start ostart) (with-current-buffer (or visited ;; It is faster to avoid visiting the file. (autoload-find-file file)) @@ -381,7 +408,10 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (setq load-name (if (stringp generated-autoload-load-name) generated-autoload-load-name - (autoload-file-load-name file))) + (autoload-file-load-name absfile))) + (when (and outfile + (not (equal outfile (autoload-generated-file)))) + (setq otherbuf t)) (save-excursion (save-restriction (widen) @@ -392,26 +422,22 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE ((looking-at (regexp-quote generate-autoload-cookie)) ;; If not done yet, figure out where to insert this text. (unless output-start - (when (and outfile - (not (equal outfile (autoload-generated-file)))) - ;; A file-local setting of autoload-generated-file says - ;; we should ignore OUTBUF. - (setq outbuf nil) - (setq otherbuf t)) - (unless outbuf - (setq outbuf (autoload-find-destination absfile)) - (unless outbuf - ;; The file has autoload cookies, but they're - ;; already up-to-date. If OUTFILE is nil, the - ;; entries are in the expected OUTBUF, otherwise - ;; they're elsewhere. - (throw 'done outfile))) - (with-current-buffer outbuf - (setq relfile (file-relative-name absfile)) - (setq output-start (point))) - ;; (message "file=%S, relfile=%S, dest=%S" - ;; file relfile (autoload-generated-file)) - ) + (let ((outbuf + (or (if otherbuf + ;; A file-local setting of + ;; autoload-generated-file says we + ;; should ignore OUTBUF. + nil + outbuf) + (autoload-find-destination absfile load-name) + ;; The file has autoload cookies, but they're + ;; already up-to-date. If OUTFILE is nil, the + ;; entries are in the expected OUTBUF, + ;; otherwise they're elsewhere. + (throw 'done otherbuf)))) + (with-current-buffer outbuf + (setq output-start (point-marker) + ostart (point))))) (search-forward generate-autoload-cookie) (skip-chars-forward " \t") (if (eolp) @@ -423,7 +449,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (if autoload (push (nth 1 form) autoloads-done) (setq autoload form)) - (let ((autoload-print-form-outbuf outbuf)) + (let ((autoload-print-form-outbuf + (marker-buffer output-start))) (autoload-print-form autoload))) (error (message "Error in %s: %S" file err))) @@ -438,7 +465,7 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (forward-char 1)) (point)) (progn (forward-line 1) (point))) - outbuf))) + (marker-buffer output-start)))) ((looking-at ";") ;; Don't read the comment. (forward-line 1)) @@ -450,40 +477,44 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (let ((secondary-autoloads-file-buf (if (local-variable-p 'generated-autoload-file) (current-buffer)))) - (with-current-buffer outbuf + (with-current-buffer (marker-buffer output-start) (save-excursion ;; Insert the section-header line which lists the file name ;; and which functions are in it, etc. + (assert (= ostart output-start)) (goto-char output-start) - (autoload-insert-section-header - outbuf autoloads-done load-name relfile - (if secondary-autoloads-file-buf - ;; MD5 checksums are much better because they do not - ;; change unless the file changes (so they'll be - ;; equal on two different systems and will change - ;; less often than time-stamps, thus leading to fewer - ;; unneeded changes causing spurious conflicts), but - ;; using time-stamps is a very useful optimization, - ;; so we use time-stamps for the main autoloads file - ;; (loaddefs.el) where we have special ways to - ;; circumvent the "random change problem", and MD5 - ;; checksum in secondary autoload files where we do - ;; not need the time-stamp optimization because it is - ;; already provided by the primary autoloads file. - (md5 secondary-autoloads-file-buf - ;; We'd really want to just use - ;; `emacs-internal' instead. - nil nil 'emacs-mule-unix) - (nth 5 (file-attributes relfile)))) - (insert ";;; Generated autoloads from " relfile "\n")) + (let ((relfile (file-relative-name absfile))) + (autoload-insert-section-header + (marker-buffer output-start) + autoloads-done load-name relfile + (if secondary-autoloads-file-buf + ;; MD5 checksums are much better because they do not + ;; change unless the file changes (so they'll be + ;; equal on two different systems and will change + ;; less often than time-stamps, thus leading to fewer + ;; unneeded changes causing spurious conflicts), but + ;; using time-stamps is a very useful optimization, + ;; so we use time-stamps for the main autoloads file + ;; (loaddefs.el) where we have special ways to + ;; circumvent the "random change problem", and MD5 + ;; checksum in secondary autoload files where we do + ;; not need the time-stamp optimization because it is + ;; already provided by the primary autoloads file. + (md5 secondary-autoloads-file-buf + ;; We'd really want to just use + ;; `emacs-internal' instead. + nil nil 'emacs-mule-unix) + (nth 5 (file-attributes relfile)))) + (insert ";;; Generated autoloads from " relfile "\n"))) (insert generate-autoload-section-trailer)))) (message "Generating autoloads for %s...done" file)) (or visited ;; We created this buffer, so we should kill it. (kill-buffer (current-buffer)))) - ;; If the entries were added to some other buffer, then the file - ;; doesn't add entries to OUTFILE. - (or (not output-start) otherbuf)))) + (or (not output-start) + ;; If the entries were added to some other buffer, then the file + ;; doesn't add entries to OUTFILE. + otherbuf)))) (defun autoload-save-buffers () (while autoload-modified-buffers @@ -507,15 +538,14 @@ Return FILE if there was no autoload cookie in it, else nil." (message "Autoload section for %s is up to date." file))) (if no-autoloads file))) -(defun autoload-find-destination (file) +(defun autoload-find-destination (file load-name) "Find the destination point of the current buffer's autoloads. FILE is the file name of the current buffer. Returns a buffer whose point is placed at the requested location. Returns nil if the file's autoloads are uptodate, otherwise removes any prior now out-of-date autoload entries." (catch 'up-to-date - (let* ((load-name (autoload-file-load-name file)) - (buf (current-buffer)) + (let* ((buf (current-buffer)) (existing-buffer (if buffer-file-name buf)) (found nil)) (with-current-buffer @@ -528,7 +558,7 @@ removes any prior now out-of-date autoload entries." (unless (zerop (coding-system-eol-type buffer-file-coding-system)) (set-buffer-file-coding-system 'unix)) (or (> (buffer-size) 0) - (error "Autoloads file %s does not exist" buffer-file-name)) + (error "Autoloads file %s lacks boilerplate" buffer-file-name)) (or (file-writable-p buffer-file-name) (error "Autoloads file %s is not writable" buffer-file-name)) (widen) @@ -648,6 +678,7 @@ directory or directories specified." (t (autoload-remove-section (match-beginning 0)) (if (autoload-generate-file-autoloads + ;; Passing `current-buffer' makes it insert at point. file (current-buffer) buffer-file-name) (push file no-autoloads)))) (push file done) @@ -656,6 +687,9 @@ directory or directories specified." (dolist (file files) (cond ((member (expand-file-name file) autoload-excludes) nil) + ;; Passing nil as second argument forces + ;; autoload-generate-file-autoloads to look for the right + ;; spot where to insert each autoloads section. ((autoload-generate-file-autoloads file nil buffer-file-name) (push file no-autoloads)))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 394169be99d..217afea9f8a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3333,21 +3333,31 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (setq for-effect nil))) (defun byte-compile-setq-default (form) - (let ((bytecomp-args (cdr form)) - setters) - (while bytecomp-args - (let ((var (car bytecomp-args))) - (and (or (not (symbolp var)) - (byte-compile-const-symbol-p var t)) - (byte-compile-warning-enabled-p 'constants) - (byte-compile-warn - "variable assignment to %s `%s'" - (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var))) - (push (list 'set-default (list 'quote var) (car (cdr bytecomp-args))) - setters)) - (setq bytecomp-args (cdr (cdr bytecomp-args)))) - (byte-compile-form (cons 'progn (nreverse setters))))) + (setq form (cdr form)) + (if (> (length form) 2) + (let ((setters ())) + (while (consp form) + (push `(setq-default ,(pop form) ,(pop form)) setters)) + (byte-compile-form (cons 'progn (nreverse setters)))) + (let ((var (car form))) + (and (or (not (symbolp var)) + (byte-compile-const-symbol-p var t)) + (byte-compile-warning-enabled-p 'constants) + (byte-compile-warn + "variable assignment to %s `%s'" + (if (symbolp var) "constant" "nonvariable") + (prin1-to-string var))) + (byte-compile-normal-call `(set-default ',var ,@(cdr form)))))) + +(byte-defop-compiler-1 set-default) +(defun byte-compile-set-default (form) + (let ((varexp (car-safe (cdr-safe form)))) + (if (eq (car-safe varexp) 'quote) + ;; If the varexp is constant, compile it as a setq-default + ;; so we get more warnings. + (byte-compile-setq-default `(setq-default ,(car-safe (cdr varexp)) + ,@(cddr form))) + (byte-compile-normal-call form)))) (defun byte-compile-quote (form) (byte-compile-constant (car (cdr form)))) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 3211f79c9e9..c6aae373589 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -685,7 +685,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (setq last (point)) (goto-char (1+ pt)) (while (search-forward "(quote " last t) - (delete-backward-char 7) + (delete-char -7) (insert "'") (forward-sexp) (delete-char 1)) diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index bdae05e7774..325c7b1479f 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -10,7 +10,7 @@ ;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p ;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively ;;;;;; notevery notany every some mapcon mapcan mapl maplist map -;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "d93072a26c59f663a92b10df8bc28187") +;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "deb3495d75c36a222e5238eadb8e347c") ;;; Generated autoloads from cl-extra.el (autoload 'coerce "cl-extra" "\ @@ -282,7 +282,7 @@ Not documented ;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist ;;;;;; do* do loop return-from return block etypecase typecase ecase ;;;;;; case load-time-value eval-when destructuring-bind function* -;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "273ba25f4a116c61a464dbe55f1f8c63") +;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "fbeedbf769c72fee9b4e0671957c1077") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ @@ -1242,7 +1242,6 @@ Keywords supported: :test :test-not :key ;; version-control: never ;; no-byte-compile: t ;; no-update-autoloads: t +;; coding: utf-8 ;; End: - -;; arch-tag: 08cc5aab-e992-47f6-992e-12a7428c1a0e ;;; cl-loaddefs.el ends here diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 3e800c53008..694a06f8338 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -128,6 +128,12 @@ (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x))) (defun cl-expr-access-order (x v) + ;; This apparently tries to return nil iff the expression X evaluates + ;; the variables V in the same order as they appear in V (so as to + ;; be able to replace those vars with the expressions they're bound + ;; to). + ;; FIXME: This is very naive, it doesn't even check to see if those + ;; variables appear more than once. (if (cl-const-expr-p x) v (if (consp x) (progn @@ -1763,6 +1769,7 @@ Example: (defsetf frame-visible-p cl-set-frame-visible-p) (defsetf frame-width set-screen-width t) (defsetf frame-parameter set-frame-parameter t) +(defsetf terminal-parameter set-terminal-parameter) (defsetf getenv setenv t) (defsetf get-register set-register) (defsetf global-key-binding global-set-key) @@ -1806,6 +1813,7 @@ Example: (defsetf window-height () (store) (list 'progn (list 'enlarge-window (list '- store '(window-height))) store)) (defsetf window-hscroll set-window-hscroll) +(defsetf window-parameter set-window-parameter) (defsetf window-point set-window-point) (defsetf window-start set-window-start) (defsetf window-width () (store) @@ -1815,10 +1823,26 @@ Example: (defsetf x-get-secondary-selection x-own-secondary-selection t) (defsetf x-get-selection x-own-selection t) +;; This is a hack that allows (setf (eq a 7) B) to mean either +;; (setq a 7) or (setq a nil) depending on whether B is nil or not. +;; This is useful when you have control over the PLACE but not over +;; the VALUE, as is the case in define-minor-mode's :variable. +(define-setf-method eq (place val) + (let ((method (get-setf-method place cl-macro-environment)) + (val-temp (make-symbol "--eq-val--")) + (store-temp (make-symbol "--eq-store--"))) + (list (append (nth 0 method) (list val-temp)) + (append (nth 1 method) (list val)) + (list store-temp) + `(let ((,(car (nth 2 method)) + (if ,store-temp ,val-temp (not ,val-temp)))) + ,(nth 3 method) ,store-temp) + `(eq ,(nth 4 method) ,val-temp)))) + ;;; More complex setf-methods. -;;; These should take &environment arguments, but since full arglists aren't -;;; available while compiling cl-macs, we fake it by referring to the global -;;; variable cl-macro-environment directly. +;; These should take &environment arguments, but since full arglists aren't +;; available while compiling cl-macs, we fake it by referring to the global +;; variable cl-macro-environment directly. (define-setf-method apply (func arg1 &rest rest) (or (and (memq (car-safe func) '(quote function function*)) @@ -2616,21 +2640,36 @@ surrounded by (block NAME ...). (cons '&cl-quote args)) (list* 'cl-defsubst-expand (list 'quote argns) (list 'quote (list* 'block name body)) - (not (or unsafe (cl-expr-access-order pbody argns))) + ;; We used to pass `simple' as + ;; (not (or unsafe (cl-expr-access-order pbody argns))) + ;; But this is much too simplistic since it + ;; does not pay attention to the argvs (and + ;; cl-expr-access-order itself is also too naive). + nil (and (memq '&key args) 'cl-whole) unsafe argns))) (list* 'defun* name args body)))) (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole (if (cl-simple-exprs-p argvs) (setq simple t)) - (let ((lets (delq nil - (mapcar* (function - (lambda (argn argv) - (if (or simple (cl-const-expr-p argv)) - (progn (setq body (subst argv argn body)) - (and unsafe (list argn argv))) - (list argn argv)))) - argns argvs)))) + (let* ((substs ()) + (lets (delq nil + (mapcar* (function + (lambda (argn argv) + (if (or simple (cl-const-expr-p argv)) + (progn (push (cons argn argv) substs) + (and unsafe (list argn argv))) + (list argn argv)))) + argns argvs)))) + ;; FIXME: `sublis/subst' will happily substitute the symbol + ;; `argn' in places where it's not used as a reference + ;; to a variable. + ;; FIXME: `sublis/subst' will happily copy `argv' to a different + ;; scope, leading to name capture. + (setq body (cond ((null substs) body) + ((null (cdr substs)) + (subst (cdar substs) (caar substs) body)) + (t (sublis substs body)))) (if lets (list 'let lets body) body)))) diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index debef5535f5..d6f717ccda7 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -230,7 +230,7 @@ No problems result if this variable is not bound. ; Run the parent. (delay-mode-hooks - (,(or parent 'kill-all-local-variables)) + (,(or parent 'fundamental-mode)) ; Identify the child mode. (setq major-mode (quote ,child)) (setq mode-name ,name) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 13e08667839..5a21946183e 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -116,6 +116,11 @@ BODY contains code to execute each time the mode is activated or deactivated. :lighter SPEC Same as the LIGHTER argument. :keymap MAP Same as the KEYMAP argument. :require SYM Same as in `defcustom'. +:variable PLACE The location (as can be used with `setf') to use instead + of the variable MODE to store the state of the mode. PLACE + can also be of the form (GET . SET) where GET is an expression + that returns the current state and SET is a function that takes + a new state and sets it. For example, you could write (define-minor-mode foo-mode \"If enabled, foo on you!\" @@ -147,6 +152,9 @@ For example, you could write (type nil) (extra-args nil) (extra-keywords nil) + (variable nil) ;The PLACE where the state is stored. + (setter nil) ;The function (if any) to set the mode var. + (modefun mode) ;The minor mode function name we're defining. (require t) (hook (intern (concat mode-name "-hook"))) (hook-on (intern (concat mode-name "-on-hook"))) @@ -167,6 +175,12 @@ For example, you could write (:type (setq type (list :type (pop body)))) (:require (setq require (pop body))) (:keymap (setq keymap (pop body))) + (:variable (setq variable (pop body)) + (if (not (functionp (cdr-safe variable))) + ;; PLACE is not of the form (GET . SET). + (setq mode variable) + (setq mode (car variable)) + (setq setter (cdr variable)))) (t (push keyw extra-keywords) (push (pop body) extra-keywords)))) (setq keymap-sym (if (and keymap (symbolp keymap)) keymap @@ -187,12 +201,16 @@ For example, you could write `(progn ;; Define the variable to enable or disable the mode. - ,(if (not globalp) - `(progn - (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled. + ,(cond + ;; If :variable is specified, then the var will be + ;; declared elsewhere. + (variable nil) + ((not globalp) + `(progn + (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled. Use the command `%s' to change this variable." pretty-name mode)) - (make-variable-buffer-local ',mode)) - + (make-variable-buffer-local ',mode))) + (t (let ((base-doc-string (concat "Non-nil if %s is enabled. See the command `%s' for a description of this minor mode." @@ -207,10 +225,10 @@ or call the function `%s'.")))) ,@group ,@type ,@(unless (eq require t) `(:require ,require)) - ,@(nreverse extra-keywords)))) + ,@(nreverse extra-keywords))))) ;; The actual function. - (defun ,mode (&optional arg ,@extra-args) + (defun ,modefun (&optional arg ,@extra-args) ,(or doc (format (concat "Toggle %s on or off. Interactively, with no prefix argument, toggle the mode. @@ -221,22 +239,19 @@ With zero or negative ARG turn mode off. ;; repeat-command still does the toggling correctly. (interactive (list (or current-prefix-arg 'toggle))) (let ((,last-message (current-message))) - (setq ,mode - (cond - ((eq arg 'toggle) (not ,mode)) - (arg (> (prefix-numeric-value arg) 0)) - (t - (if (null ,mode) t - (message - "Toggling %s off; better pass an explicit argument." - ',mode) - nil)))) + (,@(if setter (list setter) + (list (if (symbolp mode) 'setq 'setf) mode)) + (if (eq arg 'toggle) + (not ,mode) + ;; A nil argument also means ON now. + (> (prefix-numeric-value arg) 0))) ,@body ;; The on/off hooks are here for backward compatibility only. (run-hooks ',hook (if ,mode ',hook-on ',hook-off)) (if (called-interactively-p 'any) (progn - ,(if globalp `(customize-mark-as-set ',mode)) + ,(if (and globalp (symbolp mode)) + `(customize-mark-as-set ',mode)) ;; Avoid overwriting a message shown by the body, ;; but do overwrite previous messages. (unless (and (current-message) @@ -261,9 +276,15 @@ With zero or negative ARG turn mode off. (t (error "Invalid keymap %S" ,keymap)))) ,(format "Keymap for `%s'." mode-name))) - (add-minor-mode ',mode ',lighter - ,(if keymap keymap-sym - `(if (boundp ',keymap-sym) ,keymap-sym)))))) + ,(if (not (symbolp mode)) + (if (or lighter keymap) + (error ":lighter and :keymap unsupported with mode expression %s" mode)) + `(with-no-warnings + (add-minor-mode ',mode ',lighter + ,(if keymap keymap-sym + `(if (boundp ',keymap-sym) ,keymap-sym)) + nil + ,(unless (eq mode modefun) 'modefun))))))) ;;; ;;; make global minor mode @@ -343,9 +364,11 @@ See `%s' for more information on %s." (progn (add-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers) + (add-hook 'fundamental-mode-hook ',MODE-enable-in-buffers) (add-hook 'find-file-hook ',MODE-check-buffers) (add-hook 'change-major-mode-hook ',MODE-cmhh)) (remove-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers) + (remove-hook 'fundamental-mode-hook ',MODE-enable-in-buffers) (remove-hook 'find-file-hook ',MODE-check-buffers) (remove-hook 'change-major-mode-hook ',MODE-cmhh)) @@ -366,13 +389,14 @@ See `%s' for more information on %s." (dolist (buf ,MODE-buffers) (when (buffer-live-p buf) (with-current-buffer buf - (if ,mode - (unless (eq ,MODE-major-mode major-mode) - (,mode -1) - (,turn-on) - (setq ,MODE-major-mode major-mode)) - (,turn-on) - (setq ,MODE-major-mode major-mode)))))) + (unless (eq ,MODE-major-mode major-mode) + (if ,mode + (progn + (,mode -1) + (,turn-on) + (setq ,MODE-major-mode major-mode)) + (,turn-on) + (setq ,MODE-major-mode major-mode))))))) (put ',MODE-enable-in-buffers 'definition-name ',global-mode) (defun ,MODE-check-buffers () diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 961d576433a..b4845495c9e 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -530,13 +530,13 @@ The words \"&rest\", \"&optional\" are returned unchanged." ;; Prime the command list. (eldoc-add-command-completions - "backward-" "beginning-of-" "move-beginning-of-" "delete-other-windows" - "delete-window" "handle-select-window" - "end-of-" "move-end-of-" "exchange-point-and-mark" "forward-" - "indent-for-tab-command" "goto-" "mark-page" "mark-paragraph" - "mouse-set-point" "move-" "pop-global-mark" "next-" "other-window" - "previous-" "recenter" "scroll-" "self-insert-command" - "split-window-" "up-list" "down-list") + "backward-" "beginning-of-" "delete-other-windows" "delete-window" + "down-list" "end-of-" "exchange-point-and-mark" "forward-" "goto-" + "handle-select-window" "indent-for-tab-command" "left-" "mark-page" + "mark-paragraph" "mouse-set-point" "move-" "move-beginning-of-" + "move-end-of-" "next-" "other-window" "pop-global-mark" "previous-" + "recenter" "right-" "scroll-" "self-insert-command" "split-window-" + "up-list") (provide 'eldoc) diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 8a1c753f5f6..10b7baf294f 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -458,7 +458,9 @@ each line." "Return list of keywords given in file FILE." (let ((keywords (lm-keywords file))) (if keywords - (split-string keywords "[, \t\n]+" t)))) + (if (string-match-p "," keywords) + (split-string keywords ",[ \t\n]*" t) + (split-string keywords "[ \t\n]+" t))))) (defvar finder-known-keywords) (defun lm-keywords-finder-p (&optional file) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 4b58a4e68c2..02477baf74f 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -221,8 +221,6 @@ font-lock keywords will not be case sensitive." ;;(set (make-local-variable 'adaptive-fill-mode) nil) (make-local-variable 'indent-line-function) (setq indent-line-function 'lisp-indent-line) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) (make-local-variable 'outline-regexp) (setq outline-regexp ";;;\\(;* [^ \t\n]\\|###autoload\\)\\|(") (make-local-variable 'outline-level) @@ -431,7 +429,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") :type 'hook :group 'lisp) -(define-derived-mode emacs-lisp-mode nil "Emacs-Lisp" +(define-derived-mode emacs-lisp-mode prog-mode "Emacs-Lisp" "Major mode for editing Lisp code to run in Emacs. Commands: Delete converts tabs to spaces as it moves back. @@ -466,7 +464,7 @@ if that value is non-nil." "Keymap for ordinary Lisp mode. All commands in `lisp-mode-shared-map' are inherited by this map.") -(defun lisp-mode () +(define-derived-mode lisp-mode prog-mode "Lisp" "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp. Commands: Delete converts tabs to spaces as it moves back. @@ -478,19 +476,12 @@ or to switch back to an existing one. Entry to this mode calls the value of `lisp-mode-hook' if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map lisp-mode-map) - (setq major-mode 'lisp-mode) - (setq mode-name "Lisp") (lisp-mode-variables nil t) + (set (make-local-variable 'find-tag-default-function) 'lisp-find-tag-default) (make-local-variable 'comment-start-skip) (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") - (setq imenu-case-fold-search t) - (set-syntax-table lisp-mode-syntax-table) - (run-mode-hooks 'lisp-mode-hook)) -(put 'lisp-mode 'find-tag-default-function 'lisp-find-tag-default) + (setq imenu-case-fold-search t)) (defun lisp-find-tag-default () (let ((default (find-tag-default))) diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 54fa4d615cd..4ef6dab8968 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -624,21 +624,25 @@ considered." (interactive) (let* ((data (lisp-completion-at-point predicate)) (plist (nthcdr 3 data))) - (let ((completion-annotate-function (plist-get plist :annotate-function))) + (if (null data) + (minibuffer-message "Nothing to complete") + (let ((completion-annotate-function + (plist-get plist :annotate-function))) (completion-in-region (nth 0 data) (nth 1 data) (nth 2 data) - (plist-get plist :predicate))))) + (plist-get plist :predicate)))))) (defun lisp-completion-at-point (&optional predicate) "Function used for `completion-at-point-functions' in `emacs-lisp-mode'." ;; FIXME: the `end' could be after point? - (let* ((end (point)) + (let* ((pos (point)) (beg (with-syntax-table emacs-lisp-mode-syntax-table - (save-excursion - (backward-sexp 1) - (while (= (char-syntax (following-char)) ?\') - (forward-char 1)) - (point)))) + (condition-case nil + (save-excursion + (backward-sexp 1) + (skip-syntax-forward "'") + (point)) + (scan-error pos)))) (predicate (or predicate (save-excursion @@ -657,12 +661,23 @@ considered." ;; Maybe a `let' varlist or something. nil ;; Else, we assume that a function name is expected. - 'fboundp)))))) - (list beg end obarray - :predicate predicate - :annotate-function + 'fboundp))))) + (end + (unless (or (eq beg (point-max)) + (member (char-syntax (char-after beg)) '(?\" ?\( ?\)))) + (condition-case nil + (save-excursion + (goto-char beg) + (forward-sexp 1) + (when (>= (point) pos) + (point))) + (scan-error pos))))) + (when end + (list beg end obarray + :predicate predicate + :annotate-function (unless (eq predicate 'fboundp) - (lambda (str) (if (fboundp (intern-soft str)) " <f>")))))) + (lambda (str) (if (fboundp (intern-soft str)) " <f>"))))))) ;; arch-tag: aa7fa8a4-2e6f-4e9b-9cd9-fef06340e67e ;;; lisp.el ends here diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el new file mode 100644 index 00000000000..fb1e4737d39 --- /dev/null +++ b/lisp/emacs-lisp/smie.el @@ -0,0 +1,877 @@ +;;; smie.el --- Simple Minded Indentation Engine + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: languages, lisp, internal, parsing, indentation + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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 this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; While working on the SML indentation code, the idea grew that maybe +;; I could write something generic to do the same thing, and at the +;; end of working on the SML code, I had a pretty good idea of what it +;; could look like. That idea grew stronger after working on +;; LaTeX indentation. +;; +;; So at some point I decided to try it out, by writing a new +;; indentation code for Coq while trying to keep most of the code +;; "table driven", where only the tables are Coq-specific. The result +;; (which was used for Beluga-mode as well) turned out to be based on +;; something pretty close to an operator precedence parser. + +;; So here is another rewrite, this time following the actual principles of +;; operator precedence grammars. Why OPG? Even though they're among the +;; weakest kinds of parsers, these parsers have some very desirable properties +;; for Emacs: +;; - most importantly for indentation, they work equally well in either +;; direction, so you can use them to parse backward from the indentation +;; point to learn the syntactic context; +;; - they work locally, so there's no need to keep a cache of +;; the parser's state; +;; - because of that locality, indentation also works just fine when earlier +;; parts of the buffer are syntactically incorrect since the indentation +;; looks at "as little as possible" of the buffer to make an indentation +;; decision. +;; - they typically have no error handling and can't even detect a parsing +;; error, so we don't have to worry about what to do in case of a syntax +;; error because the parser just automatically does something. Better yet, +;; we can afford to use a sloppy grammar. + +;; The development (especially the parts building the 2D precedence +;; tables and then computing the precedence levels from it) is largely +;; inspired from page 187-194 of "Parsing techniques" by Dick Grune +;; and Ceriel Jacobs (BookBody.pdf available at +;; http://www.cs.vu.nl/~dick/PTAPG.html). +;; +;; OTOH we had to kill many chickens, read many coffee grounds, and practice +;; untold numbers of black magic spells, to come up with the indentation code. +;; Since then, some of that code has been beaten into submission, but the +;; smie-indent-keyword is still pretty obscure. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defvar comment-continue) +(declare-function comment-string-strip "newcomment" (str beforep afterp)) + +;;; Building precedence level tables from BNF specs. + +(defun smie-set-prec2tab (table x y val &optional override) + (assert (and x y)) + (let* ((key (cons x y)) + (old (gethash key table))) + (if (and old (not (eq old val))) + (if (and override (gethash key override)) + ;; FIXME: The override is meant to resolve ambiguities, + ;; but it also hides real conflicts. It would be great to + ;; be able to distinguish the two cases so that overrides + ;; don't hide real conflicts. + (puthash key (gethash key override) table) + (display-warning 'smie (format "Conflict: %s %s/%s %s" x old val y))) + (puthash key val table)))) + +(defun smie-precs-precedence-table (precs) + "Compute a 2D precedence table from a list of precedences. +PRECS should be a list, sorted by precedence (e.g. \"+\" will +come before \"*\"), of elements of the form \(left OP ...) +or (right OP ...) or (nonassoc OP ...) or (assoc OP ...). All operators in +one of those elements share the same precedence level and associativity." + (let ((prec2-table (make-hash-table :test 'equal))) + (dolist (prec precs) + (dolist (op (cdr prec)) + (let ((selfrule (cdr (assq (car prec) + '((left . >) (right . <) (assoc . =)))))) + (when selfrule + (dolist (other-op (cdr prec)) + (smie-set-prec2tab prec2-table op other-op selfrule)))) + (let ((op1 '<) (op2 '>)) + (dolist (other-prec precs) + (if (eq prec other-prec) + (setq op1 '> op2 '<) + (dolist (other-op (cdr other-prec)) + (smie-set-prec2tab prec2-table op other-op op2) + (smie-set-prec2tab prec2-table other-op op op1))))))) + prec2-table)) + +(defun smie-merge-prec2s (&rest tables) + (if (null (cdr tables)) + (car tables) + (let ((prec2 (make-hash-table :test 'equal))) + (dolist (table tables) + (maphash (lambda (k v) + (smie-set-prec2tab prec2 (car k) (cdr k) v)) + table)) + prec2))) + +(defun smie-bnf-precedence-table (bnf &rest precs) + (let ((nts (mapcar 'car bnf)) ;Non-terminals + (first-ops-table ()) + (last-ops-table ()) + (first-nts-table ()) + (last-nts-table ()) + (prec2 (make-hash-table :test 'equal)) + (override (apply 'smie-merge-prec2s + (mapcar 'smie-precs-precedence-table precs))) + again) + (dolist (rules bnf) + (let ((nt (car rules)) + (last-ops ()) + (first-ops ()) + (last-nts ()) + (first-nts ())) + (dolist (rhs (cdr rules)) + (assert (consp rhs)) + (if (not (member (car rhs) nts)) + (pushnew (car rhs) first-ops) + (pushnew (car rhs) first-nts) + (when (consp (cdr rhs)) + ;; If the first is not an OP we add the second (which + ;; should be an OP if BNF is an "operator grammar"). + ;; Strictly speaking, this should only be done if the + ;; first is a non-terminal which can expand to a phrase + ;; without any OP in it, but checking doesn't seem worth + ;; the trouble, and it lets the writer of the BNF + ;; be a bit more sloppy by skipping uninteresting base + ;; cases which are terminals but not OPs. + (assert (not (member (cadr rhs) nts))) + (pushnew (cadr rhs) first-ops))) + (let ((shr (reverse rhs))) + (if (not (member (car shr) nts)) + (pushnew (car shr) last-ops) + (pushnew (car shr) last-nts) + (when (consp (cdr shr)) + (assert (not (member (cadr shr) nts))) + (pushnew (cadr shr) last-ops))))) + (push (cons nt first-ops) first-ops-table) + (push (cons nt last-ops) last-ops-table) + (push (cons nt first-nts) first-nts-table) + (push (cons nt last-nts) last-nts-table))) + ;; Compute all first-ops by propagating the initial ones we have + ;; now, according to first-nts. + (setq again t) + (while (prog1 again (setq again nil)) + (dolist (first-nts first-nts-table) + (let* ((nt (pop first-nts)) + (first-ops (assoc nt first-ops-table))) + (dolist (first-nt first-nts) + (dolist (op (cdr (assoc first-nt first-ops-table))) + (unless (member op first-ops) + (setq again t) + (push op (cdr first-ops)))))))) + ;; Same thing for last-ops. + (setq again t) + (while (prog1 again (setq again nil)) + (dolist (last-nts last-nts-table) + (let* ((nt (pop last-nts)) + (last-ops (assoc nt last-ops-table))) + (dolist (last-nt last-nts) + (dolist (op (cdr (assoc last-nt last-ops-table))) + (unless (member op last-ops) + (setq again t) + (push op (cdr last-ops)))))))) + ;; Now generate the 2D precedence table. + (dolist (rules bnf) + (dolist (rhs (cdr rules)) + (while (cdr rhs) + (cond + ((member (car rhs) nts) + (dolist (last (cdr (assoc (car rhs) last-ops-table))) + (smie-set-prec2tab prec2 last (cadr rhs) '> override))) + ((member (cadr rhs) nts) + (dolist (first (cdr (assoc (cadr rhs) first-ops-table))) + (smie-set-prec2tab prec2 (car rhs) first '< override)) + (if (and (cddr rhs) (not (member (car (cddr rhs)) nts))) + (smie-set-prec2tab prec2 (car rhs) (car (cddr rhs)) + '= override))) + (t (smie-set-prec2tab prec2 (car rhs) (cadr rhs) '= override))) + (setq rhs (cdr rhs))))) + prec2)) + +(defun smie-prec2-levels (prec2) + "Take a 2D precedence table and turn it into an alist of precedence levels. +PREC2 is a table as returned by `smie-precs-precedence-table' or +`smie-bnf-precedence-table'." + ;; For each operator, we create two "variables" (corresponding to + ;; the left and right precedence level), which are represented by + ;; cons cells. Those are the vary cons cells that appear in the + ;; final `table'. The value of each "variable" is kept in the `car'. + (let ((table ()) + (csts ()) + (eqs ()) + tmp x y) + ;; From `prec2' we construct a list of constraints between + ;; variables (aka "precedence levels"). These can be either + ;; equality constraints (in `eqs') or `<' constraints (in `csts'). + (maphash (lambda (k v) + (if (setq tmp (assoc (car k) table)) + (setq x (cddr tmp)) + (setq x (cons nil nil)) + (push (cons (car k) (cons nil x)) table)) + (if (setq tmp (assoc (cdr k) table)) + (setq y (cdr tmp)) + (setq y (cons nil (cons nil nil))) + (push (cons (cdr k) y) table)) + (ecase v + (= (push (cons x y) eqs)) + (< (push (cons x y) csts)) + (> (push (cons y x) csts)))) + prec2) + ;; First process the equality constraints. + (let ((eqs eqs)) + (while eqs + (let ((from (caar eqs)) + (to (cdar eqs))) + (setq eqs (cdr eqs)) + (if (eq to from) + nil ;Nothing to do. + (dolist (other-eq eqs) + (if (eq from (cdr other-eq)) (setcdr other-eq to)) + (when (eq from (car other-eq)) + ;; This can happen because of `assoc' settings in precs + ;; or because of a rhs like ("op" foo "op"). + (setcar other-eq to))) + (dolist (cst csts) + (if (eq from (cdr cst)) (setcdr cst to)) + (if (eq from (car cst)) (setcar cst to))))))) + ;; Then eliminate trivial constraints iteratively. + (let ((i 0)) + (while csts + (let ((rhvs (mapcar 'cdr csts)) + (progress nil)) + (dolist (cst csts) + (unless (memq (car cst) rhvs) + (setq progress t) + ;; We could give each var in a given iteration the same value, + ;; but we can also give them arbitrarily different values. + ;; Basically, these are vars between which there is no + ;; constraint (neither equality nor inequality), so + ;; anything will do. + ;; We give them arbitrary values, which means that we + ;; replace the "no constraint" case with either > or < + ;; but not =. The reason we do that is so as to try and + ;; distinguish associative operators (which will have + ;; left = right). + (unless (caar cst) + (setcar (car cst) i) + (incf i)) + (setq csts (delq cst csts)))) + (unless progress + (error "Can't resolve the precedence table to precedence levels"))) + (incf i 10)) + ;; Propagate equalities back to their source. + (dolist (eq (nreverse eqs)) + (assert (or (null (caar eq)) (eq (car eq) (cdr eq)))) + (setcar (car eq) (cadr eq))) + ;; Finally, fill in the remaining vars (which only appeared on the + ;; right side of the < constraints). + (dolist (x table) + ;; When both sides are nil, it means this operator binds very + ;; very tight, but it's still just an operator, so we give it + ;; the highest precedence. + ;; OTOH if only one side is nil, it usually means it's like an + ;; open-paren, which is very important for indentation purposes, + ;; so we keep it nil, to make it easier to recognize. + (unless (or (nth 1 x) (nth 2 x)) + (setf (nth 1 x) i) + (setf (nth 2 x) i)))) + table)) + +;;; Parsing using a precedence level table. + +(defvar smie-op-levels 'unset + "List of token parsing info. +Each element is of the form (TOKEN LEFT-LEVEL RIGHT-LEVEL). +Parsing is done using an operator precedence parser. +LEFT-LEVEL and RIGHT-LEVEL can be either numbers or nil, where nil +means that this operator does not bind on the corresponding side, +i.e. a LEFT-LEVEL of nil means this is a token that behaves somewhat like +an open-paren, whereas a RIGHT-LEVEL of nil would correspond to something +like a close-paren.") + +(defvar smie-forward-token-function 'smie-default-forward-token + "Function to scan forward for the next token. +Called with no argument should return a token and move to its end. +If no token is found, return nil or the empty string. +It can return nil when bumping into a parenthesis, which lets SMIE +use syntax-tables to handle them in efficient C code.") + +(defvar smie-backward-token-function 'smie-default-backward-token + "Function to scan backward the previous token. +Same calling convention as `smie-forward-token-function' except +it should move backward to the beginning of the previous token.") + +(defalias 'smie-op-left 'car) +(defalias 'smie-op-right 'cadr) + +(defun smie-default-backward-token () + (forward-comment (- (point))) + (buffer-substring (point) + (progn (if (zerop (skip-syntax-backward ".")) + (skip-syntax-backward "w_'")) + (point)))) + +(defun smie-default-forward-token () + (forward-comment (point-max)) + (buffer-substring (point) + (progn (if (zerop (skip-syntax-forward ".")) + (skip-syntax-forward "w_'")) + (point)))) + +(defun smie-associative-p (toklevels) + ;; in "a + b + c" we want to stop at each +, but in + ;; "if a then b else c" we don't want to stop at each keyword. + ;; To distinguish the two cases, we made smie-prec2-levels choose + ;; different levels for each part of "if a then b else c", so that + ;; by checking if the left-level is equal to the right level, we can + ;; figure out that it's an associative operator. + ;; This is not 100% foolproof, tho, since a grammar like + ;; (exp ("A" exp "C") ("A" exp "B" exp "C")) + ;; will cause "B" to have equal left and right levels, even though + ;; it is not an associative operator. + ;; A better check would be the check the actual previous operator + ;; against this one to see if it's the same, but we'd have to change + ;; `levels' to keep a stack of operators rather than only levels. + (eq (smie-op-left toklevels) (smie-op-right toklevels))) + +(defun smie-next-sexp (next-token next-sexp op-forw op-back halfsexp) + "Skip over one sexp. +NEXT-TOKEN is a function of no argument that moves forward by one +token (after skipping comments if needed) and returns it. +NEXT-SEXP is a lower-level function to skip one sexp. +OP-FORW is the accessor to the forward level of the level data. +OP-BACK is the accessor to the backward level of the level data. +HALFSEXP if non-nil, means skip over a partial sexp if needed. I.e. if the +first token we see is an operator, skip over its left-hand-side argument. +Possible return values: + (FORW-LEVEL POS TOKEN): we couldn't skip TOKEN because its back-level + is too high. FORW-LEVEL is the forw-level of TOKEN, + POS is its start position in the buffer. + (t POS TOKEN): same thing when we bump on the wrong side of a paren. + (nil POS TOKEN): we skipped over a paren-like pair. + nil: we skipped over an identifier, matched parentheses, ..." + (catch 'return + (let ((levels ())) + (while + (let* ((pos (point)) + (token (funcall next-token)) + (toklevels (cdr (assoc token smie-op-levels)))) + + (cond + ((null toklevels) + (when (zerop (length token)) + (condition-case err + (progn (goto-char pos) (funcall next-sexp 1) nil) + (scan-error (throw 'return (list t (caddr err))))) + (if (eq pos (point)) + ;; We did not move, so let's abort the loop. + (throw 'return (list t (point)))))) + ((null (funcall op-back toklevels)) + ;; A token like a paren-close. + (assert (funcall op-forw toklevels)) ;Otherwise, why mention it? + (push (funcall op-forw toklevels) levels)) + (t + (while (and levels (< (funcall op-back toklevels) (car levels))) + (setq levels (cdr levels))) + (cond + ((null levels) + (if (and halfsexp (funcall op-forw toklevels)) + (push (funcall op-forw toklevels) levels) + (throw 'return + (prog1 (list (or (car toklevels) t) (point) token) + (goto-char pos))))) + (t + (if (and levels (= (funcall op-back toklevels) (car levels))) + (setq levels (cdr levels))) + (cond + ((null levels) + (cond + ((null (funcall op-forw toklevels)) + (throw 'return (list nil (point) token))) + ((smie-associative-p toklevels) + (throw 'return + (prog1 (list (or (car toklevels) t) (point) token) + (goto-char pos)))) + ;; We just found a match to the previously pending operator + ;; but this new operator is still part of a larger RHS. + ;; E.g. we're now looking at the "then" in + ;; "if a then b else c". So we have to keep parsing the + ;; rest of the construct. + (t (push (funcall op-forw toklevels) levels)))) + (t + (if (funcall op-forw toklevels) + (push (funcall op-forw toklevels) levels)))))))) + levels) + (setq halfsexp nil))))) + +(defun smie-backward-sexp (&optional halfsexp) + "Skip over one sexp. +HALFSEXP if non-nil, means skip over a partial sexp if needed. I.e. if the +first token we see is an operator, skip over its left-hand-side argument. +Possible return values: + (LEFT-LEVEL POS TOKEN): we couldn't skip TOKEN because its right-level + is too high. LEFT-LEVEL is the left-level of TOKEN, + POS is its start position in the buffer. + (t POS TOKEN): same thing but for an open-paren or the beginning of buffer. + (nil POS TOKEN): we skipped over a paren-like pair. + nil: we skipped over an identifier, matched parentheses, ..." + (smie-next-sexp + (indirect-function smie-backward-token-function) + (indirect-function 'backward-sexp) + (indirect-function 'smie-op-left) + (indirect-function 'smie-op-right) + halfsexp)) + +(defun smie-forward-sexp (&optional halfsexp) + "Skip over one sexp. +HALFSEXP if non-nil, means skip over a partial sexp if needed. I.e. if the +first token we see is an operator, skip over its left-hand-side argument. +Possible return values: + (RIGHT-LEVEL POS TOKEN): we couldn't skip TOKEN because its left-level + is too high. RIGHT-LEVEL is the right-level of TOKEN, + POS is its end position in the buffer. + (t POS TOKEN): same thing but for an open-paren or the beginning of buffer. + (nil POS TOKEN): we skipped over a paren-like pair. + nil: we skipped over an identifier, matched parentheses, ..." + (smie-next-sexp + (indirect-function smie-forward-token-function) + (indirect-function 'forward-sexp) + (indirect-function 'smie-op-right) + (indirect-function 'smie-op-left) + halfsexp)) + +(defun smie-backward-sexp-command (&optional n) + "Move backward through N logical elements." + (interactive "p") + (if (< n 0) + (smie-forward-sexp-command (- n)) + (let ((forward-sexp-function nil)) + (while (> n 0) + (decf n) + (let ((pos (point)) + (res (smie-backward-sexp 'halfsexp))) + (if (and (car res) (= pos (point)) (not (bolp))) + (signal 'scan-error + (list "Containing expression ends prematurely" + (cadr res) (cadr res))) + nil)))))) + +(defun smie-forward-sexp-command (&optional n) + "Move forward through N logical elements." + (interactive "p") + (if (< n 0) + (smie-backward-sexp-command (- n)) + (let ((forward-sexp-function nil)) + (while (> n 0) + (decf n) + (let ((pos (point)) + (res (smie-forward-sexp 'halfsexp))) + (if (and (car res) (= pos (point)) (not (bolp))) + (signal 'scan-error + (list "Containing expression ends prematurely" + (cadr res) (cadr res))) + nil)))))) + +;;; The indentation engine. + +(defcustom smie-indent-basic 4 + "Basic amount of indentation." + :type 'integer) + +(defvar smie-indent-rules 'unset + ;; TODO: For SML, we need more rule formats, so as to handle + ;; structure Foo = + ;; Bar (toto) + ;; and + ;; structure Foo = + ;; struct ... end + ;; I.e. the indentation after "=" depends on the parent ("structure") + ;; as well as on the following token ("struct"). + "Rules of the following form. +\((:before . TOK) . OFFSET-RULES) how to indent TOK itself. +\(TOK . OFFSET-RULES) how to indent right after TOK. +\((T1 . T2) . OFFSET) how to indent token T2 w.r.t T1. +\((t . TOK) . OFFSET) how to indent TOK with respect to its parent. +\(list-intro . TOKENS) declare TOKENS as being followed by what may look like + a funcall but is just a sequence of expressions. +\(t . OFFSET) basic indentation step. +\(args . OFFSET) indentation of arguments. + +OFFSET-RULES is a list of elements which can each either be: + +\(:hanging . OFFSET-RULES) if TOK is hanging, use OFFSET-RULES. +\(:parent PARENT . OFFSET-RULES) if TOK's parent is PARENT, use OFFSET-RULES. +\(:next TOKEN . OFFSET-RULES) if TOK is followed by TOKEN, use OFFSET-RULES. +\(:prev TOKEN . OFFSET-RULES) if TOK is preceded by TOKEN, use OFFSET-RULES. +a number the offset to use. +`point' align with the token. +`parent' align with the parent. + +A nil offset for indentation after a token defaults to `smie-indent-basic'.") + +(defun smie-indent-hanging-p () + ;; A hanging keyword is one that's at the end of a line except it's not at + ;; the beginning of a line. + (and (save-excursion + (when (zerop (length (funcall smie-forward-token-function))) + ;; Could be an open-paren. + (forward-char 1)) + (skip-chars-forward " \t") + (eolp)) + (not (smie-bolp)))) + +(defun smie-bolp () + (save-excursion (skip-chars-backward " \t") (bolp))) + +(defun smie-indent-offset (elem) + (or (cdr (assq elem smie-indent-rules)) + (cdr (assq t smie-indent-rules)) + smie-indent-basic)) + +(defun smie-indent-offset-rule (tokinfo &optional after) + "Apply the OFFSET-RULES in TOKINFO. +Point is expected to be right in front of the token corresponding to TOKINFO. +If computing the indentation after the token, then AFTER is the position +after the token." + (let ((rules (cdr tokinfo)) + parent next prev + offset) + (while (consp rules) + (let ((rule (pop rules))) + (cond + ((not (consp rule)) (setq offset rule)) + ((eq (car rule) :hanging) + (when (smie-indent-hanging-p) + (setq rules (cdr rule)))) + ((eq (car rule) :prev) + (unless prev + (save-excursion + (setq prev (smie-indent-backward-token)))) + (when (equal (car prev) (cadr rule)) + (setq rules (cddr rule)))) + ((eq (car rule) :next) + (unless next + (unless after + (error "Can't use :next in :before indentation rules")) + (save-excursion + (goto-char after) + (setq next (smie-indent-forward-token)))) + (when (equal (car next) (cadr rule)) + (setq rules (cddr rule)))) + ((eq (car rule) :parent) + (unless parent + (save-excursion + (if after (goto-char after)) + (setq parent (smie-backward-sexp 'halfsexp)))) + (when (equal (nth 2 parent) (cadr rule)) + (setq rules (cddr rule)))) + (t (error "Unknown rule %s for indentation of %s" + rule (car tokinfo)))))) + offset)) + +(defun smie-indent-forward-token () + "Skip token forward and return it, along with its levels." + (let ((tok (funcall smie-forward-token-function))) + (cond + ((< 0 (length tok)) (assoc tok smie-op-levels)) + ((looking-at "\\s(") + (forward-char 1) + (list (buffer-substring (1- (point)) (point)) nil 0))))) + +(defun smie-indent-backward-token () + "Skip token backward and return it, along with its levels." + (let ((tok (funcall smie-backward-token-function))) + (cond + ((< 0 (length tok)) (assoc tok smie-op-levels)) + ;; 4 == Open paren syntax. + ((eq 4 (syntax-class (syntax-after (1- (point))))) + (forward-char -1) + (list (buffer-substring (point) (1+ (point))) nil 0))))) + +(defun smie-indent-virtual () + ;; We used to take an optional arg (with value :not-hanging) to specify that + ;; we should only use (smie-indent-calculate) if we're looking at a hanging + ;; keyword. This was a bad idea, because the virtual indent of a position + ;; should not depend on the caller, since it leads to situations where two + ;; dependent indentations get indented differently. + "Compute the virtual indentation to use for point. +This is used when we're not trying to indent point but just +need to compute the column at which point should be indented +in order to figure out the indentation of some other (further down) point." + ;; Trust pre-existing indentation on other lines. + (if (smie-bolp) (current-column) (smie-indent-calculate))) + +(defun smie-indent-fixindent () + ;; Obey the `fixindent' special comment. + (and (smie-bolp) + (save-excursion + (comment-normalize-vars) + (re-search-forward (concat comment-start-skip + "fixindent" + comment-end-skip) + ;; 1+ to account for the \n comment termination. + (1+ (line-end-position)) t)) + (current-column))) + +(defun smie-indent-bob () + ;; Start the file at column 0. + (save-excursion + (forward-comment (- (point))) + (if (bobp) 0))) + +(defun smie-indent-close () + ;; Align close paren with opening paren. + (save-excursion + ;; (forward-comment (point-max)) + (when (looking-at "\\s)") + (while (not (zerop (skip-syntax-forward ")"))) + (skip-chars-forward " \t")) + (condition-case nil + (progn + (backward-sexp 1) + (smie-indent-virtual)) ;:not-hanging + (scan-error nil))))) + +(defun smie-indent-keyword () + ;; Align closing token with the corresponding opening one. + ;; (e.g. "of" with "case", or "in" with "let"). + (save-excursion + (let* ((pos (point)) + (toklevels (smie-indent-forward-token)) + (token (pop toklevels))) + (if (null (car toklevels)) + ;; Different case: + ;; - smie-bolp: "indent according to others". + ;; - common hanging: "indent according to others". + ;; - SML-let hanging: "indent like parent". + ;; - if-after-else: "indent-like parent". + ;; - middle-of-line: "trust current position". + (cond + ((null (cdr toklevels)) nil) ;Not a keyword. + ((smie-bolp) + ;; For an open-paren-like thingy at BOL, always indent only + ;; based on other rules (typically smie-indent-after-keyword). + nil) + (t + (let* ((tokinfo (or (assoc (cons :before token) smie-indent-rules) + ;; By default use point unless we're hanging. + (cons (cons :before token) + '((:hanging nil) point)))) + (after (prog1 (point) (goto-char pos))) + (offset (smie-indent-offset-rule tokinfo))) + (cond + ((eq offset 'point) (current-column)) + ((eq offset 'parent) + (let ((parent (smie-backward-sexp 'halfsexp))) + (if parent (goto-char (cadr parent)))) + (smie-indent-virtual)) + ((eq offset nil) nil) + (t (error "Unhandled offset %s in %s" + offset (cons :before token))))))) + + ;; FIXME: This still looks too much like black magic!! + ;; FIXME: Rather than a bunch of rules like (PARENT . TOKEN), we + ;; want a single rule for TOKEN with different cases for each PARENT. + (let ((res (smie-backward-sexp 'halfsexp)) tmp) + (cond + ((not (or (< (point) pos) + (and (cadr res) (< (cadr res) pos)))) + ;; If we didn't move at all, that means we didn't really skip + ;; what we wanted. + nil) + ((eq (car res) (car toklevels)) + ;; We bumped into a same-level operator. align with it. + (goto-char (cadr res)) + ;; Don't use (smie-indent-virtual :not-hanging) here, because we + ;; want to jump back over a sequence of same-level ops such as + ;; a -> b -> c + ;; -> d + ;; So as to align with the earliest appropriate place. + (smie-indent-virtual)) + ((setq tmp (assoc (cons (caddr res) token) + smie-indent-rules)) + (goto-char (cadr res)) + (+ (cdr tmp) (smie-indent-virtual))) ;:not-hanging + ;; FIXME: The rules ((t . TOK) . OFFSET) either indent + ;; relative to "before the parent" or "after the parent", + ;; depending on details of the grammar. + ((null (car res)) + (assert (eq (point) (cadr res))) + (goto-char (cadr res)) + (+ (or (cdr (assoc (cons t token) smie-indent-rules)) 0) + (smie-indent-virtual))) ;:not-hanging + ((and (= (point) pos) (smie-bolp)) + ;; Since we started at BOL, we're not computing a virtual + ;; indentation, and we're still at the starting point, so the + ;; next (default) rule can't be used since it uses `current-column' + ;; which would cause. indentation to depend on itself. + ;; We could just return nil, but OTOH that's not good enough in + ;; some cases. Instead, we want to combine the offset-rules for + ;; the current token with the offset-rules of the previous one. + (+ (or (cdr (assoc (cons t token) smie-indent-rules)) 0) + ;; FIXME: This is odd. Can't we make it use + ;; smie-indent-(calculate|virtual) somehow? + (smie-indent-after-keyword))) + (t + (+ (or (cdr (assoc (cons t token) smie-indent-rules)) 0) + (current-column))))))))) + +(defun smie-indent-comment () + ;; Indentation of a comment. + (and (looking-at comment-start-skip) + (save-excursion + (forward-comment (point-max)) + (skip-chars-forward " \t\r\n") + (smie-indent-calculate)))) + +(defun smie-indent-comment-continue () + ;; indentation of comment-continue lines. + (let ((continue (and comment-continue + (comment-string-strip comment-continue t t)))) + (and (< 0 (length continue)) + (looking-at (regexp-quote continue)) (nth 4 (syntax-ppss)) + (let ((ppss (syntax-ppss))) + (save-excursion + (forward-line -1) + (if (<= (point) (nth 8 ppss)) + (progn (goto-char (1+ (nth 8 ppss))) (current-column)) + (skip-chars-forward " \t") + (if (looking-at (regexp-quote continue)) + (current-column)))))))) + +(defun smie-indent-after-keyword () + ;; Indentation right after a special keyword. + (save-excursion + (let* ((pos (point)) + (toklevel (smie-indent-backward-token)) + (tok (car toklevel)) + (tokinfo (assoc tok smie-indent-rules))) + (if (and toklevel (null (cadr toklevel)) (null tokinfo)) + (setq tokinfo (list (car toklevel)))) + ;; (if (and tokinfo (null toklevel)) + ;; (error "Token %S has indent rule but has no parsing info" tok)) + (when toklevel + (let ((offset + (cond + (tokinfo (or (smie-indent-offset-rule tokinfo pos) + (smie-indent-offset t))) + ;; The default indentation after a keyword/operator + ;; is 0 for infix and t for prefix. + ;; Using the BNF syntax, we could come up with + ;; better defaults, but we only have the + ;; precedence levels here. + ((null (cadr toklevel)) (smie-indent-offset t)) + (t 0)))) + ;; For indentation after "(let" in SML-mode, we end up accumulating + ;; the offset of "(" and the offset of "let", so we use `min' to try + ;; and get it right either way. + (+ (min (smie-indent-virtual) (current-column)) offset)))))) + +(defun smie-indent-exps () + ;; Indentation of sequences of simple expressions without + ;; intervening keywords or operators. E.g. "a b c" or "g (balbla) f". + ;; Can be a list of expressions or a function call. + ;; If it's a function call, the first element is special (it's the + ;; function). We distinguish function calls from mere lists of + ;; expressions based on whether the preceding token is listed in + ;; the `list-intro' entry of smie-indent-rules. + ;; + ;; TODO: to indent Lisp code, we should add a way to specify + ;; particular indentation for particular args depending on the + ;; function (which would require always skipping back until the + ;; function). + ;; TODO: to indent C code, such as "if (...) {...}" we might need + ;; to add similar indentation hooks for particular positions, but + ;; based on the preceding token rather than based on the first exp. + (save-excursion + (let ((positions nil) + arg) + (while (and (null (car (smie-backward-sexp))) + (push (point) positions) + (not (smie-bolp)))) + (save-excursion + ;; Figure out if the atom we just skipped is an argument rather + ;; than a function. + (setq arg (or (null (car (smie-backward-sexp))) + (member (funcall smie-backward-token-function) + (cdr (assoc 'list-intro smie-indent-rules)))))) + (cond + ((null positions) + ;; We're the first expression of the list. In that case, the + ;; indentation should be (have been) determined by its context. + nil) + (arg + ;; There's a previous element, and it's not special (it's not + ;; the function), so let's just align with that one. + (goto-char (car positions)) + (current-column)) + ((cdr positions) + ;; We skipped some args plus the function and bumped into something. + ;; Align with the first arg. + (goto-char (cadr positions)) + (current-column)) + (positions + ;; We're the first arg. + (goto-char (car positions)) + (+ (smie-indent-offset 'args) + ;; We used to use (smie-indent-virtual), but that + ;; doesn't seem right since it might then indent args less than + ;; the function itself. + (current-column))))))) + +(defvar smie-indent-functions + '(smie-indent-fixindent smie-indent-bob smie-indent-close smie-indent-comment + smie-indent-comment-continue smie-indent-keyword smie-indent-after-keyword + smie-indent-exps) + "Functions to compute the indentation. +Each function is called with no argument, shouldn't move point, and should +return either nil if it has no opinion, or an integer representing the column +to which that point should be aligned, if we were to reindent it.") + +(defun smie-indent-calculate () + "Compute the indentation to use for point." + (run-hook-with-args-until-success 'smie-indent-functions)) + +(defun smie-indent-line () + "Indent current line using the SMIE indentation engine." + (interactive) + (let* ((savep (point)) + (indent (condition-case nil + (save-excursion + (forward-line 0) + (skip-chars-forward " \t") + (if (>= (point) savep) (setq savep nil)) + (or (smie-indent-calculate) 0)) + (error 0)))) + (if (not (numberp indent)) + ;; If something funny is used (e.g. `noindent'), return it. + indent + (if (< indent 0) (setq indent 0)) ;Just in case. + (if savep + (save-excursion (indent-line-to indent)) + (indent-line-to indent))))) + +;;;###autoload +(defun smie-setup (op-levels indent-rules) + (set (make-local-variable 'smie-indent-rules) indent-rules) + (set (make-local-variable 'smie-op-levels) op-levels) + (set (make-local-variable 'indent-line-function) 'smie-indent-line)) + + +(provide 'smie) +;;; smie.el ends here |