diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 94 | ||||
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 77 | ||||
| -rw-r--r-- | lisp/emacs-lisp/checkdoc.el | 3 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 219 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp-mode.el | 5 | ||||
| -rw-r--r-- | lisp/emacs-lisp/package.el | 414 | ||||
| -rw-r--r-- | lisp/emacs-lisp/smie.el | 351 |
7 files changed, 638 insertions, 525 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 0b4043b1f2a..2666fc5b9b7 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1316,35 +1316,38 @@ "Don't call this!" ;; fetch and return the offset for the current opcode. ;; return nil if this opcode has no offset - ;; OP, PTR and BYTES are used and set dynamically - (defvar op) - (defvar ptr) - (defvar bytes) - (cond ((< op byte-nth) - (let ((tem (logand op 7))) - (setq op (logand op 248)) + ;; Used and set dynamically in byte-decompile-bytecode-1. + (defvar bytedecomp-op) + (defvar bytedecomp-ptr) + (defvar bytedecomp-bytes) + (cond ((< bytedecomp-op byte-nth) + (let ((tem (logand bytedecomp-op 7))) + (setq bytedecomp-op (logand bytedecomp-op 248)) (cond ((eq tem 6) - (setq ptr (1+ ptr)) ;offset in next byte - (aref bytes ptr)) + ;; Offset in next byte. + (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (aref bytedecomp-bytes bytedecomp-ptr)) ((eq tem 7) - (setq ptr (1+ ptr)) ;offset in next 2 bytes - (+ (aref bytes ptr) - (progn (setq ptr (1+ ptr)) - (lsh (aref bytes ptr) 8)))) + ;; Offset in next 2 bytes. + (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (+ (aref bytedecomp-bytes bytedecomp-ptr) + (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) (t tem)))) ;offset was in opcode - ((>= op byte-constant) - (prog1 (- op byte-constant) ;offset in opcode - (setq op byte-constant))) - ((and (>= op byte-constant2) - (<= op byte-goto-if-not-nil-else-pop)) - (setq ptr (1+ ptr)) ;offset in next 2 bytes - (+ (aref bytes ptr) - (progn (setq ptr (1+ ptr)) - (lsh (aref bytes ptr) 8)))) - ((and (>= op byte-listN) - (<= op byte-insertN)) - (setq ptr (1+ ptr)) ;offset in next byte - (aref bytes ptr)))) + ((>= bytedecomp-op byte-constant) + (prog1 (- bytedecomp-op byte-constant) ;offset in opcode + (setq bytedecomp-op byte-constant))) + ((and (>= bytedecomp-op byte-constant2) + (<= bytedecomp-op byte-goto-if-not-nil-else-pop)) + ;; Offset in next 2 bytes. + (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (+ (aref bytedecomp-bytes bytedecomp-ptr) + (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) + (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) + ((and (>= bytedecomp-op byte-listN) + (<= bytedecomp-op byte-insertN)) + (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;offset in next byte + (aref bytedecomp-bytes bytedecomp-ptr)))) ;; This de-compiler is used for inline expansion of compiled functions, @@ -1367,19 +1370,20 @@ ;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler. ;; In that case, we put a pc value into the list ;; before each insn (or its label). -(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) - (let ((length (length bytes)) - (ptr 0) optr tags op offset +(defun byte-decompile-bytecode-1 (bytedecomp-bytes constvec + &optional make-spliceable) + (let ((length (length bytedecomp-bytes)) + (bytedecomp-ptr 0) optr tags bytedecomp-op offset lap tmp endtag) - (while (not (= ptr length)) + (while (not (= bytedecomp-ptr length)) (or make-spliceable - (setq lap (cons ptr lap))) - (setq op (aref bytes ptr) - optr ptr + (setq lap (cons bytedecomp-ptr lap))) + (setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr) + optr bytedecomp-ptr offset (disassemble-offset)) ; this does dynamic-scope magic - (setq op (aref byte-code-vector op)) - (cond ((memq op byte-goto-ops) + (setq bytedecomp-op (aref byte-code-vector bytedecomp-op)) + (cond ((memq bytedecomp-op byte-goto-ops) ;; it's a pc (setq offset (cdr (or (assq offset tags) @@ -1387,27 +1391,28 @@ (cons (cons offset (byte-compile-make-tag)) tags))))))) - ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t) - ((memq op byte-constref-ops))) + ((cond ((eq bytedecomp-op 'byte-constant2) + (setq bytedecomp-op 'byte-constant) t) + ((memq bytedecomp-op byte-constref-ops))) (setq tmp (if (>= offset (length constvec)) (list 'out-of-range offset) (aref constvec offset)) - offset (if (eq op 'byte-constant) + offset (if (eq bytedecomp-op 'byte-constant) (byte-compile-get-constant tmp) (or (assq tmp byte-compile-variables) (car (setq byte-compile-variables (cons (list tmp) byte-compile-variables))))))) ((and make-spliceable - (eq op 'byte-return)) - (if (= ptr (1- length)) - (setq op nil) + (eq bytedecomp-op 'byte-return)) + (if (= bytedecomp-ptr (1- length)) + (setq bytedecomp-op nil) (setq offset (or endtag (setq endtag (byte-compile-make-tag))) - op 'byte-goto)))) + bytedecomp-op 'byte-goto)))) ;; lap = ( [ (pc . (op . arg)) ]* ) - (setq lap (cons (cons optr (cons op (or offset 0))) + (setq lap (cons (cons optr (cons bytedecomp-op (or offset 0))) lap)) - (setq ptr (1+ ptr))) + (setq bytedecomp-ptr (1+ bytedecomp-ptr))) ;; take off the dummy nil op that we replaced a trailing "return" with. (let ((rest lap)) (while rest @@ -2036,5 +2041,4 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." byte-optimize-lapcode)))) nil) -;; arch-tag: 0f14076b-737e-4bef-aae6-908826ec1ff1 ;;; byte-opt.el ends here diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index b3ac7b83d79..aec6bdb2f35 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -37,6 +37,7 @@ ;; ======================================================================== ;; Entry points: ;; byte-recompile-directory, byte-compile-file, +;; byte-recompile-file, ;; batch-byte-compile, batch-byte-recompile-directory, ;; byte-compile, compile-defun, ;; display-call-tree @@ -1551,23 +1552,10 @@ that already has a `.elc' file." (not (auto-save-file-name-p bytecomp-source)) (not (string-equal dir-locals-file (file-name-nondirectory - bytecomp-source))) - (setq bytecomp-dest - (byte-compile-dest-file bytecomp-source)) - (if (file-exists-p bytecomp-dest) - ;; File was already compiled. - (or bytecomp-force - (file-newer-than-file-p bytecomp-source - bytecomp-dest)) - ;; No compiled file exists yet. - (and bytecomp-arg - (or (eq 0 bytecomp-arg) - (y-or-n-p (concat "Compile " - bytecomp-source "? ")))))) - (progn (if (and noninteractive (not byte-compile-verbose)) - (message "Compiling %s..." bytecomp-source)) - (let ((bytecomp-res (byte-compile-file - bytecomp-source))) + bytecomp-source)))) + (progn (let ((bytecomp-res (byte-recompile-file + bytecomp-source + bytecomp-force bytecomp-arg))) (cond ((eq bytecomp-res 'no-byte-compile) (setq skip-count (1+ skip-count))) ((eq bytecomp-res t) @@ -1595,6 +1583,60 @@ This is normally set in local file variables at the end of the elisp file: ;; Local Variables:\n;; no-byte-compile: t\n;; End: ") ;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp) +(defun byte-recompile-file (bytecomp-filename &optional bytecomp-force bytecomp-arg load) + "Recompile BYTECOMP-FILENAME file if it needs recompilation. +This happens when its `.elc' file is older than itself. + +If the `.elc' file exists and is up-to-date, normally this +function *does not* compile BYTECOMP-FILENAME. However, if the +prefix argument BYTECOMP-FORCE is set, that means do compile +BYTECOMP-FILENAME even if the destination already exists and is +up-to-date. + +If the `.elc' file does not exist, normally this function *does +not* compile BYTECOMP-FILENAME. If BYTECOMP-ARG is 0, that means +compile the file even if it has never been compiled before. +A nonzero BYTECOMP-ARG means ask the user. + +If LOAD is set, `load' the file after compiling. + +The value returned is the value returned by `byte-compile-file', +or 'no-byte-compile if the file did not need recompilation." + (interactive + (let ((bytecomp-file buffer-file-name) + (bytecomp-file-name nil) + (bytecomp-file-dir nil)) + (and bytecomp-file + (eq (cdr (assq 'major-mode (buffer-local-variables))) + 'emacs-lisp-mode) + (setq bytecomp-file-name (file-name-nondirectory bytecomp-file) + bytecomp-file-dir (file-name-directory bytecomp-file))) + (list (read-file-name (if current-prefix-arg + "Byte compile file: " + "Byte recompile file: ") + bytecomp-file-dir bytecomp-file-name nil) + current-prefix-arg))) + (let ((bytecomp-dest + (byte-compile-dest-file bytecomp-filename)) + ;; Expand now so we get the current buffer's defaults + (bytecomp-filename (expand-file-name bytecomp-filename))) + (if (if (file-exists-p bytecomp-dest) + ;; File was already compiled + ;; Compile if forced to, or filename newer + (or bytecomp-force + (file-newer-than-file-p bytecomp-filename + bytecomp-dest)) + (and bytecomp-arg + (or (eq 0 bytecomp-arg) + (y-or-n-p (concat "Compile " + bytecomp-filename "? "))))) + (progn + (if (and noninteractive (not byte-compile-verbose)) + (message "Compiling %s..." bytecomp-filename)) + (byte-compile-file bytecomp-filename load)) + (when load (load bytecomp-filename)) + 'no-byte-compile))) + ;;;###autoload (defun byte-compile-file (bytecomp-filename &optional load) "Compile a file of Lisp code named BYTECOMP-FILENAME into a file of byte code. @@ -4308,5 +4350,4 @@ and corresponding effects." (run-hooks 'bytecomp-load-hook) -;; arch-tag: 9c97b0f0-8745-4571-bfc3-8dceb677292a ;;; bytecomp.el ends here diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 9acad6e67cb..5e4b0dc96c6 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1388,7 +1388,7 @@ Depends on `checkdoc-this-string-valid' to reset the syntax table so that regexp short cuts work. FP is the function defun information." (let ((case-fold-search nil) ;; Use a marker so if an early check modifies the text, - ;; we won't accidentally loose our place. This could cause + ;; we won't accidentally lose our place. This could cause ;; end-of doc string whitespace to also delete the " char. (s (point)) (e (if (looking-at "\"") @@ -2676,5 +2676,4 @@ function called to create the messages." (provide 'checkdoc) -;; arch-tag: c49a7ec8-3bb7-46f2-bfbc-d5f26e033b26 ;;; checkdoc.el ends here diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index f6d66c64c7a..0cd518bbe62 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -639,7 +639,7 @@ This is compatible with Common Lisp, but note that `defun' and ;;; The "loop" macro. -(defvar args) (defvar loop-accum-var) (defvar loop-accum-vars) +(defvar loop-args) (defvar loop-accum-var) (defvar loop-accum-vars) (defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps) (defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag) (defvar loop-initially) (defvar loop-map-form) (defvar loop-name) @@ -647,7 +647,7 @@ This is compatible with Common Lisp, but note that `defun' and (defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs) ;;;###autoload -(defmacro loop (&rest args) +(defmacro loop (&rest loop-args) "The Common Lisp `loop' macro. Valid clauses are: for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, @@ -662,8 +662,8 @@ Valid clauses are: finally return EXPR, named NAME. \(fn CLAUSE...)" - (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args)))))) - (list 'block nil (list* 'while t args)) + (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list loop-args)))))) + (list 'block nil (list* 'while t loop-args)) (let ((loop-name nil) (loop-bindings nil) (loop-body nil) (loop-steps nil) (loop-result nil) (loop-result-explicit nil) @@ -672,8 +672,8 @@ Valid clauses are: (loop-initially nil) (loop-finally nil) (loop-map-form nil) (loop-first-flag nil) (loop-destr-temps nil) (loop-symbol-macs nil)) - (setq args (append args '(cl-end-loop))) - (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause)) + (setq loop-args (append loop-args '(cl-end-loop))) + (while (not (eq (car loop-args) 'cl-end-loop)) (cl-parse-loop-clause)) (if loop-finish-flag (push `((,loop-finish-flag t)) loop-bindings)) (if loop-first-flag @@ -713,34 +713,34 @@ Valid clauses are: (setq body (list (list* 'symbol-macrolet loop-symbol-macs body)))) (list* 'block loop-name body))))) -(defun cl-parse-loop-clause () ; uses args, loop-* - (let ((word (pop args)) +(defun cl-parse-loop-clause () ; uses loop-* + (let ((word (pop loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) (key-types '(key-code key-codes key-seq key-seqs key-binding key-bindings))) (cond - ((null args) + ((null loop-args) (error "Malformed `loop' macro")) ((eq word 'named) - (setq loop-name (pop args))) + (setq loop-name (pop loop-args))) ((eq word 'initially) - (if (memq (car args) '(do doing)) (pop args)) - (or (consp (car args)) (error "Syntax error on `initially' clause")) - (while (consp (car args)) - (push (pop args) loop-initially))) + (if (memq (car loop-args) '(do doing)) (pop loop-args)) + (or (consp (car loop-args)) (error "Syntax error on `initially' clause")) + (while (consp (car loop-args)) + (push (pop loop-args) loop-initially))) ((eq word 'finally) - (if (eq (car args) 'return) - (setq loop-result-explicit (or (cl-pop2 args) '(quote nil))) - (if (memq (car args) '(do doing)) (pop args)) - (or (consp (car args)) (error "Syntax error on `finally' clause")) - (if (and (eq (caar args) 'return) (null loop-name)) - (setq loop-result-explicit (or (nth 1 (pop args)) '(quote nil))) - (while (consp (car args)) - (push (pop args) loop-finally))))) + (if (eq (car loop-args) 'return) + (setq loop-result-explicit (or (cl-pop2 loop-args) '(quote nil))) + (if (memq (car loop-args) '(do doing)) (pop loop-args)) + (or (consp (car loop-args)) (error "Syntax error on `finally' clause")) + (if (and (eq (caar loop-args) 'return) (null loop-name)) + (setq loop-result-explicit (or (nth 1 (pop loop-args)) '(quote nil))) + (while (consp (car loop-args)) + (push (pop loop-args) loop-finally))))) ((memq word '(for as)) (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) @@ -749,29 +749,29 @@ Valid clauses are: ;; Use `gensym' rather than `make-symbol'. It's important that ;; (not (eq (symbol-name var1) (symbol-name var2))) because ;; these vars get added to the cl-macro-environment. - (let ((var (or (pop args) (gensym "--cl-var--")))) - (setq word (pop args)) - (if (eq word 'being) (setq word (pop args))) - (if (memq word '(the each)) (setq word (pop args))) + (let ((var (or (pop loop-args) (gensym "--cl-var--")))) + (setq word (pop loop-args)) + (if (eq word 'being) (setq word (pop loop-args))) + (if (memq word '(the each)) (setq word (pop loop-args))) (if (memq word '(buffer buffers)) - (setq word 'in args (cons '(buffer-list) args))) + (setq word 'in loop-args (cons '(buffer-list) loop-args))) (cond ((memq word '(from downfrom upfrom to downto upto above below by)) - (push word args) - (if (memq (car args) '(downto above)) + (push word loop-args) + (if (memq (car loop-args) '(downto above)) (error "Must specify `from' value for downward loop")) - (let* ((down (or (eq (car args) 'downfrom) - (memq (caddr args) '(downto above)))) - (excl (or (memq (car args) '(above below)) - (memq (caddr args) '(above below)))) - (start (and (memq (car args) '(from upfrom downfrom)) - (cl-pop2 args))) - (end (and (memq (car args) + (let* ((down (or (eq (car loop-args) 'downfrom) + (memq (caddr loop-args) '(downto above)))) + (excl (or (memq (car loop-args) '(above below)) + (memq (caddr loop-args) '(above below)))) + (start (and (memq (car loop-args) '(from upfrom downfrom)) + (cl-pop2 loop-args))) + (end (and (memq (car loop-args) '(to upto downto above below)) - (cl-pop2 args))) - (step (and (eq (car args) 'by) (cl-pop2 args))) + (cl-pop2 loop-args))) + (step (and (eq (car loop-args) 'by) (cl-pop2 loop-args))) (end-var (and (not (cl-const-expr-p end)) (make-symbol "--cl-var--"))) (step-var (and (not (cl-const-expr-p step)) @@ -794,7 +794,7 @@ Valid clauses are: (let* ((on (eq word 'on)) (temp (if (and on (symbolp var)) var (make-symbol "--cl-var--")))) - (push (list temp (pop args)) loop-for-bindings) + (push (list temp (pop loop-args)) loop-for-bindings) (push (list 'consp temp) loop-body) (if (eq word 'in-ref) (push (list var (list 'car temp)) loop-symbol-macs) @@ -804,8 +804,8 @@ Valid clauses are: (push (list var (if on temp (list 'car temp))) loop-for-sets)))) (push (list temp - (if (eq (car args) 'by) - (let ((step (cl-pop2 args))) + (if (eq (car loop-args) 'by) + (let ((step (cl-pop2 loop-args))) (if (and (memq (car-safe step) '(quote function function*)) @@ -816,10 +816,10 @@ Valid clauses are: loop-for-steps))) ((eq word '=) - (let* ((start (pop args)) - (then (if (eq (car args) 'then) (cl-pop2 args) start))) + (let* ((start (pop loop-args)) + (then (if (eq (car loop-args) 'then) (cl-pop2 loop-args) start))) (push (list var nil) loop-for-bindings) - (if (or ands (eq (car args) 'and)) + (if (or ands (eq (car loop-args) 'and)) (progn (push `(,var (if ,(or loop-first-flag @@ -839,7 +839,7 @@ Valid clauses are: ((memq word '(across across-ref)) (let ((temp-vec (make-symbol "--cl-vec--")) (temp-idx (make-symbol "--cl-idx--"))) - (push (list temp-vec (pop args)) loop-for-bindings) + (push (list temp-vec (pop loop-args)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) (push (list '< (list 'setq temp-idx (list '1+ temp-idx)) (list 'length temp-vec)) loop-body) @@ -851,15 +851,15 @@ Valid clauses are: loop-for-sets)))) ((memq word '(element elements)) - (let ((ref (or (memq (car args) '(in-ref of-ref)) - (and (not (memq (car args) '(in of))) + (let ((ref (or (memq (car loop-args) '(in-ref of-ref)) + (and (not (memq (car loop-args) '(in of))) (error "Expected `of'")))) - (seq (cl-pop2 args)) + (seq (cl-pop2 loop-args)) (temp-seq (make-symbol "--cl-seq--")) - (temp-idx (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (eq (caadr args) 'index)) - (cadr (cl-pop2 args)) + (temp-idx (if (eq (car loop-args) 'using) + (if (and (= (length (cadr loop-args)) 2) + (eq (caadr loop-args) 'index)) + (cadr (cl-pop2 loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-idx--")))) (push (list temp-seq seq) loop-for-bindings) @@ -885,13 +885,13 @@ Valid clauses are: loop-for-steps))) ((memq word hash-types) - (or (memq (car args) '(in of)) (error "Expected `of'")) - (let* ((table (cl-pop2 args)) - (other (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (memq (caadr args) hash-types) - (not (eq (caadr args) word))) - (cadr (cl-pop2 args)) + (or (memq (car loop-args) '(in of)) (error "Expected `of'")) + (let* ((table (cl-pop2 loop-args)) + (other (if (eq (car loop-args) 'using) + (if (and (= (length (cadr loop-args)) 2) + (memq (caadr loop-args) hash-types) + (not (eq (caadr loop-args) word))) + (cadr (cl-pop2 loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(hash-value hash-values)) @@ -901,16 +901,16 @@ Valid clauses are: ((memq word '(symbol present-symbol external-symbol symbols present-symbols external-symbols)) - (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args)))) + (let ((ob (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args)))) (setq loop-map-form `(mapatoms (lambda (,var) . --cl-map) ,ob)))) ((memq word '(overlay overlays extent extents)) (let ((buf nil) (from nil) (to nil)) - (while (memq (car args) '(in of from to)) - (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) - ((eq (car args) 'to) (setq to (cl-pop2 args))) - (t (setq buf (cl-pop2 args))))) + (while (memq (car loop-args) '(in of from to)) + (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args))) + ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args))) + (t (setq buf (cl-pop2 loop-args))))) (setq loop-map-form `(cl-map-extents (lambda (,var ,(make-symbol "--cl-var--")) @@ -921,12 +921,12 @@ Valid clauses are: (let ((buf nil) (prop nil) (from nil) (to nil) (var1 (make-symbol "--cl-var1--")) (var2 (make-symbol "--cl-var2--"))) - (while (memq (car args) '(in of property from to)) - (cond ((eq (car args) 'from) (setq from (cl-pop2 args))) - ((eq (car args) 'to) (setq to (cl-pop2 args))) - ((eq (car args) 'property) - (setq prop (cl-pop2 args))) - (t (setq buf (cl-pop2 args))))) + (while (memq (car loop-args) '(in of property from to)) + (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args))) + ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args))) + ((eq (car loop-args) 'property) + (setq prop (cl-pop2 loop-args))) + (t (setq buf (cl-pop2 loop-args))))) (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) (setq var1 (car var) var2 (cdr var)) (push (list var (list 'cons var1 var2)) loop-for-sets)) @@ -936,13 +936,13 @@ Valid clauses are: ,buf ,prop ,from ,to)))) ((memq word key-types) - (or (memq (car args) '(in of)) (error "Expected `of'")) - (let ((map (cl-pop2 args)) - (other (if (eq (car args) 'using) - (if (and (= (length (cadr args)) 2) - (memq (caadr args) key-types) - (not (eq (caadr args) word))) - (cadr (cl-pop2 args)) + (or (memq (car loop-args) '(in of)) (error "Expected `of'")) + (let ((map (cl-pop2 loop-args)) + (other (if (eq (car loop-args) 'using) + (if (and (= (length (cadr loop-args)) 2) + (memq (caadr loop-args) key-types) + (not (eq (caadr loop-args) word))) + (cadr (cl-pop2 loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(key-binding key-bindings)) @@ -964,7 +964,7 @@ Valid clauses are: loop-for-steps))) ((memq word '(window windows)) - (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) + (let ((scr (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args))) (temp (make-symbol "--cl-var--"))) (push (list var (if scr (list 'frame-selected-window scr) @@ -982,9 +982,9 @@ Valid clauses are: (if handler (funcall handler var) (error "Expected a `for' preposition, found %s" word))))) - (eq (car args) 'and)) + (eq (car loop-args) 'and)) (setq ands t) - (pop args)) + (pop loop-args)) (if (and ands loop-for-bindings) (push (nreverse loop-for-bindings) loop-bindings) (setq loop-bindings (nconc (mapcar 'list loop-for-bindings) @@ -1000,11 +1000,11 @@ Valid clauses are: ((eq word 'repeat) (let ((temp (make-symbol "--cl-var--"))) - (push (list (list temp (pop args))) loop-bindings) + (push (list (list temp (pop loop-args))) loop-bindings) (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body))) ((memq word '(collect collecting)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum nil 'nreverse))) (if (eq var loop-accum-var) (push (list 'progn (list 'push what var) t) loop-body) @@ -1013,7 +1013,7 @@ Valid clauses are: t) loop-body)))) ((memq word '(nconc nconcing append appending)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum nil 'nreverse))) (push (list 'progn (list 'setq var @@ -1028,27 +1028,27 @@ Valid clauses are: var what))) t) loop-body))) ((memq word '(concat concating)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum ""))) (push (list 'progn (list 'callf 'concat var what) t) loop-body))) ((memq word '(vconcat vconcating)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum []))) (push (list 'progn (list 'callf 'vconcat var what) t) loop-body))) ((memq word '(sum summing)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum 0))) (push (list 'progn (list 'incf var what) t) loop-body))) ((memq word '(count counting)) - (let ((what (pop args)) + (let ((what (pop loop-args)) (var (cl-loop-handle-accum 0))) (push (list 'progn (list 'if what (list 'incf var)) t) loop-body))) ((memq word '(minimize minimizing maximize maximizing)) - (let* ((what (pop args)) + (let* ((what (pop loop-args)) (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--"))) (var (cl-loop-handle-accum nil)) (func (intern (substring (symbol-name word) 0 3))) @@ -1059,27 +1059,27 @@ Valid clauses are: ((eq word 'with) (let ((bindings nil)) - (while (progn (push (list (pop args) - (and (eq (car args) '=) (cl-pop2 args))) + (while (progn (push (list (pop loop-args) + (and (eq (car loop-args) '=) (cl-pop2 loop-args))) bindings) - (eq (car args) 'and)) - (pop args)) + (eq (car loop-args) 'and)) + (pop loop-args)) (push (nreverse bindings) loop-bindings))) ((eq word 'while) - (push (pop args) loop-body)) + (push (pop loop-args) loop-body)) ((eq word 'until) - (push (list 'not (pop args)) loop-body)) + (push (list 'not (pop loop-args)) loop-body)) ((eq word 'always) (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (push (list 'setq loop-finish-flag (pop args)) loop-body) + (push (list 'setq loop-finish-flag (pop loop-args)) loop-body) (setq loop-result t)) ((eq word 'never) (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (push (list 'setq loop-finish-flag (list 'not (pop args))) + (push (list 'setq loop-finish-flag (list 'not (pop loop-args))) loop-body) (setq loop-result t)) @@ -1087,20 +1087,20 @@ Valid clauses are: (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--"))) (push (list 'setq loop-finish-flag - (list 'not (list 'setq loop-result-var (pop args)))) + (list 'not (list 'setq loop-result-var (pop loop-args)))) loop-body)) ((memq word '(if when unless)) - (let* ((cond (pop args)) + (let* ((cond (pop loop-args)) (then (let ((loop-body nil)) (cl-parse-loop-clause) (cl-loop-build-ands (nreverse loop-body)))) (else (let ((loop-body nil)) - (if (eq (car args) 'else) - (progn (pop args) (cl-parse-loop-clause))) + (if (eq (car loop-args) 'else) + (progn (pop loop-args) (cl-parse-loop-clause))) (cl-loop-build-ands (nreverse loop-body)))) (simple (and (eq (car then) t) (eq (car else) t)))) - (if (eq (car args) 'end) (pop args)) + (if (eq (car loop-args) 'end) (pop loop-args)) (if (eq word 'unless) (setq then (prog1 else (setq else then)))) (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) (if simple (nth 1 else) (list (nth 2 else)))))) @@ -1114,22 +1114,22 @@ Valid clauses are: ((memq word '(do doing)) (let ((body nil)) - (or (consp (car args)) (error "Syntax error on `do' clause")) - (while (consp (car args)) (push (pop args) body)) + (or (consp (car loop-args)) (error "Syntax error on `do' clause")) + (while (consp (car loop-args)) (push (pop loop-args) body)) (push (cons 'progn (nreverse (cons t body))) loop-body))) ((eq word 'return) (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--"))) (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--"))) - (push (list 'setq loop-result-var (pop args) + (push (list 'setq loop-result-var (pop loop-args) loop-finish-flag nil) loop-body)) (t (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) (or handler (error "Expected a loop keyword, found %s" word)) (funcall handler)))) - (if (eq (car args) 'and) - (progn (pop args) (cl-parse-loop-clause))))) + (if (eq (car loop-args) 'and) + (progn (pop loop-args) (cl-parse-loop-clause))))) (defun cl-loop-let (specs body par) ; uses loop-* (let ((p specs) (temps nil) (new nil)) @@ -1165,9 +1165,9 @@ Valid clauses are: (list* (if par 'let 'let*) (nconc (nreverse temps) (nreverse new)) body)))) -(defun cl-loop-handle-accum (def &optional func) ; uses args, loop-* - (if (eq (car args) 'into) - (let ((var (cl-pop2 args))) +(defun cl-loop-handle-accum (def &optional func) ; uses loop-* + (if (eq (car loop-args) 'into) + (let ((var (cl-pop2 loop-args))) (or (memq var loop-accum-vars) (progn (push (list (list var def)) loop-bindings) (push var loop-accum-vars))) @@ -2791,5 +2791,4 @@ surrounded by (block NAME ...). ;; generated-autoload-file: "cl-loaddefs.el" ;; End: -;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46 ;;; cl-macs.el ends here diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index e4330e43fc9..ef639d6ec37 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -407,10 +407,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") (if (and (buffer-modified-p) (y-or-n-p (format "Save buffer %s first? " (buffer-name)))) (save-buffer)) - (let ((compiled-file-name (byte-compile-dest-file buffer-file-name))) - (if (file-newer-than-file-p compiled-file-name buffer-file-name) - (load-file compiled-file-name) - (byte-compile-file buffer-file-name t)))) + (byte-recompile-file buffer-file-name nil 0 t)) (defcustom emacs-lisp-mode-hook nil "Hook run when entering Emacs Lisp mode." diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ea4c14e7cda..6d3132c1250 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -77,7 +77,7 @@ ;; Other external functions you may want to use: ;; -;; M-x package-list-packages +;; M-x list-packages ;; Enters a mode similar to buffer-menu which lets you manage ;; packages. You can choose packages for install (mark with "i", ;; then "x" to execute) or deletion (not implemented yet), and you @@ -215,7 +215,6 @@ If VERSION is nil, the package is not loaded (it is \"disabled\")." (declare-function url-http-parse-response "url-http" ()) (declare-function lm-header "lisp-mnt" (header)) (declare-function lm-commentary "lisp-mnt" (&optional file)) -(declare-function dired-delete-file "dired" (file &optional recursive trash)) (defvar url-http-end-of-headers) (defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/")) @@ -278,9 +277,12 @@ contrast, `package-user-dir' contains packages for personal use." ;; until it's needed (i.e. when `package-intialize' is called). (defvar package--builtins nil "Alist of built-in packages. +The actual value is initialized by loading the library +`finder-inf'; this is not done until it is needed, e.g. by the +function `package-built-in-p'. + Each element has the form (PKG . DESC), where PKG is a package name (a symbol) and DESC is a vector that describes the package. - The vector DESC has the form [VERSION REQS DOCSTRING]. VERSION is a version list. REQS is a list of packages (symbols) required by the package. @@ -329,7 +331,9 @@ E.g., if given \"quux-23.0\", will return \"quux\"" (match-string 1 dirname))) (defun package-load-descriptor (dir package) - "Load the description file in directory DIR for package PACKAGE." + "Load the description file in directory DIR for package PACKAGE. +Here, PACKAGE is a string of the form NAME-VER, where NAME is the +package name and VER is its version." (let* ((pkg-dir (expand-file-name package dir)) (pkg-file (expand-file-name (concat (package-strip-version package) "-pkg") @@ -387,8 +391,10 @@ updates `package-alist' and `package-obsolete-alist'." "Extract the kind of download from an archive package description vector." (aref desc 3)) -(defun package--dir (name version-string) - (let* ((subdir (concat name "-" version-string)) +(defun package--dir (name version) + "Return the directory where a package is installed, or nil if none. +NAME and VERSION are both strings." + (let* ((subdir (concat name "-" version)) (dir-list (cons package-user-dir package-directory-list)) pkg-dir) (while dir-list @@ -404,7 +410,7 @@ updates `package-alist' and `package-obsolete-alist'." (version-str (package-version-join (package-desc-vers pkg-vec))) (pkg-dir (package--dir name version-str))) (unless pkg-dir - (error "Internal error: could not find directory for %s-%s" + (error "Internal error: unable to find directory for `%s-%s'" name version-str)) ;; Add info node. (when (file-exists-p (expand-file-name "dir" pkg-dir)) @@ -419,42 +425,46 @@ updates `package-alist' and `package-obsolete-alist'." ;; Don't return nil. t)) -(defun package--built-in (package version) - "Return true if the package is built-in to Emacs." +(defun package-built-in-p (package &optional version) + "Return true if PACKAGE, of VERSION or newer, is built-in to Emacs." + (require 'finder-inf nil t) ; For `package--builtins'. (let ((elt (assq package package--builtins))) - (and elt (version-list-= (package-desc-vers (cdr elt)) version)))) + (and elt (version-list-<= version (package-desc-vers (cdr elt)))))) -;; FIXME: return a reason instead? +;; This function goes ahead and activates a newer version of a package +;; if an older one was already activated. This is not ideal; we'd at +;; least need to check to see if the package has actually been loaded, +;; and not merely activated. (defun package-activate (package version) - "Activate a package, and recursively activate its dependencies. + "Activate package PACKAGE, of version VERSION or newer. +If PACKAGE has any dependencies, recursively activate them. Return nil if the package could not be activated." - ;; Assume the user knows what he is doing -- go ahead and activate a - ;; newer version of a package if an older one has already been - ;; activated. This is not ideal; we'd at least need to check to see - ;; if the package has actually been loaded, and not merely - ;; activated. However, don't try to activate 'emacs', as that makes - ;; no sense. - (unless (eq package 'emacs) - (let* ((pkg-desc (assq package package-alist)) - (this-version (package-desc-vers (cdr pkg-desc))) - (req-list (package-desc-reqs (cdr pkg-desc))) - ;; If the package was never activated, do it now. - (keep-going (or (not (memq package package-activated-list)) - (version-list-< version this-version)))) - (while (and req-list keep-going) - (let* ((req (car req-list)) - (req-name (car req)) - (req-version (cadr req))) - (or (package-activate req-name req-version) - (setq keep-going nil))) - (setq req-list (cdr req-list))) - (if keep-going - (package-activate-1 package (cdr pkg-desc)) - ;; We get here if a dependency failed to activate -- but we - ;; can also get here if the requested package was already - ;; activated. Return non-nil in the latter case. - (and (memq package package-activated-list) - (version-list-<= version this-version)))))) + (let ((pkg-vec (cdr (assq package package-alist))) + available-version found) + ;; Check if PACKAGE is available in `package-alist'. + (when pkg-vec + (setq available-version (package-desc-vers pkg-vec) + found (version-list-<= version available-version))) + (cond + ;; If no such package is found, maybe it's built-in. + ((null found) + (package-built-in-p package version)) + ;; If the package is already activated, just return t. + ((memq package package-activated-list) + t) + ;; Otherwise, proceed with activation. + (t + (let ((fail (catch 'dep-failure + ;; Activate its dependencies recursively. + (dolist (req (package-desc-reqs pkg-vec)) + (unless (package-activate (car req) (cadr req)) + (throw 'dep-failure req)))))) + (if fail + (warn "Unable to activate package `%s'. +Required package `%s-%s' is unavailable" + package (car fail) (package-version-join (cadr fail))) + ;; If all goes well, activate the package itself. + (package-activate-1 package pkg-vec))))))) (defun package-mark-obsolete (package pkg-vec) "Put package on the obsolete list, if not already there." @@ -470,48 +480,45 @@ Return nil if the package could not be activated." pkg-vec))) package-obsolete-alist)))) -(defun define-package (name-str version-string +(defun define-package (name-string version-string &optional docstring requirements &rest extra-properties) "Define a new package. -NAME is the name of the package, a string. -VERSION-STRING is the version of the package, a dotted sequence -of integers. -DOCSTRING is the optional description. -REQUIREMENTS is a list of requirements on other packages. +NAME-STRING is the name of the package, as a string. +VERSION-STRING is the version of the package, as a list of +integers of the form produced by `version-to-list'. +DOCSTRING is a short description of the package, a string. +REQUIREMENTS is a list of dependencies on other packages. Each requirement is of the form (OTHER-PACKAGE \"VERSION\"). EXTRA-PROPERTIES is currently unused." - (let* ((name (intern name-str)) - (pkg-desc (assq name package-alist)) - (new-version (version-to-list version-string)) + (let* ((name (intern name-string)) + (version (version-to-list version-string)) (new-pkg-desc (cons name - (vector new-version + (vector version (mapcar (lambda (elt) (list (car elt) (version-to-list (car (cdr elt))))) requirements) - docstring)))) - ;; Only redefine a package if the redefinition is newer. - (if (or (not pkg-desc) - (version-list-< (package-desc-vers (cdr pkg-desc)) - new-version)) - (progn - (when pkg-desc - ;; Remove old package and declare it obsolete. - (setq package-alist (delq pkg-desc package-alist)) - (package-mark-obsolete (car pkg-desc) (cdr pkg-desc))) - ;; Add package to the alist. - (push new-pkg-desc package-alist)) - ;; You can have two packages with the same version, for instance - ;; one in the system package directory and one in your private - ;; directory. We just let the first one win. - (unless (version-list-= new-version - (package-desc-vers (cdr pkg-desc))) - ;; The package is born obsolete. - (package-mark-obsolete (car new-pkg-desc) (cdr new-pkg-desc)))))) + docstring))) + (old-pkg (assq name package-alist))) + (cond + ;; If there's no old package, just add this to `package-alist'. + ((null old-pkg) + (push new-pkg-desc package-alist)) + ((version-list-< (package-desc-vers (cdr old-pkg)) version) + ;; Remove the old package and declare it obsolete. + (package-mark-obsolete name (cdr old-pkg)) + (setq package-alist (cons new-pkg-desc + (delq old-pkg package-alist)))) + ;; You can have two packages with the same version, e.g. one in + ;; the system package directory and one in your private + ;; directory. We just let the first one win. + ((not (version-list-= (package-desc-vers (cdr old-pkg)) version)) + ;; The package is born obsolete. + (package-mark-obsolete name (cdr new-pkg-desc)))))) ;; From Emacs 22. (defun package-autoload-ensure-default-file (file) @@ -562,12 +569,8 @@ Otherwise it uses an external `tar' program. (defun package-unpack (name version) (let ((pkg-dir (expand-file-name (concat (symbol-name name) "-" version) package-user-dir))) - ;; Be careful!! (make-directory package-user-dir t) - (if (file-directory-p pkg-dir) - (mapc (lambda (file) nil) ; 'delete-file -- FIXME: when we're - ; more confident - (directory-files pkg-dir t "^[^.]"))) + ;; FIXME: should we delete PKG-DIR if it exists? (let* ((default-directory (file-name-as-directory package-user-dir))) (package-untar-buffer) (package-generate-autoloads (symbol-name name) pkg-dir) @@ -605,7 +608,7 @@ Otherwise it uses an external `tar' program. (mapcar (lambda (elt) (list (car elt) - (package-version-join (car (cdr elt))))) + (package-version-join (cadr elt)))) requires)))) "\n") nil @@ -657,10 +660,14 @@ It will move point to somewhere in the headers." (kill-buffer tar-buffer)))) (defun package-installed-p (package &optional min-version) + "Return true if PACKAGE, of VERSION or newer, is installed. +Built-in packages also qualify." (let ((pkg-desc (assq package package-alist))) - (and pkg-desc - (version-list-<= min-version - (package-desc-vers (cdr pkg-desc)))))) + (if pkg-desc + (version-list-<= min-version + (package-desc-vers (cdr pkg-desc))) + ;; Also check built-in packages. + (package-built-in-p package min-version)))) (defun package-compute-transaction (package-list requirements) "Return a list of packages to be installed, including PACKAGE-LIST. @@ -691,17 +698,18 @@ not included in this list." ((null (stringp hold)) (error "Invalid element in `package-load-list'")) ((version-list-< (version-to-list hold) next-version) - (error "Package '%s' held at version %s, \ + (error "Package `%s' held at version %s, \ but version %s required" (symbol-name next-pkg) hold (package-version-join next-version))))) (unless pkg-desc - (error "Package '%s' is not available for installation" - (symbol-name next-pkg))) + (error "Package `%s-%s' is unavailable" + (symbol-name next-pkg) + (package-version-join next-version))) (unless (version-list-<= next-version (package-desc-vers (cdr pkg-desc))) (error - "Need package '%s' with version %s, but only %s is available" + "Need package `%s-%s', but only %s is available" (symbol-name next-pkg) (package-version-join next-version) (package-version-join (package-desc-vers (cdr pkg-desc))))) ;; Only add to the transaction if we don't already have it. @@ -811,7 +819,7 @@ The package is found on one of the archives in `package-archives'." nil t)))) (let ((pkg-desc (assq name package-archive-contents))) (unless pkg-desc - (error "Package '%s' is not available for installation" + (error "Package `%s' is not available for installation" (symbol-name name))) (package-download-transaction (package-compute-transaction (list name) @@ -968,11 +976,16 @@ The file can either be a tar file or an Emacs Lisp file." (t (error "Unrecognized extension `%s'" (file-name-extension file)))))) (defun package-delete (name version) - (require 'dired) ; for dired-delete-file - (dired-delete-file (expand-file-name (concat name "-" version) - package-user-dir) - ;; FIXME: query user? - 'always)) + (let ((dir (package--dir name version))) + (if (string-equal (file-name-directory dir) + (file-name-as-directory + (expand-file-name package-user-dir))) + (progn + (delete-directory dir t t) + (message "Package `%s-%s' deleted." name version)) + ;; Don't delete "system" packages + (error "Package `%s-%s' is a system package, not deleting" + name version)))) (defun package-archive-url (name) "Return the archive containing the package NAME." @@ -1014,21 +1027,22 @@ makes them available for download." (car archive))))) (package-read-all-archive-contents)) +(defvar package--initialized nil) + ;;;###autoload -(defun package-initialize () +(defun package-initialize (&optional no-activate) "Load Emacs Lisp packages, and activate them. -The variable `package-load-list' controls which packages to load." +The variable `package-load-list' controls which packages to load. +If optional arg NO-ACTIVATE is non-nil, don't activate packages." (interactive) - (require 'finder-inf nil t) - (setq package-alist package--builtins) - (setq package-activated-list (mapcar #'car package-alist)) - (setq package-obsolete-alist nil) + (setq package-alist nil + package-obsolete-alist nil) (package-load-all-descriptors) (package-read-all-archive-contents) - ;; Try to activate all our packages. - (mapc (lambda (elt) - (package-activate (car elt) (package-desc-vers (cdr elt)))) - package-alist)) + (unless no-activate + (dolist (elt package-alist) + (package-activate (car elt) (package-desc-vers (cdr elt))))) + (setq package--initialized t)) ;;;; Package description buffer. @@ -1037,10 +1051,15 @@ The variable `package-load-list' controls which packages to load." (defun describe-package (package) "Display the full documentation of PACKAGE (a symbol)." (interactive - (let* ((packages (append (mapcar 'car package-alist) - (mapcar 'car package-archive-contents))) - (guess (function-called-at-point)) - val) + (let* ((guess (function-called-at-point)) + packages val) + (require 'finder-inf nil t) + ;; Load the package list if necessary (but don't activate them). + (unless package--initialized + (package-initialize t)) + (setq packages (append (mapcar 'car package-alist) + (mapcar 'car package-archive-contents) + (mapcar 'car package--builtins))) (unless (memq guess packages) (setq guess nil)) (setq packages (mapcar 'symbol-name packages)) @@ -1051,8 +1070,8 @@ The variable `package-load-list' controls which packages to load." "Describe package: ") packages nil t nil nil guess)) (list (if (equal val "") guess (intern val))))) - (if (or (null package) (null (symbolp package))) - (message "You did not specify a package") + (if (or (null package) (not (symbolp package))) + (message "No package specified") (help-setup-xref (list #'describe-package package) (called-interactively-p 'interactive)) (with-help-window (help-buffer) @@ -1066,22 +1085,27 @@ The variable `package-load-list' controls which packages to load." desc pkg-dir reqs version installable) (prin1 package) (princ " is ") - (if (setq desc (cdr (assq package package-alist))) - ;; This package is loaded (i.e. in `package-alist'). - (progn - (setq version (package-version-join (package-desc-vers desc))) - (cond (built-in - (princ "a built-in package.\n\n")) - ((setq pkg-dir (package--dir package-name version)) - (insert "an installed package.\n\n")) - (t ;; This normally does not happen. - (insert "a deleted package.\n\n") - (setq version nil)))) - ;; This package is not installed. - (setq desc (cdr (assq package package-archive-contents)) - version (package-version-join (package-desc-vers desc)) + (cond + ;; Loaded packages are in `package-alist'. + ((setq desc (cdr (assq package package-alist))) + (setq version (package-version-join (package-desc-vers desc))) + (if (setq pkg-dir (package--dir package-name version)) + (insert "an installed package.\n\n") + ;; This normally does not happen. + (insert "a deleted package.\n\n"))) + ;; Available packages are in `package-archive-contents'. + ((setq desc (cdr (assq package package-archive-contents))) + (setq version (package-version-join (package-desc-vers desc)) installable t) - (insert "an uninstalled package.\n\n")) + (if built-in + (insert "a built-in package.\n\n") + (insert "an uninstalled package.\n\n"))) + (built-in + (setq desc (cdr built-in) + version (package-version-join (package-desc-vers desc))) + (insert "a built-in package.\n\n")) + (t + (insert "an orphan package.\n\n"))) (insert " " (propertize "Status" 'font-lock-face 'bold) ": ") (cond (pkg-dir @@ -1091,32 +1115,35 @@ The variable `package-load-list' controls which packages to load." ;; Todo: Add button for uninstalling. (help-insert-xref-button (file-name-as-directory pkg-dir) 'help-package-def pkg-dir) - (insert "'.")) + (if built-in + (insert "',\n shadowing a " + (propertize "built-in package" + 'font-lock-face 'font-lock-builtin-face) + ".") + (insert "'."))) (installable - (insert "Available -- ") - (let ((button-text (if (display-graphic-p) - "Install" - "[Install]")) + (if built-in + (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face) + " Alternate version available -- ") + (insert "Available -- ")) + (let ((button-text (if (display-graphic-p) "Install" "[Install]")) (button-face (if (display-graphic-p) '(:box (:line-width 2 :color "dark grey") :background "light grey" :foreground "black") 'link))) - (insert-text-button button-text - 'face button-face - 'follow-link t + (insert-text-button button-text 'face button-face 'follow-link t 'package-symbol package 'action 'package-install-button-action))) (built-in - (insert (propertize "Built-in" - 'font-lock-face 'font-lock-builtin-face) ".")) + (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face))) (t (insert "Deleted."))) (insert "\n") - (and version - (> (length version) 0) + (and version (> (length version) 0) (insert " " (propertize "Version" 'font-lock-face 'bold) ": " version "\n")) - (setq reqs (package-desc-reqs desc)) + + (setq reqs (if desc (package-desc-reqs desc))) (when reqs (insert " " (propertize "Requires" 'font-lock-face 'bold) ": ") (let ((first t) @@ -1134,9 +1161,9 @@ The variable `package-load-list' controls which packages to load." (help-insert-xref-button text 'help-package name)) (insert "\n"))) (insert " " (propertize "Summary" 'font-lock-face 'bold) - ": " (package-desc-doc desc) "\n\n") + ": " (if desc (package-desc-doc desc)) "\n\n") - (if (assq package package--builtins) + (if built-in ;; For built-in packages, insert the commentary. (let ((fn (locate-file (concat package-name ".el") load-path load-file-rep-suffixes)) @@ -1340,12 +1367,16 @@ buffers. The arguments are ignored." (defun package-menu-mark-delete (num) "Mark a package for deletion and move to the next line." (interactive "p") - (package-menu-mark-internal "D")) + (if (string-equal (package-menu-get-status) "installed") + (package-menu-mark-internal "D") + (forward-line))) (defun package-menu-mark-install (num) "Mark a package for installation and move to the next line." (interactive "p") - (package-menu-mark-internal "I")) + (if (string-equal (package-menu-get-status) "available") + (package-menu-mark-internal "I") + (forward-line))) (defun package-menu-mark-unmark (num) "Clear any marks on a package and move to the next line." @@ -1399,34 +1430,58 @@ buffers. The arguments are ignored." ""))) (defun package-menu-execute () - "Perform all the marked actions. -Packages marked for installation will be downloaded and -installed. Packages marked for deletion will be removed. -Note that after installing packages you will want to restart -Emacs." + "Perform marked Package Menu actions. +Packages marked for installation are downloaded and installed; +packages marked for deletion are removed." (interactive) - (goto-char (point-min)) - (while (not (eobp)) - (let ((cmd (char-after)) - (pkg-name (package-menu-get-package)) - (pkg-vers (package-menu-get-version)) - (pkg-status (package-menu-get-status))) - (cond - ((eq cmd ?D) - (when (and (string= pkg-status "installed") - (string= pkg-name "package")) - ;; FIXME: actually, we could be tricky and remove all info. - ;; But that is drastic and the user can do that instead. - (error "Can't delete most recent version of `package'")) - ;; Ask for confirmation here? Maybe if package status is ""? - ;; Or if any lisp from package is actually loaded? - (message "Deleting %s-%s..." pkg-name pkg-vers) - (package-delete pkg-name pkg-vers) - (message "Deleting %s-%s... done" pkg-name pkg-vers)) - ((eq cmd ?I) - (package-install (intern pkg-name))))) - (forward-line)) - (package-menu-revert)) + (let (install-list delete-list cmd) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (setq cmd (char-after)) + (cond + ((eq cmd ?\s) t) + ((eq cmd ?D) + (push (cons (package-menu-get-package) + (package-menu-get-version)) + delete-list)) + ((eq cmd ?I) + (push (package-menu-get-package) install-list))) + (forward-line))) + ;; Delete packages, prompting if necessary. + (when delete-list + (if (yes-or-no-p + (if (= (length delete-list) 1) + (format "Delete package `%s-%s'? " + (caar delete-list) + (cdr (car delete-list))) + (format "Delete these %d packages (%s)? " + (length delete-list) + (mapconcat (lambda (elt) + (concat (car elt) "-" (cdr elt))) + delete-list + ", ")))) + (dolist (elt delete-list) + (condition-case err + (package-delete (car elt) (cdr elt)) + (error (message (cadr err))))) + (error "Aborted"))) + (when install-list + (if (yes-or-no-p + (if (= (length install-list) 1) + (format "Install package `%s'? " (car install-list)) + (format "Install these %d packages (%s)? " + (length install-list) + (mapconcat 'identity install-list ", ")))) + (dolist (elt install-list) + (package-install (intern elt))))) + ;; If we deleted anything, regenerate `package-alist'. This is done + ;; automatically if we installed a package. + (and delete-list (null install-list) + (package-initialize)) + (if (or delete-list install-list) + (package-menu-revert) + (message "No operations specified.")))) (defun package-print-package (package version key desc) (let ((face @@ -1471,31 +1526,36 @@ A value of nil means to display all packages.") (defun package--generate-package-list () "Populate the current Package Menu buffer." - (package-initialize) (let ((inhibit-read-only t) info-list name desc hold builtin) (erase-buffer) ;; List installed packages (dolist (elt package-alist) (setq name (car elt)) - (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. - (or (null package-menu-package-list) - (memq name package-menu-package-list))) + (when (or (null package-menu-package-list) + (memq name package-menu-package-list)) (setq desc (cdr elt) - hold (cadr (assq name package-load-list)) - builtin (cdr (assq name package--builtins))) + hold (cadr (assq name package-load-list))) (setq info-list (package-list-maybe-add name (package-desc-vers desc) ;; FIXME: it turns out to be tricky to see if this ;; package is presently activated. - (cond ((stringp hold) "held") - ((and builtin - (version-list-= - (package-desc-vers builtin) - (package-desc-vers desc))) - "built-in") - (t "installed")) + (if (stringp hold) "held" "installed") + (package-desc-doc desc) + info-list)))) + + ;; List built-in packages + (dolist (elt package--builtins) + (setq name (car elt)) + (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. + (or (null package-menu-package-list) + (memq name package-menu-package-list))) + (setq desc (cdr elt)) + (setq info-list + (package-list-maybe-add + name (package-desc-vers desc) + "built-in" (package-desc-doc desc) info-list)))) @@ -1601,6 +1661,7 @@ A value of nil means to display all packages.") "Generate and pop to the *Packages* buffer. Optional PACKAGES is a list of names of packages (symbols) to list; the default is to display everything in `package-alist'." + (require 'finder-inf nil t) (with-current-buffer (get-buffer-create "*Packages*") (package-menu-mode) (set (make-local-variable 'package-menu-package-list) packages) @@ -1617,6 +1678,9 @@ list; the default is to display everything in `package-alist'." Fetches the updated list of packages before displaying. The list is displayed in a buffer named `*Packages*'." (interactive) + ;; Initialize the package system if necessary. + (unless package--initialized + (package-initialize t)) (package-refresh-contents) (package--list-packages)) diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 4f5b2046150..afb2834414a 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -70,6 +70,10 @@ (eval-when-compile (require 'cl)) +(defgroup smie nil + "Simple Minded Indentation Engine." + :group 'languages) + (defvar comment-continue) (declare-function comment-string-strip "newcomment" (str beforep afterp)) @@ -109,6 +113,7 @@ (display-warning 'smie (format "Conflict: %s %s/%s %s" x old val y))) (puthash key val table)))) +(put 'smie-precs-precedence-table 'pure t) (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 @@ -132,6 +137,7 @@ one of those elements share the same precedence level and associativity." (smie-set-prec2tab prec2-table other-op op op1))))))) prec2-table)) +(put 'smie-merge-prec2s 'pure t) (defun smie-merge-prec2s (&rest tables) (if (null (cdr tables)) (car tables) @@ -147,6 +153,7 @@ one of those elements share the same precedence level and associativity." table)) prec2))) +(put 'smie-bnf-precedence-table 'pure t) (defun smie-bnf-precedence-table (bnf &rest precs) (let ((nts (mapcar 'car bnf)) ;Non-terminals (first-ops-table ()) @@ -233,6 +240,7 @@ one of those elements share the same precedence level and associativity." ;; Keep track of which tokens are openers/closer, so they can get a nil ;; precedence in smie-prec2-levels. (puthash :smie-open/close-alist (smie-bnf-classify bnf) prec2) + (puthash :smie-closer-alist (smie-bnf-closer-alist bnf) prec2) prec2)) ;; (defun smie-prec2-closer-alist (prec2 include-inners) @@ -377,6 +385,7 @@ CSTS is a list of pairs representing arcs in a graph." (append names (list (car names))) " < "))) +(put 'smie-prec2-levels 'pure t) (defun smie-prec2-levels (prec2) ;; FIXME: Rather than only return an alist of precedence levels, we should ;; also extract other useful data from it: @@ -479,6 +488,8 @@ PREC2 is a table as returned by `smie-precs-precedence-table' or (eq 'closer (cdr (assoc (car x) classification-table)))) (setf (nth 2 x) i) (incf i))))) ;See other (incf i) above. + (let ((ca (gethash :smie-closer-alist prec2))) + (when ca (push (cons :smie-closer-alist ca) table))) table)) ;;; Parsing using a precedence level table. @@ -783,7 +794,8 @@ I.e. a good choice can be: (defcustom smie-blink-matching-inners t "Whether SMIE should blink to matching opener for inner keywords. If non-nil, it will blink not only for \"begin..end\" but also for \"if...else\"." - :type 'boolean) + :type 'boolean + :group 'smie) (defun smie-blink-matching-check (start end) (save-excursion @@ -803,14 +815,22 @@ If non-nil, it will blink not only for \"begin..end\" but also for \"if...else\" (defun smie-blink-matching-open () "Blink the matching opener when applicable. This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'." + (let ((pos (point)) ;Position after the close token. + token) (when (and blink-matching-paren smie-closer-alist ; Optimization. - (eq (char-before) last-command-event) ; Sanity check. + (or (eq (char-before) last-command-event) ;; Sanity check. + (save-excursion + (or (progn (skip-chars-backward " \t") + (setq pos (point)) + (eq (char-before) last-command-event)) + (progn (skip-chars-backward " \n\t") + (setq pos (point)) + (eq (char-before) last-command-event))))) (memq last-command-event smie-blink-matching-triggers) (not (nth 8 (syntax-ppss)))) (save-excursion - (let ((pos (point)) - (token (funcall smie-backward-token-function))) + (setq token (funcall smie-backward-token-function)) (when (and (eq (point) (1- pos)) (= 1 (length token)) (not (rassoc token smie-closer-alist))) @@ -818,17 +838,20 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'. ;; closers (e.g. ?\; in Octave mode), so go back to the ;; previous token. (setq pos (point)) - (setq token (save-excursion - (funcall smie-backward-token-function)))) + (setq token (funcall smie-backward-token-function))) (when (rassoc token smie-closer-alist) ;; We're after a close token. Let's still make sure we ;; didn't skip a comment to find that token. (funcall smie-forward-token-function) (when (and (save-excursion - ;; Trigger can be SPC, or reindent. - (skip-chars-forward " \n\t") + ;; Skip the trigger char, if applicable. + (if (eq (char-after) last-command-event) + (forward-char 1)) + (if (eq ?\n last-command-event) + ;; Skip any auto-indentation, if applicable. + (skip-chars-forward " \t")) (>= (point) pos)) - ;; If token ends with a trigger char, so don't blink for + ;; If token ends with a trigger char, don't blink for ;; anything else than this trigger char, lest we'd blink ;; both when inserting the trigger char and when ;; inserting a subsequent trigger char like SPC. @@ -848,36 +871,28 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'. (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. -\(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. -\((T1 . T2) OFFSET) like ((:before . T2) (:parent T1 OFFSET)). - -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 -\(:bolp . OFFSET-RULES) If TOK is first on a line, use OFFSET-RULES. -OFFSET the offset to use. - -PARENT can be either the name of the parent or a list of such names. + :type 'integer + :group 'smie) + +(defvar smie-rules-function 'ignore + "Function providing the indentation rules. +It takes two arguments METHOD and ARG where the meaning of ARG +and the expected return value depends on METHOD. +METHOD can be: +- :after, in which case ARG is a token and the function should return the + OFFSET to use for indentation after ARG. +- :before, in which case ARG is a token and the function should return the + OFFSET to use to indent ARG itself. +- :elem, in which case the function should return either: + - the offset to use to indent function arguments (ARG = `arg') + - the basic indentation step (ARG = `basic'). +- :list-intro, in which case ARG is a token and the function should return + non-nil if TOKEN is followed by a list of expressions (not separated by any + token) rather than an expression. + +When ARG is a token, the function is called with point just before that token. +A return value of nil always means to fallback on the default behavior, so the +function should return nil for arguments it does not expect. OFFSET can be of the form: `point' align with the token. @@ -886,91 +901,69 @@ NUMBER offset by NUMBER. \(+ OFFSETS...) use the sum of OFFSETS. VARIABLE use the value of VARIABLE as offset. -The precise meaning of `point' depends on various details: it can -either mean the position of the token we're indenting, or the -position of its parent, or the position right after its parent. - -A nil offset for indentation after an opening token defaults -to `smie-indent-basic'.") +This function will often use some of the following functions designed +specifically for it: +`smie-bolp', `smie-hanging-p', `smie-parent-p', `smie-next-p', `smie-prev-p'.") -(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 +(defun smie-hanging-p () + "Return non-nil if the current token is \"hanging\". +A hanging keyword is one that's at the end of a line except it's not at +the beginning of a line." + (and (not (smie-bolp)) + (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-indent--bolp)))) + (eolp)))) -(defun smie-indent--bolp () +(defun smie-bolp () + "Return non-nil if the current token is the first on the line." (save-excursion (skip-chars-backward " \t") (bolp))) +(defvar smie--parent) (defvar smie--after) ;Dynamically scoped. + +(defun smie-parent-p (&rest parents) + "Return non-nil if the current token's parent is among PARENTS. +Only meaningful when called from within `smie-rules-function'." + (member (nth 2 (or smie--parent + (save-excursion + (let* ((pos (point)) + (tok (funcall smie-forward-token-function))) + (unless (cadr (assoc tok smie-op-levels)) + (goto-char pos)) + (setq smie--parent + (smie-backward-sexp 'halfsexp)))))) + parents)) + +(defun smie-next-p (&rest tokens) + "Return non-nil if the next token is among TOKENS. +Only meaningful when called from within `smie-rules-function'." + (let ((next + (save-excursion + (unless smie--after + (smie-indent-forward-token) (setq smie--after (point))) + (goto-char smie--after) + (smie-indent-forward-token)))) + (member (car next) tokens))) + +(defun smie-prev-p (&rest tokens) + "Return non-nil if the previous token is among TOKENS." + (let ((prev (save-excursion + (smie-indent-backward-token)))) + (member (car prev) tokens))) + + (defun smie-indent--offset (elem) - (or (cdr (assq elem smie-indent-rules)) - (cdr (assq t smie-indent-rules)) + (or (funcall smie-rules-function :elem elem) + (if (not (eq elem 'basic)) + (funcall smie-rules-function :elem 'basic)) smie-indent-basic)) -(defvar smie-indent-debug-log) - -(defun smie-indent--offset-rule (tokinfo &optional after parent) - "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, otherwise it should be nil. -PARENT if non-nil should be the parent info returned by `smie-backward-sexp'." - (let ((rules (cdr tokinfo)) - next prev - offset) - (while (consp rules) - (let ((rule (pop rules))) - (cond - ((not (consp rule)) (setq offset rule)) - ((eq (car rule) '+) (setq offset rule)) - ((eq (car rule) :hanging) - (when (smie-indent--hanging-p) - (setq rules (cdr rule)))) - ((eq (car rule) :bolp) - (when (smie-indent--bolp) - (setq rules (cdr rule)))) - ((eq (car rule) :eolp) - (unless after - (error "Can't use :eolp in :before indentation rules")) - (when (> after (line-end-position)) - (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 (if (listp (cadr rule)) - (member (nth 2 parent) (cadr rule)) - (equal (nth 2 parent) (cadr rule))) - (setq rules (cddr rule)))) - (t (error "Unknown rule %s for indentation of %s" - rule (car tokinfo)))))) - ;; If `offset' is not set yet, use `rules' to handle the case where - ;; the tokinfo uses the old-style ((PARENT . TOK). OFFSET). - (unless offset (setq offset rules)) - (when (boundp 'smie-indent-debug-log) - (push (list (point) offset tokinfo) smie-indent-debug-log)) - offset)) +(defun smie-indent--rule (kind token &optional after parent) + (let ((smie--parent parent) + (smie--after after)) + (funcall smie-rules-function kind token))) (defun smie-indent--column (offset &optional base parent virtual-point) "Compute the actual column to use for a given OFFSET. @@ -1012,6 +1005,9 @@ If VIRTUAL-POINT is non-nil, then `point' is virtual." (if (consp parent) (goto-char (cadr parent))) (smie-indent-virtual)) ((eq offset nil) nil) + ;; FIXME: would be good to get rid of this since smie-rules-function + ;; can usually do the lookup trivially, but in cases where + ;; smie-rules-function returns (+ point VAR) it's not nearly as trivial. ((and (symbolp offset) (boundp 'offset)) (smie-indent--column (symbol-value offset) base parent virtual-point)) (t (error "Unknown indentation offset %s" offset)))) @@ -1046,11 +1042,11 @@ 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-indent--bolp) (current-column) (smie-indent-calculate))) + (if (smie-bolp) (current-column) (smie-indent-calculate))) (defun smie-indent-fixindent () ;; Obey the `fixindent' special comment. - (and (smie-indent--bolp) + (and (smie-bolp) (save-excursion (comment-normalize-vars) (re-search-forward (concat comment-start-skip @@ -1090,43 +1086,31 @@ in order to figure out the indentation of some other (further down) point." (save-excursion (goto-char pos) ;; Different cases: - ;; - smie-indent--bolp: "indent according to others". + ;; - 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-indent--bolp) + ((smie-bolp) ;; For an open-paren-like thingy at BOL, always indent only ;; based on other rules (typically smie-indent-after-keyword). nil) (t ;; We're only ever here for virtual-indent, which is why ;; we can use (current-column) as answer for `point'. - (let* ((tokinfo (or (assoc (cons :before token) - smie-indent-rules) + (let* ((offset (or (smie-indent--rule :before token) ;; By default use point unless we're hanging. - `((:before . ,token) (:hanging nil) point))) - ;; (after (prog1 (point) (goto-char pos))) - (offset (smie-indent--offset-rule tokinfo))) + (unless (smie-hanging-p) 'point)))) (smie-indent--column offset))))) ;; 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* ((parent (smie-backward-sexp 'halfsexp)) - (tokinfo - (or (assoc (cons (caddr parent) token) - smie-indent-rules) - (assoc (cons :before token) smie-indent-rules) - ;; Default rule. - `((:before . ,token) - ;; (:parent open 0) - point))) (offset (save-excursion (goto-char pos) - (smie-indent--offset-rule tokinfo nil parent)))) + (or (smie-indent--rule :before token nil parent) + 'point)))) ;; Different behaviors: ;; - align with parent. ;; - parent + offset. @@ -1151,10 +1135,10 @@ in order to figure out the indentation of some other (further down) point." nil) ((eq (car parent) (car toklevels)) ;; We bumped into a same-level operator. align with it. - (if (and (smie-indent--bolp) (/= (point) pos) + (if (and (smie-bolp) (/= (point) pos) (save-excursion (goto-char (goto-char (cadr parent))) - (not (smie-indent--bolp))) + (not (smie-bolp))) ;; Check the offset of `token' rather then its parent ;; because its parent may have used a special rule. E.g. ;; function foo; @@ -1190,8 +1174,8 @@ in order to figure out the indentation of some other (further down) point." ;; -> d ;; So as to align with the earliest appropriate place. (smie-indent-virtual))) - (tokinfo - (if (and (= (point) pos) (smie-indent--bolp) + (t + (if (and (= (point) pos) (smie-bolp) (or (eq offset 'point) (and (consp offset) (memq 'point offset)))) ;; Since we started at BOL, we're not computing a virtual @@ -1209,7 +1193,7 @@ in order to figure out the indentation of some other (further down) point." ;; Don't do it for virtual indentations. We should normally never be "in ;; front of a comment" when doing virtual-indentation anyway. And if we are ;; (as can happen in octave-mode), moving forward can lead to inf-loops. - (and (smie-indent--bolp) + (and (smie-bolp) (let ((pos (point))) (save-excursion (beginning-of-line) @@ -1254,27 +1238,18 @@ in order to figure out the indentation of some other (further down) point." (save-excursion (let* ((pos (point)) (toklevel (smie-indent-backward-token)) - (tok (car toklevel)) - (tokinfo (assoc tok smie-indent-rules))) - ;; Set some default 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)) + (tok (car toklevel))) (when toklevel - (unless tokinfo - ;; 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. - (setq tokinfo (list tok 'default-rule - (if (cadr toklevel) 0 (smie-indent--offset t))))) (let ((offset - (or (smie-indent--offset-rule tokinfo pos) - (smie-indent--offset t)))) - (let ((before (point))) + (or (smie-indent--rule :after tok pos) + ;; The default indentation after a keyword/operator is + ;; 0 for infix and t for prefix. + (if (or (null (cadr toklevel)) + (rassoc tok smie-closer-alist)) + (smie-indent--offset 'basic) 0))) + (before (point))) (goto-char pos) - (smie-indent--column offset before))))))) + (smie-indent--column offset before)))))) (defun smie-indent-exps () ;; Indentation of sequences of simple expressions without @@ -1297,13 +1272,14 @@ in order to figure out the indentation of some other (further down) point." arg) (while (and (null (car (smie-backward-sexp))) (push (point) positions) - (not (smie-indent--bolp)))) + (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)))))) + (setq arg + (or (null (car (smie-backward-sexp))) + (funcall smie-rules-function :list-intro + (funcall smie-backward-token-function))))) (cond ((null positions) ;; We're the first expression of the list. In that case, the @@ -1362,18 +1338,51 @@ to which that point should be aligned, if we were to reindent it.") (save-excursion (indent-line-to indent)) (indent-line-to indent))))) -(defun smie-indent-debug () - "Show the rules used to compute indentation of current line." - (interactive) - (let ((smie-indent-debug-log '())) - (smie-indent-calculate) - ;; FIXME: please improve! - (message "%S" smie-indent-debug-log))) - -(defun smie-setup (op-levels indent-rules) - (set (make-local-variable 'smie-indent-rules) indent-rules) +(defun smie-setup (op-levels rules-function &rest keywords) + "Setup SMIE navigation and indentation. +OP-LEVELS is a grammar table generated by `smie-prec2-levels'. +RULES-FUNCTION is a set of indentation rules for use on `smie-rules-function'. +KEYWORDS are additional arguments, which can use the following keywords: +- :forward-token FUN +- :backward-token FUN" + (set (make-local-variable 'smie-rules-function) rules-function) (set (make-local-variable 'smie-op-levels) op-levels) - (set (make-local-variable 'indent-line-function) 'smie-indent-line)) + (set (make-local-variable 'indent-line-function) 'smie-indent-line) + (set (make-local-variable 'forward-sexp-function) + 'smie-forward-sexp-command) + (while keywords + (let ((k (pop keywords)) + (v (pop keywords))) + (case k + (:forward-token + (set (make-local-variable 'smie-forward-token-function) v)) + (:backward-token + (set (make-local-variable 'smie-backward-token-function) v)) + (t (message "smie-setup: ignoring unknown keyword %s" k))))) + (let ((ca (cdr (assq :smie-closer-alist op-levels)))) + (when ca + (set (make-local-variable 'smie-closer-alist) ca) + ;; Only needed for interactive calls to blink-matching-open. + (set (make-local-variable 'blink-matching-check-function) + #'smie-blink-matching-check) + (add-hook 'post-self-insert-hook + #'smie-blink-matching-open 'append 'local) + (set (make-local-variable 'smie-blink-matching-triggers) + (append smie-blink-matching-triggers + ;; Rather than wait for SPC to blink, try to blink as + ;; soon as we type the last char of a block ender. + (let ((closers (sort (mapcar #'cdr smie-closer-alist) + #'string-lessp)) + (triggers ()) + closer) + (while (setq closer (pop closers)) + (unless (and closers + ;; FIXME: this eliminates prefixes of other + ;; closers, but we should probably elimnate + ;; prefixes of other keywords as well. + (string-prefix-p closer (car closers))) + (push (aref closer (1- (length closer))) triggers))) + (delete-dups triggers))))))) (provide 'smie) |