diff options
Diffstat (limited to 'lisp/emacs-lisp')
36 files changed, 1501 insertions, 1437 deletions
diff --git a/lisp/emacs-lisp/assoc.el b/lisp/emacs-lisp/assoc.el deleted file mode 100644 index 264374ed721..00000000000 --- a/lisp/emacs-lisp/assoc.el +++ /dev/null @@ -1,139 +0,0 @@ -;;; assoc.el --- insert/delete functions on association lists - -;; Copyright (C) 1996, 2001-2012 Free Software Foundation, Inc. - -;; Author: Barry A. Warsaw <bwarsaw@cen.com> -;; Keywords: extensions - -;; 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Association list utilities providing insertion, deletion, sorting -;; fetching off key-value pairs in association lists. - -;;; Code: -(eval-when-compile (require 'cl)) - -(defun asort (alist-symbol key) - "Move a specified key-value pair to the head of an alist. -The alist is referenced by ALIST-SYMBOL. Key-value pair to move to -head is one matching KEY. Returns the sorted list and doesn't affect -the order of any other key-value pair. Side effect sets alist to new -sorted list." - (set alist-symbol - (sort (copy-alist (symbol-value alist-symbol)) - (function (lambda (a b) (equal (car a) key)))))) - - -(defun aelement (key value) - "Make a list of a cons cell containing car of KEY and cdr of VALUE. -The returned list is suitable for concatenating with an existing -alist, via `nconc'." - (list (cons key value))) - - -(defun aheadsym (alist) - "Return the key symbol at the head of ALIST." - (car (car alist))) - - -(defun anot-head-p (alist key) - "Find out if a specified key-value pair is not at the head of an alist. -The alist to check is specified by ALIST and the key-value pair is the -one matching the supplied KEY. Returns nil if ALIST is nil, or if -key-value pair is at the head of the alist. Returns t if key-value -pair is not at the head of alist. ALIST is not altered." - (not (equal (aheadsym alist) key))) - - -(defun aput (alist-symbol key &optional value) - "Insert a key-value pair into an alist. -The alist is referenced by ALIST-SYMBOL. The key-value pair is made -from KEY and optionally, VALUE. Returns the altered alist. - -If the key-value pair referenced by KEY can be found in the alist, and -VALUE is supplied non-nil, then the value of KEY will be set to VALUE. -If VALUE is not supplied, or is nil, the key-value pair will not be -modified, but will be moved to the head of the alist. If the key-value -pair cannot be found in the alist, it will be inserted into the head -of the alist (with value nil if VALUE is nil or not supplied)." - (lexical-let ((elem (aelement key value)) - alist) - (asort alist-symbol key) - (setq alist (symbol-value alist-symbol)) - (cond ((null alist) (set alist-symbol elem)) - ((anot-head-p alist key) (set alist-symbol (nconc elem alist))) - (value (setcar alist (car elem)) alist) - (t alist)))) - - -(defun adelete (alist-symbol key) - "Delete a key-value pair from the alist. -Alist is referenced by ALIST-SYMBOL and the key-value pair to remove -is pair matching KEY. Returns the altered alist." - (asort alist-symbol key) - (lexical-let ((alist (symbol-value alist-symbol))) - (cond ((null alist) nil) - ((anot-head-p alist key) alist) - (t (set alist-symbol (cdr alist)))))) - - -(defun aget (alist key &optional keynil-p) - "Return the value in ALIST that is associated with KEY. -Optional KEYNIL-P describes what to do if the value associated with -KEY is nil. If KEYNIL-P is not supplied or is nil, and the value is -nil, then KEY is returned. If KEYNIL-P is non-nil, then nil would be -returned. - -If no key-value pair matching KEY could be found in ALIST, or ALIST is -nil then nil is returned. ALIST is not altered." - (let ((copy (copy-alist alist))) - (cond ((null alist) nil) - ((progn (asort 'copy key) - (anot-head-p copy key)) nil) - ((cdr (car copy))) - (keynil-p nil) - ((car (car copy))) - (t nil)))) - - -(defun amake (alist-symbol keylist &optional valuelist) - "Make an association list. -The association list is attached to the alist referenced by -ALIST-SYMBOL. Each element in the KEYLIST becomes a key and is -associated with the value in VALUELIST with the same index. If -VALUELIST is not supplied or is nil, then each key in KEYLIST is -associated with nil. - -KEYLIST and VALUELIST should have the same number of elements, but -this isn't enforced. If VALUELIST is smaller than KEYLIST, remaining -keys are associated with nil. If VALUELIST is larger than KEYLIST, -extra values are ignored. Returns the created alist." - (lexical-let ((keycar (car keylist)) - (keycdr (cdr keylist)) - (valcar (car valuelist)) - (valcdr (cdr valuelist))) - (cond ((null keycdr) - (aput alist-symbol keycar valcar)) - (t - (amake alist-symbol keycdr valcdr) - (aput alist-symbol keycar valcar)))) - (symbol-value alist-symbol)) - -(provide 'assoc) - -;;; assoc.el ends here diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index 6f2c6f73eca..a7f8dad54ed 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -1,4 +1,4 @@ -;;; authors.el --- utility for maintaining Emacs's AUTHORS file -*-coding: utf-8;-*- +;;; authors.el --- utility for maintaining Emacs's AUTHORS file -*-coding: utf-8 -*- ;; Copyright (C) 2000-2012 Free Software Foundation, Inc. @@ -829,7 +829,7 @@ with the file and the number of each action: (enable-local-eval nil) (existing-buffer (get-file-buffer log-file)) (buffer (find-file-noselect log-file)) - authors file pos) + authors pos) (with-current-buffer buffer (save-restriction (widen) @@ -943,8 +943,7 @@ and changed by AUTHOR." (file (car change)) (filestat (if (authors-public-domain-p file) (concat file " (public domain)") - file)) - slot) + file))) (cond ((assq :wrote actions) (setq wrote-list (cons filestat wrote-list))) ((assq :cowrote actions) diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 5af666b9ded..d9fc0fccf0e 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1,4 +1,4 @@ -;; autoload.el --- maintain autoloads in loaddefs.el +;; autoload.el --- maintain autoloads in loaddefs.el -*- lexical-binding: t -*- ;; Copyright (C) 1991-1997, 2001-2012 Free Software Foundation, Inc. @@ -86,28 +86,67 @@ that text will be copied verbatim to `generated-autoload-file'.") (defvar autoload-modified-buffers) ;Dynamically scoped var. -(defun make-autoload (form file) +(defun make-autoload (form file &optional expansion) "Turn FORM into an autoload or defvar for source file FILE. Returns nil if FORM is not a special autoload form (i.e. a function definition -or macro definition or a defcustom)." +or macro definition or a defcustom). +If EXPANSION is non-nil, we're processing the macro expansion of an +expression, in which case we want to handle forms differently." (let ((car (car-safe form)) expand) (cond + ((and expansion (eq car 'defalias)) + (pcase-let* + ((`(,_ ,_ ,arg . ,rest) form) + ;; `type' is non-nil if it defines a macro. + ;; `fun' is the function part of `arg' (defaults to `arg'). + ((or (and (or `(cons 'macro ,fun) `'(macro . ,fun)) (let type t)) + (and (let fun arg) (let type nil))) + arg) + ;; `lam' is the lambda expression in `fun' (or nil if not + ;; recognized). + (lam (if (memq (car-safe fun) '(quote function)) (cadr fun))) + ;; `args' is the list of arguments (or t if not recognized). + ;; `body' is the body of `lam' (or t if not recognized). + ((or `(lambda ,args . ,body) + (and (let args t) (let body t))) + lam) + ;; Get the `doc' from `body' or `rest'. + (doc (cond ((stringp (car-safe body)) (car body)) + ((stringp (car-safe rest)) (car rest)))) + ;; Look for an interactive spec. + (interactive (pcase body + ((or `((interactive . ,_) . ,_) + `(,_ (interactive . ,_) . ,_)) t)))) + ;; Add the usage form at the end where describe-function-1 + ;; can recover it. + (when (listp args) (setq doc (help-add-fundoc-usage doc args))) + ;; (message "autoload of %S" (nth 1 form)) + `(autoload ,(nth 1 form) ,file ,doc ,interactive ,type))) + + ((and expansion (memq car '(progn prog1))) + (let ((end (memq :autoload-end form))) + (when end ;Cut-off anything after the :autoload-end marker. + (setq form (copy-sequence form)) + (setcdr (memq :autoload-end form) nil)) + (let ((exps (delq nil (mapcar (lambda (form) + (make-autoload form file expansion)) + (cdr form))))) + (when exps (cons 'progn exps))))) + ;; For complex cases, try again on the macro-expansion. ((and (memq car '(easy-mmode-define-global-mode define-global-minor-mode - define-globalized-minor-mode + define-globalized-minor-mode defun defmacro + ;; FIXME: we'd want `defmacro*' here as well, so as + ;; to handle its `declare', but when autoload is run + ;; CL is not loaded so macroexpand doesn't know how + ;; to expand it! easy-mmode-define-minor-mode define-minor-mode)) (setq expand (let ((load-file-name file)) (macroexpand form))) - (eq (car expand) 'progn) - (memq :autoload-end expand)) - (let ((end (memq :autoload-end expand))) - ;; Cut-off anything after the :autoload-end marker. - (setcdr end nil) - (cons 'progn - (mapcar (lambda (form) (make-autoload form file)) - (cdr expand))))) + (memq (car expand) '(progn prog1 defalias))) + (make-autoload expand file 'expansion)) ;Recurse on the expansion. ;; For special function-like operators, use the `autoload' function. - ((memq car '(defun define-skeleton defmacro define-derived-mode + ((memq car '(define-skeleton define-derived-mode define-compilation-mode define-generic-mode easy-mmode-define-global-mode define-global-minor-mode define-globalized-minor-mode @@ -124,40 +163,21 @@ or macro definition or a defcustom)." (t))) (body (nthcdr (get car 'doc-string-elt) form)) (doc (if (stringp (car body)) (pop body)))) - (when (listp args) - ;; Add the usage form at the end where describe-function-1 - ;; can recover it. - (setq doc (help-add-fundoc-usage doc args))) - (let ((exp - ;; `define-generic-mode' quotes the name, so take care of that - (list 'autoload (if (listp name) name (list 'quote name)) - file doc - (or (and (memq car '(define-skeleton define-derived-mode - define-generic-mode - easy-mmode-define-global-mode - define-global-minor-mode - define-globalized-minor-mode - easy-mmode-define-minor-mode - define-minor-mode)) t) - (eq (car-safe (car body)) 'interactive)) - (if macrop (list 'quote 'macro) nil)))) - (when macrop - ;; Special case to autoload some of the macro's declarations. - (let ((decls (nth (if (stringp (nth 3 form)) 4 3) form)) - (exps '())) - (when (eq (car-safe decls) 'declare) - ;; FIXME: We'd like to reuse macro-declaration-function, - ;; but we can't since it doesn't return anything. - (dolist (decl decls) - (case (car-safe decl) - (indent - (push `(put ',name 'lisp-indent-function ',(cadr decl)) - exps)) - (doc-string - (push `(put ',name 'doc-string-elt ',(cadr decl)) exps)))) - (when exps - (setq exp `(progn ,exp ,@exps)))))) - exp))) + ;; Add the usage form at the end where describe-function-1 + ;; can recover it. + (when (listp args) (setq doc (help-add-fundoc-usage doc args))) + ;; `define-generic-mode' quotes the name, so take care of that + (list 'autoload (if (listp name) name (list 'quote name)) + file doc + (or (and (memq car '(define-skeleton define-derived-mode + define-generic-mode + easy-mmode-define-global-mode + define-global-minor-mode + define-globalized-minor-mode + easy-mmode-define-minor-mode + define-minor-mode)) t) + (eq (car-safe (car body)) 'interactive)) + (if macrop (list 'quote 'macro) nil)))) ;; For defclass forms, use `eieio-defclass-autoload'. ((eq car 'defclass) @@ -190,6 +210,11 @@ or macro definition or a defcustom)." (if (member ',file loads) nil (put ',groupname 'custom-loads (cons ',file loads)))))) + ;; When processing a macro expansion, any expression + ;; before a :autoload-end should be included. These are typically (put + ;; 'fun 'prop val) and things like that. + ((and expansion (consp form)) form) + ;; nil here indicates that this is not a special autoload form. (t nil)))) @@ -481,7 +506,7 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE (search-forward generate-autoload-cookie) (skip-chars-forward " \t") (if (eolp) - (condition-case err + (condition-case-unless-debug err ;; Read the next form and make an autoload. (let* ((form (prog1 (read (current-buffer)) (or (bolp) (forward-line 1)))) @@ -671,9 +696,9 @@ file binds `generated-autoload-file' as a file-local variable, write its autoloads into the specified file instead." (interactive "DUpdate autoloads from directory: ") (let* ((files-re (let ((tmp nil)) - (dolist (suf (get-load-suffixes) - (concat "^[^=.].*" (regexp-opt tmp t) "\\'")) - (unless (string-match "\\.elc" suf) (push suf tmp))))) + (dolist (suf (get-load-suffixes)) + (unless (string-match "\\.elc" suf) (push suf tmp))) + (concat "^[^=.].*" (regexp-opt tmp t) "\\'"))) (files (apply 'nconc (mapcar (lambda (dir) (directory-files (expand-file-name dir) @@ -762,9 +787,6 @@ write its autoloads into the specified file instead." (define-obsolete-function-alias 'update-autoloads-from-directories 'update-directory-autoloads "22.1") -(defvar autoload-make-program (or (getenv "MAKE") "make") - "Name of the make program in use during the Emacs build process.") - ;;;###autoload (defun batch-update-autoloads () "Update loaddefs.el autoloads in batch mode. diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index 9f348767478..1f00677cd00 100644 --- a/lisp/emacs-lisp/avl-tree.el +++ b/lisp/emacs-lisp/avl-tree.el @@ -260,7 +260,7 @@ Return t if the height of the tree has grown." (opp (avl-tree--switch-dir dir)) ;; direction 0,1 -> sign factor -1,+1 (sgn (avl-tree--dir-to-sign dir)) - p1 p2 b2 result) + p1 p2 b2) (cond ((< (* sgn (avl-tree--node-balance br)) 0) (setf (avl-tree--node-balance br) 0) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 78ac29d89df..7cb93890cb5 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -288,10 +288,14 @@ (push `(,(car binding) ',(cdr binding)) renv))) ((eq binding t)) (t (push `(defvar ,binding) body)))) - (let ((newfn (byte-compile-preprocess - (if (null renv) - `(lambda ,args ,@body) - `(lambda ,args (let ,(nreverse renv) ,@body)))))) + (let ((newfn (if (eq fn localfn) + ;; If `fn' is from the same file, it has already + ;; been preprocessed! + `(function ,fn) + (byte-compile-preprocess + (if (null renv) + `(lambda ,args ,@body) + `(lambda ,args (let ,(nreverse renv) ,@body))))))) (if (eq (car-safe newfn) 'function) (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) (byte-compile-log-warning @@ -496,7 +500,7 @@ (prin1-to-string form)) nil) - ((memq fn '(defun defmacro function condition-case)) + ((memq fn '(function condition-case)) ;; These forms are compiled as constants or by breaking out ;; all the subexpressions and compiling them separately. form) @@ -1237,7 +1241,7 @@ string-to-multibyte tan truncate unibyte-char-to-multibyte upcase user-full-name - user-login-name user-original-login-name user-variable-p + user-login-name user-original-login-name custom-variable-p vconcat window-buffer window-dedicated-p window-edges window-height window-hscroll window-minibuffer-p window-width diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index dc7166bc2ea..df8f588ce01 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -1,4 +1,4 @@ -;;; byte-run.el --- byte-compiler support for inlining +;;; byte-run.el --- byte-compiler support for inlining -*- lexical-binding: t -*- ;; Copyright (C) 1992, 2001-2012 Free Software Foundation, Inc. @@ -30,37 +30,167 @@ ;;; Code: -;; We define macro-declaration-function here because it is needed to -;; handle declarations in macro definitions and this is the first file -;; loaded by loadup.el that uses declarations in macros. +;; `macro-declaration-function' are both obsolete (as marked at the end of this +;; file) but used in many .elc files. + +(defvar macro-declaration-function #'macro-declaration-function + "Function to process declarations in a macro definition. +The function will be called with two args MACRO and DECL. +MACRO is the name of the macro being defined. +DECL is a list `(declare ...)' containing the declarations. +The value the function returns is not used.") -(defun macro-declaration-function (macro decl) - "Process a declaration found in a macro definition. +(defalias 'macro-declaration-function + #'(lambda (macro decl) + "Process a declaration found in a macro definition. This is set as the value of the variable `macro-declaration-function'. MACRO is the name of the macro being defined. DECL is a list `(declare ...)' containing the declarations. The return value of this function is not used." - ;; We can't use `dolist' or `cadr' yet for bootstrapping reasons. - (let (d) - ;; Ignore the first element of `decl' (it's always `declare'). - (while (setq decl (cdr decl)) - (setq d (car decl)) - (if (and (consp d) - (listp (cdr d)) - (null (cdr (cdr d)))) - (cond ((eq (car d) 'indent) - (put macro 'lisp-indent-function (car (cdr d)))) - ((eq (car d) 'debug) - (put macro 'edebug-form-spec (car (cdr d)))) - ((eq (car d) 'doc-string) - (put macro 'doc-string-elt (car (cdr d)))) - (t - (message "Unknown declaration %s" d))) - (message "Invalid declaration %s" d))))) - - -(setq macro-declaration-function 'macro-declaration-function) + ;; We can't use `dolist' or `cadr' yet for bootstrapping reasons. + (let (d) + ;; Ignore the first element of `decl' (it's always `declare'). + (while (setq decl (cdr decl)) + (setq d (car decl)) + (if (and (consp d) + (listp (cdr d)) + (null (cdr (cdr d)))) + (cond ((eq (car d) 'indent) + (put macro 'lisp-indent-function (car (cdr d)))) + ((eq (car d) 'debug) + (put macro 'edebug-form-spec (car (cdr d)))) + ((eq (car d) 'doc-string) + (put macro 'doc-string-elt (car (cdr d)))) + (t + (message "Unknown declaration %s" d))) + (message "Invalid declaration %s" d)))))) + +;; We define macro-declaration-alist here because it is needed to +;; handle declarations in macro definitions and this is the first file +;; loaded by loadup.el that uses declarations in macros. +(defvar defun-declarations-alist + ;; FIXME: Should we also add an `obsolete' property? + (list + ;; Too bad we can't use backquote yet at this stage of the bootstrap. + (list 'advertised-calling-convention + #'(lambda (f arglist when) + (list 'set-advertised-calling-convention + (list 'quote f) (list 'quote arglist) (list 'quote when)))) + (list 'doc-string + #'(lambda (f pos) + (list 'put (list 'quote f) ''doc-string-elt (list 'quote pos)))) + (list 'indent + #'(lambda (f val) + (list 'put (list 'quote f) + ''lisp-indent-function (list 'quote val))))) + "List associating function properties to their macro expansion. +Each element of the list takes the form (PROP FUN) where FUN is +a function. For each (PROP . VALUES) in a function's declaration, +the FUN corresponding to PROP is called with the function name +and the VALUES and should return the code to use to set this property.") + +(defvar macro-declarations-alist + (cons + (list 'debug + #'(lambda (name spec) + (list 'progn :autoload-end + (list 'put (list 'quote name) + ''edebug-form-spec (list 'quote spec))))) + defun-declarations-alist) + "List associating properties of macros to their macro expansion. +Each element of the list takes the form (PROP FUN) where FUN is +a function. For each (PROP . VALUES) in a macro's declaration, +the FUN corresponding to PROP is called with the function name +and the VALUES and should return the code to use to set this property.") + +(put 'defmacro 'doc-string-elt 3) +(defalias 'defmacro + (cons + 'macro + #'(lambda (name arglist &optional docstring decl &rest body) + "Define NAME as a macro. +When the macro is called, as in (NAME ARGS...), +the function (lambda ARGLIST BODY...) is applied to +the list ARGS... as it appears in the expression, +and the result should be a form to be evaluated instead of the original. +DECL is a declaration, optional, of the form (declare DECLS...) where +DECLS is a list of elements of the form (PROP . VALUES). These are +interpreted according to `macro-declarations-alist'." + (if (stringp docstring) nil + (if decl (setq body (cons decl body))) + (setq decl docstring) + (setq docstring nil)) + (if (or (null decl) (eq 'declare (car-safe decl))) nil + (setq body (cons decl body)) + (setq decl nil)) + (if (null body) (setq body '(nil))) + (if docstring (setq body (cons docstring body))) + ;; Can't use backquote because it's not defined yet! + (let* ((fun (list 'function (cons 'lambda (cons arglist body)))) + (def (list 'defalias + (list 'quote name) + (list 'cons ''macro fun))) + (declarations + (mapcar + #'(lambda (x) + (let ((f (cdr (assq (car x) macro-declarations-alist)))) + (if f (apply (car f) name (cdr x)) + (message "Warning: Unknown macro property %S in %S" + (car x) name)))) + (cdr decl)))) + (if declarations + (cons 'prog1 (cons def declarations)) + def))))) + +;; Now that we defined defmacro we can use it! +(defmacro defun (name arglist &optional docstring &rest body) + "Define NAME as a function. +The definition is (lambda ARGLIST [DOCSTRING] BODY...). +See also the function `interactive'. +DECL is a declaration, optional, of the form (declare DECLS...) where +DECLS is a list of elements of the form (PROP . VALUES). These are +interpreted according to `defun-declarations-alist'. + +\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)" + ;; We can't just have `decl' as an &optional argument, because we need + ;; to distinguish + ;; (defun foo (arg) (toto) nil) + ;; from + ;; (defun foo (arg) (toto)). + (declare (doc-string 3)) + (let ((decls (cond + ((eq (car-safe docstring) 'declare) + (prog1 (cdr docstring) (setq docstring nil))) + ((eq (car-safe (car body)) 'declare) + (prog1 (cdr (car body)) (setq body (cdr body))))))) + (if docstring (setq body (cons docstring body)) + (if (null body) (setq body '(nil)))) + (let ((declarations + (mapcar + #'(lambda (x) + (let ((f (cdr (assq (car x) defun-declarations-alist)))) + (cond + (f (apply (car f) name (cdr x))) + ;; Yuck!! + ((and (featurep 'cl) + (memq (car x) ;C.f. cl-do-proclaim. + '(special inline notinline optimize warn))) + (if (null (stringp docstring)) + (push (list 'declare x) body) + (setcdr body (cons (list 'declare x) (cdr body)))) + nil) + (t (message "Warning: Unknown defun property %S in %S" + (car x) name))))) + decls)) + (def (list 'defalias + (list 'quote name) + (list 'function + (cons 'lambda + (cons arglist body)))))) + (if declarations + (cons 'prog1 (cons def declarations)) + def)))) ;; Redefined in byte-optimize.el. ;; This is not documented--it's not clear that we should promote it. @@ -93,10 +223,9 @@ The return value of this function is not used." ;; (list 'put x ''byte-optimizer nil))) ;; fns))) -;; This has a special byte-hunk-handler in bytecomp.el. (defmacro defsubst (name arglist &rest body) "Define an inline function. The syntax is just like that of `defun'." - (declare (debug defun)) + (declare (debug defun) (doc-string 3)) (or (memq (get name 'byte-optimizer) '(nil byte-compile-inline-expand)) (error "`%s' is a primitive" name)) @@ -107,7 +236,7 @@ The return value of this function is not used." (defvar advertised-signature-table (make-hash-table :test 'eq :weakness 'key)) -(defun set-advertised-calling-convention (function signature when) +(defun set-advertised-calling-convention (function signature _when) "Set the advertised SIGNATURE of FUNCTION. This will allow the byte-compiler to warn the programmer when she uses an obsolete calling convention. WHEN specifies since when the calling @@ -122,15 +251,15 @@ If CURRENT-NAME is a string, that is the `use instead' message \(it should end with a period, and not start with a capital). WHEN should be a string indicating when the function was first made obsolete, for example a date or a release number." + (declare (advertised-calling-convention + ;; New code should always provide the `when' argument. + (obsolete-name current-name when) "23.1")) (interactive "aMake function obsolete: \nxObsoletion replacement: ") (put obsolete-name 'byte-obsolete-info ;; The second entry used to hold the `byte-compile' handler, but ;; is not used any more nowadays. (purecopy (list current-name nil when))) obsolete-name) -(set-advertised-calling-convention - ;; New code should always provide the `when' argument. - 'make-obsolete '(obsolete-name current-name when) "23.1") (defmacro define-obsolete-function-alias (obsolete-name current-name &optional when docstring) @@ -144,14 +273,13 @@ is equivalent to the following two lines of code: \(make-obsolete 'old-fun 'new-fun \"22.1\") See the docstrings of `defalias' and `make-obsolete' for more details." - (declare (doc-string 4)) + (declare (doc-string 4) + (advertised-calling-convention + ;; New code should always provide the `when' argument. + (obsolete-name current-name when &optional docstring) "23.1")) `(progn (defalias ,obsolete-name ,current-name ,docstring) (make-obsolete ,obsolete-name ,current-name ,when))) -(set-advertised-calling-convention - ;; New code should always provide the `when' argument. - 'define-obsolete-function-alias - '(obsolete-name current-name when &optional docstring) "23.1") (defun make-obsolete-variable (obsolete-name current-name &optional when access-type) "Make the byte-compiler warn that OBSOLETE-NAME is obsolete. @@ -161,13 +289,13 @@ WHEN should be a string indicating when the variable was first made obsolete, for example a date or a release number. ACCESS-TYPE if non-nil should specify the kind of access that will trigger obsolescence warnings; it can be either `get' or `set'." + (declare (advertised-calling-convention + ;; New code should always provide the `when' argument. + (obsolete-name current-name when &optional access-type) "23.1")) (put obsolete-name 'byte-obsolete-variable (purecopy (list current-name access-type when))) obsolete-name) -(set-advertised-calling-convention - ;; New code should always provide the `when' argument. - 'make-obsolete-variable - '(obsolete-name current-name when &optional access-type) "23.1") + (defmacro define-obsolete-variable-alias (obsolete-name current-name &optional when docstring) @@ -190,7 +318,10 @@ For the benefit of `custom-set-variables', if OBSOLETE-NAME has any of the following properties, they are copied to CURRENT-NAME, if it does not already have them: 'saved-value, 'saved-variable-comment." - (declare (doc-string 4)) + (declare (doc-string 4) + (advertised-calling-convention + ;; New code should always provide the `when' argument. + (obsolete-name current-name when &optional docstring) "23.1")) `(progn (defvaralias ,obsolete-name ,current-name ,docstring) ;; See Bug#4706. @@ -199,10 +330,6 @@ CURRENT-NAME, if it does not already have them: (null (get ,current-name prop)) (put ,current-name prop (get ,obsolete-name prop)))) (make-obsolete-variable ,obsolete-name ,current-name ,when))) -(set-advertised-calling-convention - ;; New code should always provide the `when' argument. - 'define-obsolete-variable-alias - '(obsolete-name current-name when &optional docstring) "23.1") ;; FIXME This is only defined in this file because the variable- and ;; function- versions are too. Unlike those two, this one is not used @@ -283,4 +410,9 @@ In interpreted code, this is entirely equivalent to `progn'." ;; (file-format emacs19))" ;; nil) +(make-obsolete-variable 'macro-declaration-function + 'macro-declarations-alist "24.2") +(make-obsolete 'macro-declaration-function + 'macro-declarations-alist "24.2") + ;;; byte-run.el ends here diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index b03e8e252fd..bbf029700a3 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1002,12 +1002,14 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (defvar byte-compile-last-warned-form nil) (defvar byte-compile-last-logged-file nil) +(defvar byte-compile-root-dir nil + "Directory relative to which file names in error messages are written.") ;; This is used as warning-prefix for the compiler. ;; It is always called with the warnings buffer current. (defun byte-compile-warning-prefix (level entry) (let* ((inhibit-read-only t) - (dir default-directory) + (dir (or byte-compile-root-dir default-directory)) (file (cond ((stringp byte-compile-current-file) (format "%s:" (file-relative-name byte-compile-current-file dir))) @@ -1167,12 +1169,14 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (t fn))))))) (defun byte-compile-arglist-signature (arglist) - (if (integerp arglist) - ;; New style byte-code arglist. - (cons (logand arglist 127) ;Mandatory. - (if (zerop (logand arglist 128)) ;No &rest. - (lsh arglist -8))) ;Nonrest. - ;; Old style byte-code, or interpreted function. + (cond + ;; New style byte-code arglist. + ((integerp arglist) + (cons (logand arglist 127) ;Mandatory. + (if (zerop (logand arglist 128)) ;No &rest. + (lsh arglist -8)))) ;Nonrest. + ;; Old style byte-code, or interpreted function. + ((listp arglist) (let ((args 0) opts restp) @@ -1188,7 +1192,9 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (setq opts (1+ opts)) (setq args (1+ args))))) (setq arglist (cdr arglist))) - (cons args (if restp nil (if opts (+ args opts) args)))))) + (cons args (if restp nil (if opts (+ args opts) args))))) + ;; Unknown arglist. + (t '(0)))) (defun byte-compile-arglist-signatures-congruent-p (old new) @@ -1248,8 +1254,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." ;; and/or remember its arity if it's unknown. (or (and (or def (fboundp (car form))) ; might be a subr or autoload. (not (memq (car form) byte-compile-noruntime-functions))) - (eq (car form) byte-compile-current-form) ; ## this doesn't work - ; with recursion. + (eq (car form) byte-compile-current-form) ; ## This doesn't work + ; with recursion. ;; It's a currently-undefined function. ;; Remember number of args in call. (let ((cons (assq (car form) byte-compile-unresolved-functions)) @@ -1314,9 +1320,8 @@ extra args." ;; Warn if the function or macro is being redefined with a different ;; number of arguments. -(defun byte-compile-arglist-warn (form macrop) - (let* ((name (nth 1 form)) - (old (byte-compile-fdefinition name macrop)) +(defun byte-compile-arglist-warn (name arglist macrop) + (let* ((old (byte-compile-fdefinition name macrop)) (initial (and macrop (cdr (assq name byte-compile-initial-macro-environment))))) @@ -1335,12 +1340,12 @@ extra args." (`(closure ,_ ,args . ,_) args) ((pred byte-code-function-p) (aref old 0)) (t '(&rest def))))) - (sig2 (byte-compile-arglist-signature (nth 2 form)))) + (sig2 (byte-compile-arglist-signature arglist))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) (byte-compile-set-symbol-position name) (byte-compile-warn "%s %s used to take %s %s, now takes %s" - (if (eq (car form) 'defun) "function" "macro") + (if macrop "macro" "function") name (byte-compile-arglist-signature-string sig1) (if (equal sig1 '(1 . 1)) "argument" "arguments") @@ -1354,7 +1359,7 @@ extra args." 'byte-compile-inline-expand)) (byte-compile-warn "defsubst `%s' was used before it was defined" name)) - (setq sig (byte-compile-arglist-signature (nth 2 form)) + (setq sig (byte-compile-arglist-signature arglist) nums (sort (copy-sequence (cdr calls)) (function <)) min (car nums) max (car (nreverse nums))) @@ -1476,40 +1481,46 @@ symbol itself." (defmacro byte-compile-constp (form) "Return non-nil if FORM is a constant." - `(cond ((consp ,form) (eq (car ,form) 'quote)) + `(cond ((consp ,form) (or (eq (car ,form) 'quote) + (and (eq (car ,form) 'function) + (symbolp (cadr ,form))))) ((not (symbolp ,form))) ((byte-compile-const-symbol-p ,form)))) +;; Dynamically bound in byte-compile-from-buffer. +;; NB also used in cl.el and cl-macs.el. +(defvar byte-compile--outbuffer) + (defmacro byte-compile-close-variables (&rest body) (declare (debug t)) - (cons 'let - (cons '(;; - ;; Close over these variables to encapsulate the - ;; compilation state - ;; - (byte-compile-macro-environment - ;; Copy it because the compiler may patch into the - ;; macroenvironment. - (copy-alist byte-compile-initial-macro-environment)) - (byte-compile-function-environment nil) - (byte-compile-bound-variables nil) - (byte-compile-const-variables nil) - (byte-compile-free-references nil) - (byte-compile-free-assignments nil) - ;; - ;; Close over these variables so that `byte-compiler-options' - ;; can change them on a per-file basis. - ;; - (byte-compile-verbose byte-compile-verbose) - (byte-optimize byte-optimize) - (byte-compile-dynamic byte-compile-dynamic) - (byte-compile-dynamic-docstrings - byte-compile-dynamic-docstrings) -;; (byte-compile-generate-emacs19-bytecodes -;; byte-compile-generate-emacs19-bytecodes) - (byte-compile-warnings byte-compile-warnings) - ) - body))) + `(let (;; + ;; Close over these variables to encapsulate the + ;; compilation state + ;; + (byte-compile-macro-environment + ;; Copy it because the compiler may patch into the + ;; macroenvironment. + (copy-alist byte-compile-initial-macro-environment)) + (byte-compile--outbuffer nil) + (byte-compile-function-environment nil) + (byte-compile-bound-variables nil) + (byte-compile-const-variables nil) + (byte-compile-free-references nil) + (byte-compile-free-assignments nil) + ;; + ;; Close over these variables so that `byte-compiler-options' + ;; can change them on a per-file basis. + ;; + (byte-compile-verbose byte-compile-verbose) + (byte-optimize byte-optimize) + (byte-compile-dynamic byte-compile-dynamic) + (byte-compile-dynamic-docstrings + byte-compile-dynamic-docstrings) + ;; (byte-compile-generate-emacs19-bytecodes + ;; byte-compile-generate-emacs19-bytecodes) + (byte-compile-warnings byte-compile-warnings) + ) + ,@body)) (defmacro displaying-byte-compile-warnings (&rest body) (declare (debug t)) @@ -1850,13 +1861,8 @@ With argument ARG, insert value in current buffer after the form." (insert "\n")) ((message "%s" (prin1-to-string value))))))) -;; Dynamically bound in byte-compile-from-buffer. -;; NB also used in cl.el and cl-macs.el. -(defvar byte-compile--outbuffer) - (defun byte-compile-from-buffer (inbuffer) - (let (byte-compile--outbuffer - (byte-compile-current-buffer inbuffer) + (let ((byte-compile-current-buffer inbuffer) (byte-compile-read-position nil) (byte-compile-last-position nil) ;; Prevent truncation of flonums and lists as we read and print them @@ -1928,8 +1934,8 @@ and will be removed soon. See (elisp)Backquote in the manual.")) ;; if the buffer contains multibyte characters. (and byte-compile-current-file (with-current-buffer byte-compile--outbuffer - (byte-compile-fix-header byte-compile-current-file))))) - byte-compile--outbuffer)) + (byte-compile-fix-header byte-compile-current-file)))) + byte-compile--outbuffer))) (defun byte-compile-fix-header (_filename) "If the current buffer has any multibyte characters, insert a version test." @@ -2016,31 +2022,30 @@ Call from the source buffer." ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n")))) (defun byte-compile-output-file-form (form) - ;; writes the given form to the output buffer, being careful of docstrings + ;; Write the given form to the output buffer, being careful of docstrings ;; in defun, defmacro, defvar, defvaralias, defconst, autoload and ;; custom-declare-variable because make-docfile is so amazingly stupid. ;; defalias calls are output directly by byte-compile-file-form-defmumble; ;; it does not pay to first build the defalias in defmumble and then parse ;; it here. - (if (and (memq (car-safe form) '(defun defmacro defvar defvaralias defconst - autoload custom-declare-variable)) - (stringp (nth 3 form))) - (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil - (memq (car form) - '(defvaralias autoload - custom-declare-variable))) - (let ((print-escape-newlines t) - (print-length nil) - (print-level nil) - (print-quoted t) - (print-gensym t) - (print-circle ; handle circular data structures - (not byte-compile-disable-print-circle))) + (let ((print-escape-newlines t) + (print-length nil) + (print-level nil) + (print-quoted t) + (print-gensym t) + (print-circle ; Handle circular data structures. + (not byte-compile-disable-print-circle))) + (if (and (memq (car-safe form) '(defun defmacro defvar defvaralias defconst + autoload custom-declare-variable)) + (stringp (nth 3 form))) + (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil + (memq (car form) + '(defvaralias autoload + custom-declare-variable))) (princ "\n" byte-compile--outbuffer) (prin1 form byte-compile--outbuffer) nil))) -(defvar print-gensym-alist) ;Used before print-circle existed. (defvar byte-compile--for-effect) (defun byte-compile-output-docform (preface name info form specindex quoted) @@ -2070,7 +2075,6 @@ list that represents a doc string reference. (setq position (byte-compile-output-as-comment (nth (nth 1 info) form) nil)) - (setq position (- (position-bytes position) (point-min) -1)) ;; If the doc string starts with * (a user variable), ;; negate POSITION. (if (and (stringp (nth (nth 1 info) form)) @@ -2083,17 +2087,7 @@ list that represents a doc string reference. (insert preface) (prin1 name byte-compile--outbuffer))) (insert (car info)) - (let ((print-escape-newlines t) - (print-quoted t) - ;; For compatibility with code before print-circle, - ;; use a cons cell to say that we want - ;; print-gensym-alist not to be cleared - ;; between calls to print functions. - (print-gensym '(t)) - (print-circle ; handle circular data structures - (not byte-compile-disable-print-circle)) - print-gensym-alist ; was used before print-circle existed. - (print-continuous-numbering t) + (let ((print-continuous-numbering t) print-number-table (index 0)) (prin1 (car form) byte-compile--outbuffer) @@ -2116,8 +2110,6 @@ list that represents a doc string reference. (byte-compile-output-as-comment (cons (car form) (nth 1 form)) t))) - (setq position (- (position-bytes position) - (point-min) -1)) (princ (format "(#$ . %d) nil" position) byte-compile--outbuffer) (setq form (cdr form)) @@ -2265,19 +2257,7 @@ list that represents a doc string reference. (when (byte-compile-warning-enabled-p 'callargs) (byte-compile-nogroup-warn form)) (push (nth 1 (nth 1 form)) byte-compile-bound-variables) - ;; Don't compile the expression because it may be displayed to the user. - ;; (when (eq (car-safe (nth 2 form)) 'quote) - ;; ;; (nth 2 form) is meant to evaluate to an expression, so if we have the - ;; ;; final value already, we can byte-compile it. - ;; (setcar (cdr (nth 2 form)) - ;; (byte-compile-top-level (cadr (nth 2 form)) nil 'file))) - (let ((tail (nthcdr 4 form))) - (while tail - (unless (keywordp (car tail)) ;No point optimizing keywords. - ;; Compile the keyword arguments. - (setcar tail (byte-compile-top-level (car tail) nil 'file))) - (setq tail (cdr tail)))) - form) + (byte-compile-keep-pending form)) (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) @@ -2324,143 +2304,132 @@ list that represents a doc string reference. (nth 1 (nth 1 form)) (byte-compile-keep-pending form))) -(put 'defun 'byte-hunk-handler 'byte-compile-file-form-defun) -(defun byte-compile-file-form-defun (form) - (byte-compile-file-form-defmumble form nil)) - -(put 'defmacro 'byte-hunk-handler 'byte-compile-file-form-defmacro) -(defun byte-compile-file-form-defmacro (form) - (byte-compile-file-form-defmumble form t)) - -(defun byte-compile-defmacro-declaration (form) - "Generate code for declarations in macro definitions. -Remove declarations from the body of the macro definition -by side-effects." - (let ((tail (nthcdr 2 form)) - (res '())) - (when (stringp (car (cdr tail))) - (setq tail (cdr tail))) - (while (and (consp (car (cdr tail))) - (eq (car (car (cdr tail))) 'declare)) - (let ((declaration (car (cdr tail)))) - (setcdr tail (cdr (cdr tail))) - (push `(if macro-declaration-function - (funcall macro-declaration-function - ',(car (cdr form)) ',declaration)) - res))) - res)) - -(defun byte-compile-file-form-defmumble (form macrop) - (let* ((name (car (cdr form))) - (this-kind (if macrop 'byte-compile-macro-environment - 'byte-compile-function-environment)) - (that-kind (if macrop 'byte-compile-function-environment - 'byte-compile-macro-environment)) - (this-one (assq name (symbol-value this-kind))) - (that-one (assq name (symbol-value that-kind))) - (byte-compile-free-references nil) - (byte-compile-free-assignments nil)) +(defun byte-compile-file-form-defmumble (name macro arglist body rest) + "Process a `defalias' for NAME. +If MACRO is non-nil, the definition is known to be a macro. +ARGLIST is the list of arguments, if it was recognized or t otherwise. +BODY of the definition, or t if not recognized. +Return non-nil if everything went as planned, or nil to imply that it decided +not to take responsibility for the actual compilation of the code." + (let* ((this-kind (if macro 'byte-compile-macro-environment + 'byte-compile-function-environment)) + (that-kind (if macro 'byte-compile-function-environment + 'byte-compile-macro-environment)) + (this-one (assq name (symbol-value this-kind))) + (that-one (assq name (symbol-value that-kind))) + (byte-compile-current-form name)) ; For warnings. + (byte-compile-set-symbol-position name) ;; When a function or macro is defined, add it to the call tree so that ;; we can tell when functions are not used. (if byte-compile-generate-call-tree - (or (assq name byte-compile-call-tree) - (setq byte-compile-call-tree - (cons (list name nil nil) byte-compile-call-tree)))) + (or (assq name byte-compile-call-tree) + (setq byte-compile-call-tree + (cons (list name nil nil) byte-compile-call-tree)))) - (setq byte-compile-current-form name) ; for warnings (if (byte-compile-warning-enabled-p 'redefine) - (byte-compile-arglist-warn form macrop)) + (byte-compile-arglist-warn name arglist macro)) + (if byte-compile-verbose - (message "Compiling %s... (%s)" - (or byte-compile-current-file "") (nth 1 form))) - (cond (that-one - (if (and (byte-compile-warning-enabled-p 'redefine) - ;; don't warn when compiling the stubs in byte-run... - (not (assq (nth 1 form) - byte-compile-initial-macro-environment))) - (byte-compile-warn + (message "Compiling %s... (%s)" + (or byte-compile-current-file "") name)) + (cond ((not (or macro (listp body))) + ;; We do not know positively if the definition is a macro + ;; or a function, so we shouldn't emit warnings. + ;; This also silences "multiple definition" warnings for defmethods. + nil) + (that-one + (if (and (byte-compile-warning-enabled-p 'redefine) + ;; Don't warn when compiling the stubs in byte-run... + (not (assq name byte-compile-initial-macro-environment))) + (byte-compile-warn "`%s' defined multiple times, as both function and macro" - (nth 1 form))) - (setcdr that-one nil)) - (this-one - (when (and (byte-compile-warning-enabled-p 'redefine) - ;; hack: don't warn when compiling the magic internal + name)) + (setcdr that-one nil)) + (this-one + (when (and (byte-compile-warning-enabled-p 'redefine) + ;; Hack: Don't warn when compiling the magic internal ;; byte-compiler macros in byte-run.el... - (not (assq (nth 1 form) - byte-compile-initial-macro-environment))) - (byte-compile-warn "%s `%s' defined multiple times in this file" - (if macrop "macro" "function") - (nth 1 form)))) - ((and (fboundp name) - (eq (car-safe (symbol-function name)) - (if macrop 'lambda 'macro))) - (when (byte-compile-warning-enabled-p 'redefine) - (byte-compile-warn "%s `%s' being redefined as a %s" - (if macrop "function" "macro") - (nth 1 form) - (if macrop "macro" "function"))) - ;; shadow existing definition - (set this-kind - (cons (cons name nil) - (symbol-value this-kind)))) - ) - (let ((body (nthcdr 3 form))) - (when (and (stringp (car body)) - (symbolp (car-safe (cdr-safe body))) - (car-safe (cdr-safe body)) - (stringp (car-safe (cdr-safe (cdr-safe body))))) - (byte-compile-set-symbol-position (nth 1 form)) - (byte-compile-warn "probable `\"' without `\\' in doc string of %s" - (nth 1 form)))) - - ;; Generate code for declarations in macro definitions. - ;; Remove declarations from the body of the macro definition. - (when macrop - (dolist (decl (byte-compile-defmacro-declaration form)) - (prin1 decl byte-compile--outbuffer))) - - (let* ((code (byte-compile-lambda (nthcdr 2 form) t))) - (if this-one - ;; A definition in b-c-initial-m-e should always take precedence - ;; during compilation, so don't let it be redefined. (Bug#8647) - (or (and macrop - (assq name byte-compile-initial-macro-environment)) - (setcdr this-one code)) - (set this-kind - (cons (cons name code) - (symbol-value this-kind)))) - (byte-compile-flush-pending) - (if (not (stringp (nth 3 form))) - ;; No doc string. Provide -1 as the "doc string index" - ;; so that no element will be treated as a doc string. - (byte-compile-output-docform - "\n(defalias '" - name - (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]")) - (append code nil) ; Turn byte-code-function-p into list. - (and (atom code) byte-compile-dynamic - 1) - nil) - ;; Output the form by hand, that's much simpler than having - ;; b-c-output-file-form analyze the defalias. - (byte-compile-output-docform - "\n(defalias '" - name - (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]")) - (append code nil) ; Turn byte-code-function-p into list. - (and (atom code) byte-compile-dynamic - 1) - nil)) - (princ ")" byte-compile--outbuffer) - nil))) + (not (assq name byte-compile-initial-macro-environment))) + (byte-compile-warn "%s `%s' defined multiple times in this file" + (if macro "macro" "function") + name))) + ((and (fboundp name) + (eq (car-safe (symbol-function name)) + (if macro 'lambda 'macro))) + (when (byte-compile-warning-enabled-p 'redefine) + (byte-compile-warn "%s `%s' being redefined as a %s" + (if macro "function" "macro") + name + (if macro "macro" "function"))) + ;; Shadow existing definition. + (set this-kind + (cons (cons name nil) + (symbol-value this-kind)))) + ) + + (when (and (listp body) + (stringp (car body)) + (symbolp (car-safe (cdr-safe body))) + (car-safe (cdr-safe body)) + (stringp (car-safe (cdr-safe (cdr-safe body))))) + ;; FIXME: We've done that already just above, so this looks wrong! + ;;(byte-compile-set-symbol-position name) + (byte-compile-warn "probable `\"' without `\\' in doc string of %s" + name)) + + (if (not (listp body)) + ;; The precise definition requires evaluation to find out, so it + ;; will only be known at runtime. + ;; For a macro, that means we can't use that macro in the same file. + (progn + (unless macro + (push (cons name (if (listp arglist) `(declared ,arglist) t)) + byte-compile-function-environment)) + ;; Tell the caller that we didn't compile it yet. + nil) + + (let* ((code (byte-compile-lambda (cons arglist body) t))) + (if this-one + ;; A definition in b-c-initial-m-e should always take precedence + ;; during compilation, so don't let it be redefined. (Bug#8647) + (or (and macro + (assq name byte-compile-initial-macro-environment)) + (setcdr this-one code)) + (set this-kind + (cons (cons name code) + (symbol-value this-kind)))) + + (if rest + ;; There are additional args to `defalias' (like maybe a docstring) + ;; that the code below can't handle: punt! + nil + ;; Otherwise, we have a bona-fide defun/defmacro definition, and use + ;; special code to allow dynamic docstrings and byte-code. + (byte-compile-flush-pending) + (let ((index + ;; If there's no doc string, provide -1 as the "doc string + ;; index" so that no element will be treated as a doc string. + (if (not (stringp (car body))) -1 4))) + ;; Output the form by hand, that's much simpler than having + ;; b-c-output-file-form analyze the defalias. + (byte-compile-output-docform + "\n(defalias '" + name + (if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]")) + (append code nil) ; Turn byte-code-function-p into list. + (and (atom code) byte-compile-dynamic + 1) + nil)) + (princ ")" byte-compile--outbuffer) + t))))) -;; Print Lisp object EXP in the output file, inside a comment, -;; and return the file position it will have. -;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting. (defun byte-compile-output-as-comment (exp quoted) - (let ((position (point))) - (with-current-buffer byte-compile--outbuffer + "Print Lisp object EXP in the output file, inside a comment, +and return the file (byte) position it will have. +If QUOTED is non-nil, print with quoting; otherwise, print without quoting." + (with-current-buffer byte-compile--outbuffer + (let ((position (point))) ;; Insert EXP, and make it a comment with #@LENGTH. (insert " ") @@ -2485,13 +2454,12 @@ by side-effects." (position-bytes position)))) ;; Save the file position of the object. - ;; Note we should add 1 to skip the space - ;; that we inserted before the actual doc string, - ;; and subtract 1 to convert from an 1-origin Emacs position - ;; to a file position; they cancel. - (setq position (point)) - (goto-char (point-max))) - position)) + ;; Note we add 1 to skip the space that we inserted before the actual doc + ;; string, and subtract point-min to convert from an 1-origin Emacs + ;; position to a file position. + (prog1 + (- (position-bytes (point)) (point-min) -1) + (goto-char (point-max)))))) @@ -2588,14 +2556,15 @@ If FORM is a lambda or a macro, byte-compile it as a function." (lsh nonrest 8) (lsh rest 7))))) -;; Byte-compile a lambda-expression and return a valid function. -;; The value is usually a compiled function but may be the original -;; lambda-expression. -;; When ADD-LAMBDA is non-nil, the symbol `lambda' is added as head -;; of the list FUN and `byte-compile-set-symbol-position' is not called. -;; Use this feature to avoid calling `byte-compile-set-symbol-position' -;; for symbols generated by the byte compiler itself. + (defun byte-compile-lambda (fun &optional add-lambda reserved-csts) + "Byte-compile a lambda-expression and return a valid function. +The value is usually a compiled function but may be the original +lambda-expression. +When ADD-LAMBDA is non-nil, the symbol `lambda' is added as head +of the list FUN and `byte-compile-set-symbol-position' is not called. +Use this feature to avoid calling `byte-compile-set-symbol-position' +for symbols generated by the byte compiler itself." (if add-lambda (setq fun (cons 'lambda fun)) (unless (eq 'lambda (car-safe fun)) @@ -2656,24 +2625,23 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-make-lambda-lexenv fun)) reserved-csts))) ;; Build the actual byte-coded function. - (if (eq 'byte-code (car-safe compiled)) - (apply 'make-byte-code - (if lexical-binding - (byte-compile-make-args-desc arglist) - arglist) - (append - ;; byte-string, constants-vector, stack depth - (cdr compiled) - ;; optionally, the doc string. - (cond (lexical-binding - (require 'help-fns) - (list (help-add-fundoc-usage doc arglist))) - ((or doc int) - (list doc))) - ;; optionally, the interactive spec. - (if int - (list (nth 1 int))))) - (error "byte-compile-top-level did not return byte-code"))))) + (assert (eq 'byte-code (car-safe compiled))) + (apply #'make-byte-code + (if lexical-binding + (byte-compile-make-args-desc arglist) + arglist) + (append + ;; byte-string, constants-vector, stack depth + (cdr compiled) + ;; optionally, the doc string. + (cond (lexical-binding + (require 'help-fns) + (list (help-add-fundoc-usage doc arglist))) + ((or doc int) + (list doc))) + ;; optionally, the interactive spec. + (if int + (list (nth 1 int)))))))) (defvar byte-compile-reserved-constants 0) @@ -3073,9 +3041,9 @@ That command is designed for interactive use only" fn)) (byte-compile-check-variable var 'assign) (let ((lex-binding (assq var byte-compile--lexical-environment))) (if lex-binding - ;; VAR is lexically bound + ;; VAR is lexically bound. (byte-compile-stack-set (cdr lex-binding)) - ;; VAR is dynamically bound + ;; VAR is dynamically bound. (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) (boundp var) (memq var byte-compile-bound-variables) @@ -3360,6 +3328,7 @@ discarding." (body (nthcdr 3 form)) (fun (byte-compile-lambda `(lambda ,vars . ,body) nil (length env)))) + (assert (> (length env) 0)) ;Otherwise, we don't need a closure. (assert (byte-code-function-p fun)) (byte-compile-form `(make-byte-code ',(aref fun 0) ',(aref fun 1) @@ -4081,36 +4050,11 @@ binding slots have been popped." ;;; top-level forms elsewhere -(byte-defop-compiler-1 defun) -(byte-defop-compiler-1 defmacro) (byte-defop-compiler-1 defvar) (byte-defop-compiler-1 defconst byte-compile-defvar) (byte-defop-compiler-1 autoload) (byte-defop-compiler-1 lambda byte-compile-lambda-form) -(defun byte-compile-defun (form) - ;; This is not used for file-level defuns with doc strings. - (if (symbolp (car form)) - (byte-compile-set-symbol-position (car form)) - (byte-compile-set-symbol-position 'defun) - (error "defun name must be a symbol, not %s" (car form))) - (byte-compile-push-constant 'defalias) - (byte-compile-push-constant (nth 1 form)) - (byte-compile-push-constant (byte-compile-lambda (cdr (cdr form)) t)) - (byte-compile-out 'byte-call 2)) - -(defun byte-compile-defmacro (form) - ;; This is not used for file-level defmacros with doc strings. - (byte-compile-body-do-effect - (let ((decls (byte-compile-defmacro-declaration form)) - (code (byte-compile-lambda (cdr (cdr form)) t))) - `((defalias ',(nth 1 form) - ,(if (eq (car-safe code) 'make-byte-code) - `(cons 'macro ,code) - `'(macro . ,(eval code)))) - ,@decls - ',(nth 1 form))))) - ;; If foo.el declares `toto' as obsolete, it is likely that foo.el will ;; actually use `toto' in order for this obsolete variable to still work ;; correctly, so paradoxically, while byte-compiling foo.el, the presence @@ -4186,38 +4130,53 @@ binding slots have been popped." (put 'defalias 'byte-hunk-handler 'byte-compile-file-form-defalias) ;; Used for eieio--defalias as well. (defun byte-compile-file-form-defalias (form) - (if (and (consp (cdr form)) (consp (nth 1 form)) - (eq (car (nth 1 form)) 'quote) - (consp (cdr (nth 1 form))) - (symbolp (nth 1 (nth 1 form)))) - (let ((constant - (and (consp (nthcdr 2 form)) - (consp (nth 2 form)) - (eq (car (nth 2 form)) 'quote) - (consp (cdr (nth 2 form))) - (symbolp (nth 1 (nth 2 form)))))) - (byte-compile-defalias-warn (nth 1 (nth 1 form))) - (push (cons (nth 1 (nth 1 form)) - (if constant (nth 1 (nth 2 form)) t)) - byte-compile-function-environment))) - ;; We used to just do: (byte-compile-normal-call form) - ;; But it turns out that this fails to optimize the code. - ;; So instead we now do the same as what other byte-hunk-handlers do, - ;; which is to call back byte-compile-file-form and then return nil. - ;; Except that we can't just call byte-compile-file-form since it would - ;; call us right back. - (byte-compile-keep-pending form) - ;; Return nil so the form is not output twice. - nil) - -;; Turn off warnings about prior calls to the function being defalias'd. -;; This could be smarter and compare those calls with -;; the function it is being aliased to. -(defun byte-compile-defalias-warn (new) - (let ((calls (assq new byte-compile-unresolved-functions))) - (if calls - (setq byte-compile-unresolved-functions - (delq calls byte-compile-unresolved-functions))))) + ;; For the compilation itself, we could largely get rid of this hunk-handler, + ;; if it weren't for the fact that we need to figure out when a defalias + ;; defines a macro, so as to add it to byte-compile-macro-environment. + ;; + ;; FIXME: we also use this hunk-handler to implement the function's dynamic + ;; docstring feature. We could actually implement it more elegantly in + ;; byte-compile-lambda so it applies to all lambdas, but the problem is that + ;; the resulting .elc format will not be recognized by make-docfile, so + ;; either we stop using DOC for the docstrings of preloaded elc files (at the + ;; cost of around 24KB on 32bit hosts, double on 64bit hosts) or we need to + ;; build DOC in a more clever way (e.g. handle anonymous elements). + (let ((byte-compile-free-references nil) + (byte-compile-free-assignments nil)) + (pcase form + ;; Decompose `form' into: + ;; - `name' is the name of the defined function. + ;; - `arg' is the expression to which it is defined. + ;; - `rest' is the rest of the arguments. + (`(,_ ',name ,arg . ,rest) + (pcase-let* + ;; `macro' is non-nil if it defines a macro. + ;; `fun' is the function part of `arg' (defaults to `arg'). + (((or (and (or `(cons 'macro ,fun) `'(macro . ,fun)) (let macro t)) + (and (let fun arg) (let macro nil))) + arg) + ;; `lam' is the lambda expression in `fun' (or nil if not + ;; recognized). + ((or `(,(or `quote `function) ,lam) (let lam nil)) + fun) + ;; `arglist' is the list of arguments (or t if not recognized). + ;; `body' is the body of `lam' (or t if not recognized). + ((or `(lambda ,arglist . ,body) + ;; `(closure ,_ ,arglist . ,body) + (and `(internal-make-closure ,arglist . ,_) (let body t)) + (and (let arglist t) (let body t))) + lam)) + (unless (byte-compile-file-form-defmumble + name macro arglist body rest) + (byte-compile-keep-pending form)))) + + ;; We used to just do: (byte-compile-normal-call form) + ;; But it turns out that this fails to optimize the code. + ;; So instead we now do the same as what other byte-hunk-handlers do, + ;; which is to call back byte-compile-file-form and then return nil. + ;; Except that we can't just call byte-compile-file-form since it would + ;; call us right back. + (t (byte-compile-keep-pending form))))) (byte-defop-compiler-1 with-no-warnings byte-compile-no-warnings) (defun byte-compile-no-warnings (form) @@ -4525,29 +4484,30 @@ already up-to-date." (kill-emacs (if error 1 0)))) (defun batch-byte-compile-file (file) - (if debug-on-error - (byte-compile-file file) - (condition-case err - (byte-compile-file file) - (file-error - (message (if (cdr err) - ">>Error occurred processing %s: %s (%s)" - ">>Error occurred processing %s: %s") - file - (get (car err) 'error-message) - (prin1-to-string (cdr err))) - (let ((destfile (byte-compile-dest-file file))) - (if (file-exists-p destfile) - (delete-file destfile))) - nil) - (error - (message (if (cdr err) - ">>Error occurred processing %s: %s (%s)" - ">>Error occurred processing %s: %s") - file - (get (car err) 'error-message) - (prin1-to-string (cdr err))) - nil)))) + (let ((byte-compile-root-dir (or byte-compile-root-dir default-directory))) + (if debug-on-error + (byte-compile-file file) + (condition-case err + (byte-compile-file file) + (file-error + (message (if (cdr err) + ">>Error occurred processing %s: %s (%s)" + ">>Error occurred processing %s: %s") + file + (get (car err) 'error-message) + (prin1-to-string (cdr err))) + (let ((destfile (byte-compile-dest-file file))) + (if (file-exists-p destfile) + (delete-file destfile))) + nil) + (error + (message (if (cdr err) + ">>Error occurred processing %s: %s (%s)" + ">>Error occurred processing %s: %s") + file + (get (car err) 'error-message) + (prin1-to-string (cdr err))) + nil))))) (defun byte-compile-refresh-preloaded () "Reload any Lisp file that was changed since Emacs was dumped. diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index b6b6a78a9bb..f43dd9e7ee4 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -73,8 +73,6 @@ ;; since afterwards they can because obnoxious (warnings about an "unused ;; variable" should not be emitted when the variable use has simply been ;; optimized away). -;; - turn defun and defmacro into macros (and remove special handling of -;; `declare' afterwards). ;; - let macros specify that some let-bindings come from the same source, ;; so the unused warning takes all uses into account. ;; - let interactive specs return a function to build the args (to stash into @@ -410,20 +408,6 @@ places where they originally did not directly appear." . ,(mapcar (lambda (form) (cconv-convert form env extend)) forms))) - ;defun, defmacro - (`(,(and sym (or `defun `defmacro)) - ,func ,args . ,body) - (assert (equal body (caar cconv-freevars-alist))) - (assert (null (cdar cconv-freevars-alist))) - - (let ((new (cconv--convert-function args body env form))) - (pcase new - (`(function (lambda ,newargs . ,new-body)) - (assert (equal args newargs)) - `(,sym ,func ,args . ,new-body)) - (t (byte-compile-report-error - (format "Internal error in cconv of (%s %s ...)" sym func)))))) - ;condition-case (`(condition-case ,var ,protected-form . ,handlers) (let ((newform (cconv--convert-function @@ -618,15 +602,6 @@ and updates the data stored in ENV." (dolist (vardata newvars) (cconv--analyse-use vardata form "variable")))) - ; defun special form - (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms) - (when env - (byte-compile-log-warning - (format "Function %S will ignore its context %S" - func (mapcar #'car env)) - t :warning)) - (cconv--analyse-function vrs body-forms nil form)) - (`(function (lambda ,vrs . ,body-forms)) (cconv--analyse-function vrs body-forms env form)) @@ -639,7 +614,9 @@ and updates the data stored in ENV." (cconv-analyse-form (cadr forms) env) (setq forms (cddr forms)))) - (`((lambda . ,_) . ,_) ; first element is lambda expression + (`((lambda . ,_) . ,_) ; First element is lambda expression. + (byte-compile-log-warning + "Use of deprecated ((lambda ...) ...) form" t :warning) (dolist (exp `((function ,(car form)) . ,(cdr form))) (cconv-analyse-form exp env))) diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 19766feac5a..74087014d69 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -62,8 +62,8 @@ (require 'eieio) ;;; Code: -(defvar chart-mode-map (make-sparse-keymap) "Keymap used in chart mode.") (define-obsolete-variable-alias 'chart-map 'chart-mode-map "24.1") +(defvar chart-mode-map (make-sparse-keymap) "Keymap used in chart mode.") (defvar chart-local-object nil "Local variable containing the locally displayed chart object.") @@ -82,7 +82,7 @@ Colors will be the background color.") Useful if new Emacs is used on B&W display.") (defcustom chart-face-use-pixmaps nil - "*Non-nil to use fancy pixmaps in the background of chart face colors." + "Non-nil to use fancy pixmaps in the background of chart face colors." :group 'eieio :type 'boolean) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 7a9a33fc2cc..ee8cbd2c3bc 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -916,7 +916,7 @@ is the starting location. If this is nil, `point-min' is used instead." (progn (goto-char wrong) (if (not take-notes) - (error "%s" (checkdoc-error-text msg))))) + (user-error "%s" (checkdoc-error-text msg))))) (checkdoc-show-diagnostics) (if (called-interactively-p 'interactive) (message "No style warnings.")))) @@ -949,7 +949,7 @@ if there is one." (e (checkdoc-file-comments-engine)) (checkdoc-generate-compile-warnings-flag (or take-notes checkdoc-generate-compile-warnings-flag))) - (if e (error "%s" (checkdoc-error-text e))) + (if e (user-error "%s" (checkdoc-error-text e))) (checkdoc-show-diagnostics) e)) @@ -987,7 +987,7 @@ Optional argument TAKE-NOTES causes all errors to be logged." (if (not (called-interactively-p 'interactive)) e (if e - (error "%s" (checkdoc-error-text e)) + (user-error "%s" (checkdoc-error-text e)) (checkdoc-show-diagnostics))) (goto-char p)) (if (called-interactively-p 'interactive) @@ -1027,19 +1027,14 @@ space at the end of each line." (car (memq checkdoc-spellcheck-documentation-flag '(defun t)))) (beg (save-excursion (beginning-of-defun) (point))) - (end (save-excursion (end-of-defun) (point))) - (msg (checkdoc-this-string-valid))) - (if msg (if no-error - (message "%s" (checkdoc-error-text msg)) - (error "%s" (checkdoc-error-text msg))) - (setq msg (checkdoc-message-text-search beg end)) - (if msg (if no-error - (message "%s" (checkdoc-error-text msg)) - (error "%s" (checkdoc-error-text msg))) - (setq msg (checkdoc-rogue-space-check-engine beg end)) - (if msg (if no-error - (message "%s" (checkdoc-error-text msg)) - (error "%s" (checkdoc-error-text msg)))))) + (end (save-excursion (end-of-defun) (point)))) + (dolist (fun (list #'checkdoc-this-string-valid + (lambda () (checkdoc-message-text-search beg end)) + (lambda () (checkdoc-rogue-space-check-engine beg end)))) + (let ((msg (funcall fun))) + (if msg (if no-error + (message "%s" (checkdoc-error-text msg)) + (user-error "%s" (checkdoc-error-text msg)))))) (if (called-interactively-p 'interactive) (message "Checkdoc: done.")))))) @@ -2644,12 +2639,6 @@ function called to create the messages." (custom-add-option 'emacs-lisp-mode-hook 'checkdoc-minor-mode) -(add-to-list 'debug-ignored-errors - "Argument `.*' should appear (as .*) in the doc string") -(add-to-list 'debug-ignored-errors - "Lisp symbol `.*' should appear in quotes") -(add-to-list 'debug-ignored-errors "Disambiguate .* by preceding .*") - (provide 'checkdoc) ;;; checkdoc.el ends here diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 9ac5ce7d2f0..420480d16ea 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -1,6 +1,6 @@ ;;; cl-extra.el --- Common Lisp features, part 2 -;; Copyright (C) 1993, 2000-2012 Free Software Foundation, Inc. +;; Copyright (C) 1993, 2000-2012 Free Software Foundation, Inc. ;; Author: Dave Gillespie <daveg@synaptics.com> ;; Keywords: extensions @@ -430,12 +430,11 @@ With two arguments, return rounding and remainder of their quotient." ;; Random numbers. -(defvar *random-state*) ;;;###autoload (defun random* (lim &optional state) "Return a random nonnegative number less than LIM, an integer or float. Optional second arg STATE is a random-state object." - (or state (setq state *random-state*)) + (or state (setq state cl--random-state)) ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. (let ((vec (aref state 3))) (if (integerp vec) @@ -458,9 +457,9 @@ Optional second arg STATE is a random-state object." ;;;###autoload (defun make-random-state (&optional state) - "Return a copy of random-state STATE, or of `*random-state*' if omitted. + "Return a copy of random-state STATE, or of the internal state if omitted. If STATE is t, return a new state object seeded from the time of day." - (cond ((null state) (make-random-state *random-state*)) + (cond ((null state) (make-random-state cl--random-state)) ((vectorp state) (cl-copy-tree state t)) ((integerp state) (vector 'cl-random-state-tag -1 30 state)) (t (make-random-state (cl-random-time))))) diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index b75239d2a38..a9380619e6a 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" "c172dda6770ce18b556561481bfefbb2") +;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "1a3a04c6a0286373093bea4b9bcf2e91") ;;; Generated autoloads from cl-extra.el (autoload 'coerce "cl-extra" "\ @@ -169,7 +169,7 @@ Optional second arg STATE is a random-state object. \(fn LIM &optional STATE)" nil nil) (autoload 'make-random-state "cl-extra" "\ -Return a copy of random-state STATE, or of `*random-state*' if omitted. +Return a copy of random-state STATE, or of the internal state if omitted. If STATE is t, return a new state object seeded from the time of day. \(fn &optional STATE)" nil nil) @@ -286,7 +286,7 @@ This also does some trivial optimizations to make the form prettier. ;;;;;; 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" "0be85e9c7ef309d2ccbac18b9b0f1d42") +;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "c383ef0fa5f6d28796cd8e9cf65e1c5d") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ @@ -308,6 +308,10 @@ and BODY is implicitly surrounded by (block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" nil (quote macro)) +(put 'defun* 'lisp-indent-function '2) + +(put 'defun* 'doc-string-elt '3) + (autoload 'defmacro* "cl-macs" "\ Define NAME as a macro. Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, @@ -315,6 +319,10 @@ and BODY is implicitly surrounded by (block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" nil (quote macro)) +(put 'defmacro* 'lisp-indent-function '2) + +(put 'defmacro* 'doc-string-elt '3) + (autoload 'function* "cl-macs" "\ Introduce a function. Like normal `function', except that if argument is a lambda form, @@ -327,6 +335,8 @@ its argument list allows full Common Lisp conventions. \(fn ARGS EXPR &rest BODY)" nil (quote macro)) +(put 'destructuring-bind 'lisp-indent-function '2) + (autoload 'eval-when "cl-macs" "\ Control when BODY is evaluated. If `compile' is in WHEN, BODY is evaluated when compiled at top-level. @@ -335,6 +345,8 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. \(fn (WHEN...) BODY...)" nil (quote macro)) +(put 'eval-when 'lisp-indent-function '1) + (autoload 'load-time-value "cl-macs" "\ Like `progn', but evaluates the body at load time. The result of the body appears to the compiler as a quoted constant. @@ -352,12 +364,16 @@ Key values are compared by `eql'. \(fn EXPR (KEYLIST BODY...)...)" nil (quote macro)) +(put 'case 'lisp-indent-function '1) + (autoload 'ecase "cl-macs" "\ Like `case', but error if no case fits. `otherwise'-clauses are not allowed. \(fn EXPR (KEYLIST BODY...)...)" nil (quote macro)) +(put 'ecase 'lisp-indent-function '1) + (autoload 'typecase "cl-macs" "\ Evals EXPR, chooses among clauses on that value. Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it @@ -367,12 +383,16 @@ final clause, and matches if no other keys match. \(fn EXPR (TYPE BODY...)...)" nil (quote macro)) +(put 'typecase 'lisp-indent-function '1) + (autoload 'etypecase "cl-macs" "\ Like `typecase', but error if no case fits. `otherwise'-clauses are not allowed. \(fn EXPR (TYPE BODY...)...)" nil (quote macro)) +(put 'etypecase 'lisp-indent-function '1) + (autoload 'block "cl-macs" "\ Define a lexically-scoped block named NAME. NAME may be any symbol. Code inside the BODY forms can call `return-from' @@ -385,6 +405,8 @@ called from BODY. \(fn NAME &rest BODY)" nil (quote macro)) +(put 'block 'lisp-indent-function '1) + (autoload 'return "cl-macs" "\ Return from the block named nil. This is equivalent to `(return-from nil RESULT)'. @@ -400,6 +422,8 @@ This is compatible with Common Lisp, but note that `defun' and \(fn NAME &optional RESULT)" nil (quote macro)) +(put 'return-from 'lisp-indent-function '1) + (autoload 'loop "cl-macs" "\ The Common Lisp `loop' macro. Valid clauses are: @@ -421,11 +445,15 @@ The Common Lisp `do' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil (quote macro)) +(put 'do 'lisp-indent-function '2) + (autoload 'do* "cl-macs" "\ The Common Lisp `do*' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil (quote macro)) +(put 'do* 'lisp-indent-function '2) + (autoload 'dolist "cl-macs" "\ Loop over a list. Evaluate BODY with VAR bound to each `car' from LIST, in turn. @@ -449,11 +477,15 @@ from OBARRAY. \(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil (quote macro)) +(put 'do-symbols 'lisp-indent-function '1) + (autoload 'do-all-symbols "cl-macs" "\ \(fn SPEC &rest BODY)" nil (quote macro)) +(put 'do-all-symbols 'lisp-indent-function '1) + (autoload 'psetq "cl-macs" "\ Set SYMs to the values VALs in parallel. This is like `setq', except that all VAL forms are evaluated (in order) @@ -471,6 +503,8 @@ a `let' form, except that the list of symbols can be computed at run-time. \(fn SYMBOLS VALUES &rest BODY)" nil (quote macro)) +(put 'progv 'lisp-indent-function '2) + (autoload 'flet "cl-macs" "\ Make temporary function definitions. This is an analogue of `let' that operates on the function cell of FUNC @@ -480,6 +514,8 @@ go back to their previous definitions, or lack thereof). \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil (quote macro)) +(put 'flet 'lisp-indent-function '1) + (autoload 'labels "cl-macs" "\ Make temporary function bindings. This is like `flet', except the bindings are lexical instead of dynamic. @@ -487,12 +523,16 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil (quote macro)) +(put 'labels 'lisp-indent-function '1) + (autoload 'macrolet "cl-macs" "\ Make temporary macro definitions. This is like `flet', but for macros instead of functions. \(fn ((NAME ARGLIST BODY...) ...) FORM...)" nil (quote macro)) +(put 'macrolet 'lisp-indent-function '1) + (autoload 'symbol-macrolet "cl-macs" "\ Make symbol macro definitions. Within the body FORMs, references to the variable NAME will be replaced @@ -500,6 +540,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). \(fn ((NAME EXPANSION) ...) FORM...)" nil (quote macro)) +(put 'symbol-macrolet 'lisp-indent-function '1) + (autoload 'lexical-let "cl-macs" "\ Like `let', but lexically scoped. The main visible difference is that lambdas inside BODY will create @@ -507,6 +549,8 @@ lexical closures as in Common Lisp. \(fn BINDINGS BODY)" nil (quote macro)) +(put 'lexical-let 'lisp-indent-function '1) + (autoload 'lexical-let* "cl-macs" "\ Like `let*', but lexically scoped. The main visible difference is that lambdas inside BODY, and in @@ -516,6 +560,8 @@ Common Lisp. \(fn BINDINGS BODY)" nil (quote macro)) +(put 'lexical-let* 'lisp-indent-function '1) + (autoload 'multiple-value-bind "cl-macs" "\ Collect multiple return values. FORM must return a list; the BODY is then executed with the first N elements @@ -526,6 +572,8 @@ a synonym for (list A B C). \(fn (SYM...) FORM BODY)" nil (quote macro)) +(put 'multiple-value-bind 'lisp-indent-function '2) + (autoload 'multiple-value-setq "cl-macs" "\ Collect multiple return values. FORM must return a list; the first N elements of this list are stored in @@ -535,6 +583,8 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). \(fn (SYM...) FORM)" nil (quote macro)) +(put 'multiple-value-setq 'lisp-indent-function '1) + (autoload 'locally "cl-macs" "\ @@ -545,6 +595,8 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). \(fn TYPE FORM)" nil (quote macro)) +(put 'the 'lisp-indent-function '1) + (autoload 'declare "cl-macs" "\ Declare SPECS about the current function while compiling. For instance @@ -649,6 +701,8 @@ the PLACE is not modified before executing BODY. \(fn ((PLACE VALUE) ...) BODY...)" nil (quote macro)) +(put 'letf 'lisp-indent-function '1) + (autoload 'letf* "cl-macs" "\ Temporarily bind to PLACEs. This is the analogue of `let*', but with generalized variables (in the @@ -661,6 +715,8 @@ the PLACE is not modified before executing BODY. \(fn ((PLACE VALUE) ...) BODY...)" nil (quote macro)) +(put 'letf* 'lisp-indent-function '1) + (autoload 'callf "cl-macs" "\ Set PLACE to (FUNC PLACE ARGS...). FUNC should be an unquoted function name. PLACE may be a symbol, @@ -668,12 +724,16 @@ or any generalized variable allowed by `setf'. \(fn FUNC PLACE ARGS...)" nil (quote macro)) +(put 'callf 'lisp-indent-function '2) + (autoload 'callf2 "cl-macs" "\ Set PLACE to (FUNC ARG1 PLACE ARGS...). Like `callf', but PLACE is the second argument of FUNC, not the first. \(fn FUNC ARG1 PLACE ARGS...)" nil (quote macro)) +(put 'callf2 'lisp-indent-function '3) + (autoload 'define-modify-macro "cl-macs" "\ Define a `setf'-like modify macro. If NAME is called, it combines its PLACE argument with the other arguments @@ -699,6 +759,8 @@ value, that slot cannot be set via `setf'. \(fn NAME SLOTS...)" nil (quote macro)) +(put 'defstruct 'doc-string-elt '2) + (autoload 'cl-struct-setf-expander "cl-macs" "\ @@ -710,6 +772,8 @@ The type name can then be used in `typecase', `check-type', etc. \(fn NAME ARGLIST &rest BODY)" nil (quote macro)) +(put 'deftype 'doc-string-elt '3) + (autoload 'typep "cl-macs" "\ Check that OBJECT is of type TYPE. TYPE is a Common Lisp-style type specifier. @@ -764,13 +828,13 @@ surrounded by (block NAME ...). ;;;;;; nsubst subst-if-not subst-if subsetp nset-exclusive-or set-exclusive-or ;;;;;; nset-difference set-difference nintersection intersection ;;;;;; nunion union rassoc-if-not rassoc-if rassoc* assoc-if-not -;;;;;; assoc-if assoc* cl-adjoin member-if-not member-if member* +;;;;;; assoc-if assoc* cl--adjoin member-if-not member-if member* ;;;;;; merge stable-sort sort* search mismatch count-if-not count-if ;;;;;; count position-if-not position-if position find-if-not find-if ;;;;;; find nsubstitute-if-not nsubstitute-if nsubstitute substitute-if-not ;;;;;; substitute-if substitute delete-duplicates remove-duplicates ;;;;;; delete-if-not delete-if delete* remove-if-not remove-if remove* -;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "99095e49c83af1c8bec0fdcf517b3f95") +;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "2d8563fcbdf4bc77e569d0aeb0a35cfc") ;;; Generated autoloads from cl-seq.el (autoload 'reduce "cl-seq" "\ @@ -1047,7 +1111,7 @@ Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'cl-adjoin "cl-seq" "\ +(autoload 'cl--adjoin "cl-seq" "\ \(fn CL-ITEM CL-LIST &rest CL-KEYS)" nil nil) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index f58fc70053f..c547a4f6460 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -143,11 +143,16 @@ ;;; Count number of times X refers to Y. Return nil for 0 times. (defun cl-expr-contains (x y) + ;; FIXME: This is naive, and it will count Y as referred twice in + ;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on + ;; non-macroexpanded code, so it may also miss some occurrences that would + ;; only appear in the expanded code. (cond ((equal y x) 1) ((and (consp x) (not (memq (car-safe x) '(quote function function*)))) (let ((sum 0)) - (while x + (while (consp x) (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))) + (setq sum (+ sum (or (cl-expr-contains x y) 0))) (and (> sum 0) sum))) (t nil))) @@ -162,15 +167,15 @@ ;;; Symbols. -(defvar *gensym-counter*) +(defvar cl--gensym-counter) ;;;###autoload (defun gensym (&optional prefix) "Generate a new uninterned symbol. The name is made by appending a number to PREFIX, default \"G\"." (let ((pfix (if (stringp prefix) prefix "G")) (num (if (integerp prefix) prefix - (prog1 *gensym-counter* - (setq *gensym-counter* (1+ *gensym-counter*)))))) + (prog1 cl--gensym-counter + (setq cl--gensym-counter (1+ cl--gensym-counter)))))) (make-symbol (format "%s%d" pfix num)))) ;;;###autoload @@ -179,13 +184,35 @@ The name is made by appending a number to PREFIX, default \"G\"." The name is made by appending a number to PREFIX, default \"G\"." (let ((pfix (if (stringp prefix) prefix "G")) name) - (while (intern-soft (setq name (format "%s%d" pfix *gensym-counter*))) - (setq *gensym-counter* (1+ *gensym-counter*))) + (while (intern-soft (setq name (format "%s%d" pfix cl--gensym-counter))) + (setq cl--gensym-counter (1+ cl--gensym-counter))) (intern name))) ;;; Program structure. +(def-edebug-spec cl-declarations + (&rest ("declare" &rest sexp))) + +(def-edebug-spec cl-declarations-or-string + (&or stringp cl-declarations)) + +(def-edebug-spec cl-lambda-list + (([&rest arg] + [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] + [&optional ["&rest" arg]] + [&optional ["&key" [cl-&key-arg &rest cl-&key-arg] + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (symbolp &optional def-form) symbolp]] + ))) + +(def-edebug-spec cl-&optional-arg + (&or (arg &optional def-form arg) arg)) + +(def-edebug-spec cl-&key-arg + (&or ([&or (symbolp arg) arg] &optional def-form arg) arg)) + ;;;###autoload (defmacro defun* (name args &rest body) "Define NAME as a function. @@ -193,10 +220,57 @@ Like normal `defun', except ARGLIST allows full Common Lisp conventions, and BODY is implicitly surrounded by (block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug + ;; Same as defun but use cl-lambda-list. + (&define [&or name ("setf" :name setf name)] + cl-lambda-list + cl-declarations-or-string + [&optional ("interactive" interactive)] + def-body)) + (doc-string 3) + (indent 2)) (let* ((res (cl-transform-lambda (cons args body) name)) (form (list* 'defun name (cdr res)))) (if (car res) (list 'progn (car res) form) form))) +;; The lambda list for macros is different from that of normal lambdas. +;; Note that &environment is only allowed as first or last items in the +;; top level list. + +(def-edebug-spec cl-macro-list + (([&optional "&environment" arg] + [&rest cl-macro-arg] + [&optional ["&optional" &rest + &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] + [&optional [[&or "&rest" "&body"] cl-macro-arg]] + [&optional ["&key" [&rest + [&or ([&or (symbolp cl-macro-arg) arg] + &optional def-form cl-macro-arg) + arg]] + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (symbolp &optional def-form) symbolp]] + [&optional "&environment" arg] + ))) + +(def-edebug-spec cl-macro-arg + (&or arg cl-macro-list1)) + +(def-edebug-spec cl-macro-list1 + (([&optional "&whole" arg] ;; only allowed at lower levels + [&rest cl-macro-arg] + [&optional ["&optional" &rest + &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] + [&optional [[&or "&rest" "&body"] cl-macro-arg]] + [&optional ["&key" [&rest + [&or ([&or (symbolp cl-macro-arg) arg] + &optional def-form cl-macro-arg) + arg]] + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (symbolp &optional def-form) symbolp]] + . [&or arg nil]))) + ;;;###autoload (defmacro defmacro* (name args &rest body) "Define NAME as a macro. @@ -204,15 +278,34 @@ Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, and BODY is implicitly surrounded by (block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug + (&define name cl-macro-list cl-declarations-or-string def-body)) + (doc-string 3) + (indent 2)) (let* ((res (cl-transform-lambda (cons args body) name)) (form (list* 'defmacro name (cdr res)))) (if (car res) (list 'progn (car res) form) form))) +(def-edebug-spec cl-lambda-expr + (&define ("lambda" cl-lambda-list + ;;cl-declarations-or-string + ;;[&optional ("interactive" interactive)] + def-body))) + +;; Redefine function-form to also match function* +(def-edebug-spec function-form + ;; form at the end could also handle "function", + ;; but recognize it specially to avoid wrapping function forms. + (&or ([&or "quote" "function"] &or symbolp lambda-expr) + ("function*" function*) + form)) + ;;;###autoload (defmacro function* (func) "Introduce a function. Like normal `function', except that if argument is a lambda form, its argument list allows full Common Lisp conventions." + (declare (debug (&or symbolp cl-lambda-expr))) (if (eq (car-safe func) 'lambda) (let* ((res (cl-transform-lambda (cdr func) 'cl-none)) (form (list 'function (cons 'lambda (cdr res))))) @@ -466,6 +559,8 @@ It is a list of elements of the form either: ;;;###autoload (defmacro destructuring-bind (args expr &rest body) + (declare (indent 2) + (debug (&define cl-macro-list def-form cl-declarations def-body))) (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil) (bind-defs nil) (bind-block 'cl-none) (bind-enquote nil)) (cl-do-arglist (or args '(&aux)) expr) @@ -486,6 +581,7 @@ If `load' is in WHEN, BODY is evaluated when loaded after top-level compile. If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. \(fn (WHEN...) BODY...)" + (declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body))) (if (and (fboundp 'cl-compiling-file) (cl-compiling-file) (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) @@ -514,6 +610,7 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. (defmacro load-time-value (form &optional read-only) "Like `progn', but evaluates the body at load time. The result of the body appears to the compiler as a quoted constant." + (declare (debug (form &optional sexp))) (if (cl-compiling-file) (let* ((temp (gentemp "--cl-load-time--")) (set (list 'set (list 'quote temp) form))) @@ -543,6 +640,7 @@ place of a KEYLIST of one atom. A KEYLIST of t or `otherwise' is allowed only in the final clause, and matches if no other keys match. Key values are compared by `eql'. \n(fn EXPR (KEYLIST BODY...)...)" + (declare (indent 1) (debug (form &rest (sexp body)))) (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) (head-list nil) (body (cons @@ -573,6 +671,7 @@ Key values are compared by `eql'. "Like `case', but error if no case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (KEYLIST BODY...)...)" + (declare (indent 1) (debug case)) (list* 'case expr (append clauses '((ecase-error-flag))))) ;;;###autoload @@ -583,6 +682,8 @@ satisfies TYPE, the corresponding BODY is evaluated. If no clause succeeds, typecase returns nil. A TYPE of t or `otherwise' is allowed only in the final clause, and matches if no other keys match. \n(fn EXPR (TYPE BODY...)...)" + (declare (indent 1) + (debug (form &rest ([&or cl-type-spec "otherwise"] body)))) (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) (type-list nil) (body (cons @@ -607,6 +708,7 @@ final clause, and matches if no other keys match. "Like `typecase', but error if no case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (TYPE BODY...)...)" + (declare (indent 1) (debug typecase)) (list* 'typecase expr (append clauses '((ecase-error-flag))))) @@ -622,6 +724,7 @@ quoted symbol or other form; and second, NAME is lexically rather than dynamically scoped: Only references to it within BODY will work. These references may appear inside macro expansions, but not inside functions called from BODY." + (declare (indent 1) (debug (symbolp body))) (if (cl-safe-expr-p (cons 'progn body)) (cons 'progn body) (list 'cl-block-wrapper (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name))) @@ -631,6 +734,7 @@ called from BODY." (defmacro return (&optional result) "Return from the block named nil. This is equivalent to `(return-from nil RESULT)'." + (declare (debug (&optional form))) (list 'return-from nil result)) ;;;###autoload @@ -640,6 +744,7 @@ This jumps out to the innermost enclosing `(block NAME ...)' form, returning RESULT from that form (or nil if RESULT is omitted). This is compatible with Common Lisp, but note that `defun' and `defmacro' do not create implicit blocks as they do in Common Lisp." + (declare (indent 1) (debug (symbolp &optional form))) (let ((name2 (intern (format "--cl-block-%s--" name)))) (list 'cl-block-throw (list 'quote name2) result))) @@ -669,6 +774,7 @@ Valid clauses are: finally return EXPR, named NAME. \(fn CLAUSE...)" + (declare (debug (&rest &or symbolp form))) (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) @@ -720,6 +826,158 @@ Valid clauses are: (setq body (list (list* 'symbol-macrolet loop-symbol-macs body)))) (list* 'block loop-name body))))) +;; Below is a complete spec for loop, in several parts that correspond +;; to the syntax given in CLtL2. The specs do more than specify where +;; the forms are; it also specifies, as much as Edebug allows, all the +;; syntactically valid loop clauses. The disadvantage of this +;; completeness is rigidity, but the "for ... being" clause allows +;; arbitrary extensions of the form: [symbolp &rest &or symbolp form]. + +;; (def-edebug-spec loop +;; ([&optional ["named" symbolp]] +;; [&rest +;; &or +;; ["repeat" form] +;; loop-for-as +;; loop-with +;; loop-initial-final] +;; [&rest loop-clause] +;; )) + +;; (def-edebug-spec loop-with +;; ("with" loop-var +;; loop-type-spec +;; [&optional ["=" form]] +;; &rest ["and" loop-var +;; loop-type-spec +;; [&optional ["=" form]]])) + +;; (def-edebug-spec loop-for-as +;; ([&or "for" "as"] loop-for-as-subclause +;; &rest ["and" loop-for-as-subclause])) + +;; (def-edebug-spec loop-for-as-subclause +;; (loop-var +;; loop-type-spec +;; &or +;; [[&or "in" "on" "in-ref" "across-ref"] +;; form &optional ["by" function-form]] + +;; ["=" form &optional ["then" form]] +;; ["across" form] +;; ["being" +;; [&or "the" "each"] +;; &or +;; [[&or "element" "elements"] +;; [&or "of" "in" "of-ref"] form +;; &optional "using" ["index" symbolp]];; is this right? +;; [[&or "hash-key" "hash-keys" +;; "hash-value" "hash-values"] +;; [&or "of" "in"] +;; hash-table-p &optional ["using" ([&or "hash-value" "hash-values" +;; "hash-key" "hash-keys"] sexp)]] + +;; [[&or "symbol" "present-symbol" "external-symbol" +;; "symbols" "present-symbols" "external-symbols"] +;; [&or "in" "of"] package-p] + +;; ;; Extensions for Emacs Lisp, including Lucid Emacs. +;; [[&or "frame" "frames" +;; "screen" "screens" +;; "buffer" "buffers"]] + +;; [[&or "window" "windows"] +;; [&or "of" "in"] form] + +;; [[&or "overlay" "overlays" +;; "extent" "extents"] +;; [&or "of" "in"] form +;; &optional [[&or "from" "to"] form]] + +;; [[&or "interval" "intervals"] +;; [&or "in" "of"] form +;; &optional [[&or "from" "to"] form] +;; ["property" form]] + +;; [[&or "key-code" "key-codes" +;; "key-seq" "key-seqs" +;; "key-binding" "key-bindings"] +;; [&or "in" "of"] form +;; &optional ["using" ([&or "key-code" "key-codes" +;; "key-seq" "key-seqs" +;; "key-binding" "key-bindings"] +;; sexp)]] +;; ;; For arbitrary extensions, recognize anything else. +;; [symbolp &rest &or symbolp form] +;; ] + +;; ;; arithmetic - must be last since all parts are optional. +;; [[&optional [[&or "from" "downfrom" "upfrom"] form]] +;; [&optional [[&or "to" "downto" "upto" "below" "above"] form]] +;; [&optional ["by" form]] +;; ])) + +;; (def-edebug-spec loop-initial-final +;; (&or ["initially" +;; ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this. +;; &rest loop-non-atomic-expr] +;; ["finally" &or +;; [[&optional &or "do" "doing"] &rest loop-non-atomic-expr] +;; ["return" form]])) + +;; (def-edebug-spec loop-and-clause +;; (loop-clause &rest ["and" loop-clause])) + +;; (def-edebug-spec loop-clause +;; (&or +;; [[&or "while" "until" "always" "never" "thereis"] form] + +;; [[&or "collect" "collecting" +;; "append" "appending" +;; "nconc" "nconcing" +;; "concat" "vconcat"] form +;; [&optional ["into" loop-var]]] + +;; [[&or "count" "counting" +;; "sum" "summing" +;; "maximize" "maximizing" +;; "minimize" "minimizing"] form +;; [&optional ["into" loop-var]] +;; loop-type-spec] + +;; [[&or "if" "when" "unless"] +;; form loop-and-clause +;; [&optional ["else" loop-and-clause]] +;; [&optional "end"]] + +;; [[&or "do" "doing"] &rest loop-non-atomic-expr] + +;; ["return" form] +;; loop-initial-final +;; )) + +;; (def-edebug-spec loop-non-atomic-expr +;; ([¬ atom] form)) + +;; (def-edebug-spec loop-var +;; ;; The symbolp must be last alternative to recognize e.g. (a b . c) +;; ;; loop-var => +;; ;; (loop-var . [&or nil loop-var]) +;; ;; (symbolp . [&or nil loop-var]) +;; ;; (symbolp . loop-var) +;; ;; (symbolp . (symbolp . [&or nil loop-var])) +;; ;; (symbolp . (symbolp . loop-var)) +;; ;; (symbolp . (symbolp . symbolp)) == (symbolp symbolp . symbolp) +;; (&or (loop-var . [&or nil loop-var]) [gate symbolp])) + +;; (def-edebug-spec loop-type-spec +;; (&optional ["of-type" loop-d-type-spec])) + +;; (def-edebug-spec loop-d-type-spec +;; (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) + + + (defun cl-parse-loop-clause () ; uses loop-* (let ((word (pop loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) @@ -1227,6 +1485,11 @@ Valid clauses are: "The Common Lisp `do' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" + (declare (indent 2) + (debug + ((&rest &or symbolp (symbolp &optional form form)) + (form body) + cl-declarations body))) (cl-expand-do-loop steps endtest body nil)) ;;;###autoload @@ -1234,6 +1497,7 @@ Valid clauses are: "The Common Lisp `do*' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" + (declare (indent 2) (debug do)) (cl-expand-do-loop steps endtest body t)) (defun cl-expand-do-loop (steps endtest body star) @@ -1265,6 +1529,7 @@ Then evaluate RESULT to get return value, default nil. An implicit nil block is established around the loop. \(fn (VAR LIST [RESULT]) BODY...)" + (declare (debug ((symbolp form &optional form) cl-declarations body))) (let ((temp (make-symbol "--cl-dolist-temp--"))) ;; FIXME: Copy&pasted from subr.el. `(block nil @@ -1298,6 +1563,7 @@ to COUNT, exclusive. Then evaluate RESULT to get return value, default nil. \(fn (VAR COUNT [RESULT]) BODY...)" + (declare (debug dolist)) (let ((temp (make-symbol "--cl-dotimes-temp--")) (end (nth 1 spec))) ;; FIXME: Copy&pasted from subr.el. @@ -1330,6 +1596,8 @@ Evaluate BODY with VAR bound to each interned symbol, or to each symbol from OBARRAY. \(fn (VAR [OBARRAY [RESULT]]) BODY...)" + (declare (indent 1) + (debug ((symbolp &optional form form) cl-declarations body))) ;; Apparently this doesn't have an implicit block. (list 'block nil (list 'let (list (car spec)) @@ -1340,6 +1608,7 @@ from OBARRAY. ;;;###autoload (defmacro do-all-symbols (spec &rest body) + (declare (indent 1) (debug ((symbolp &optional form) cl-declarations body))) (list* 'do-symbols (list (car spec) nil (cadr spec)) body)) @@ -1352,6 +1621,7 @@ This is like `setq', except that all VAL forms are evaluated (in order) before assigning any symbols SYM to the corresponding values. \(fn SYM VAL SYM VAL ...)" + (declare (debug setq)) (cons 'psetf args)) @@ -1365,6 +1635,7 @@ Each symbol in the first list is bound to the corresponding value in the second list (or made unbound if VALUES is shorter than SYMBOLS); then the BODY forms are executed and their result is returned. This is much like a `let' form, except that the list of symbols can be computed at run-time." + (declare (indent 2) (debug (form form body))) (list 'let '((cl-progv-save nil)) (list 'unwind-protect (list* 'progn (list 'cl-progv-before symbols values) body) @@ -1380,6 +1651,7 @@ function definitions in place, then the definitions are undone (the FUNCs go back to their previous definitions, or lack thereof). \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" + (declare (indent 1) (debug ((&rest (defun*)) cl-declarations body))) (list* 'letf* (mapcar (function @@ -1412,6 +1684,7 @@ This is like `flet', except the bindings are lexical instead of dynamic. Unlike `flet', this macro is fully compliant with the Common Lisp standard. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" + (declare (indent 1) (debug flet)) (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) (while bindings ;; Use `gensym' rather than `make-symbol'. It's important that @@ -1436,6 +1709,11 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard. This is like `flet', but for macros instead of functions. \(fn ((NAME ARGLIST BODY...) ...) FORM...)" + (declare (indent 1) + (debug + ((&rest (&define name (&rest arg) cl-declarations-or-string + def-body)) + cl-declarations body))) (if (cdr bindings) (list 'macrolet (list (car bindings)) (list* 'macrolet (cdr bindings) body)) @@ -1454,6 +1732,7 @@ Within the body FORMs, references to the variable NAME will be replaced by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). \(fn ((NAME EXPANSION) ...) FORM...)" + (declare (indent 1) (debug ((&rest (symbol sexp)) cl-declarations body))) (if (cdr bindings) (list 'symbol-macrolet (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body)) @@ -1470,6 +1749,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). The main visible difference is that lambdas inside BODY will create lexical closures as in Common Lisp. \n(fn BINDINGS BODY)" + (declare (indent 1) (debug let)) (let* ((cl-closure-vars cl-closure-vars) (vars (mapcar (function (lambda (x) @@ -1484,18 +1764,24 @@ lexical closures as in Common Lisp. (cons 'progn body) (nconc (mapcar (function (lambda (x) (list (symbol-name (car x)) - (list 'symbol-value (caddr x)) + (list 'symbol-value (caddr x)) t))) vars) (list '(defun . cl-defun-expander)) cl-macro-environment)))) (if (not (get (car (last cl-closure-vars)) 'used)) - (list 'let (mapcar (function (lambda (x) - (list (caddr x) (cadr x)))) vars) - (sublis (mapcar (function (lambda (x) - (cons (caddr x) - (list 'quote (caddr x))))) - vars) - ebody)) + ;; Turn (let ((foo (gensym))) (set foo <val>) ...(symbol-value foo)...) + ;; into (let ((foo <val>)) ...(symbol-value 'foo)...). + ;; This is good because it's more efficient but it only works with + ;; dynamic scoping, since with lexical scoping we'd need + ;; (let ((foo <val>)) ...foo...). + `(progn + ,@(mapcar (lambda (x) `(defvar ,(caddr x))) vars) + (let ,(mapcar (lambda (x) (list (caddr x) (cadr x))) vars) + ,(sublis (mapcar (lambda (x) + (cons (caddr x) + (list 'quote (caddr x)))) + vars) + ebody))) (list 'let (mapcar (function (lambda (x) (list (caddr x) (list 'make-symbol @@ -1516,6 +1802,7 @@ successive bindings within BINDINGS, will create lexical closures as in Common Lisp. This is similar to the behavior of `let*' in Common Lisp. \n(fn BINDINGS BODY)" + (declare (indent 1) (debug let)) (if (null bindings) (cons 'progn body) (setq bindings (reverse bindings)) (while bindings @@ -1541,6 +1828,7 @@ simulate true multiple return values. For compatibility, (values A B C) is a synonym for (list A B C). \(fn (SYM...) FORM BODY)" + (declare (indent 2) (debug ((&rest symbolp) form body))) (let ((temp (make-symbol "--cl-var--")) (n -1)) (list* 'let* (cons (list temp form) (mapcar (function @@ -1558,6 +1846,7 @@ each of the symbols SYM in turn. This is analogous to the Common Lisp values. For compatibility, (values A B C) is a synonym for (list A B C). \(fn (SYM...) FORM)" + (declare (indent 1) (debug ((&rest symbolp) form))) (cond ((null vars) (list 'progn form nil)) ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) (t @@ -1577,9 +1866,13 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). ;;; Declarations. ;;;###autoload -(defmacro locally (&rest body) (cons 'progn body)) +(defmacro locally (&rest body) + (declare (debug t)) + (cons 'progn body)) ;;;###autoload -(defmacro the (type form) form) +(defmacro the (type form) + (declare (indent 1) (debug (cl-type-spec form))) + form) (defvar cl-proclaim-history t) ; for future compilers (defvar cl-declare-stack t) ; for future compilers @@ -1659,6 +1952,8 @@ list, a store-variables list (of length one), a store-form, and an access- form. See `defsetf' for a simpler way to define most setf-methods. \(fn NAME ARGLIST BODY...)" + (declare (debug + (&define name cl-lambda-list cl-declarations-or-string def-body))) (append '(eval-when (compile load eval)) (if (stringp (car body)) (list (list 'put (list 'quote func) '(quote setf-documentation) @@ -1688,6 +1983,11 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v)) \(fn NAME [FUNC | ARGLIST (STORE) BODY...])" + (declare (debug + (&define name + [&or [symbolp &optional stringp] + [cl-lambda-list (symbolp)]] + cl-declarations-or-string def-body))) (if (and (listp arg1) (consp args)) (let* ((largs nil) (largsr nil) (temps nil) (tempsr nil) @@ -2026,6 +2326,7 @@ For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y). The return value is the last VAL in the list. \(fn PLACE VAL PLACE VAL ...)" + (declare (debug (&rest [place form]))) (if (cdr (cdr args)) (let ((sets nil)) (while args (push (list 'setf (pop args) (pop args)) sets)) @@ -2043,6 +2344,7 @@ This is like `setf', except that all VAL forms are evaluated (in order) before assigning any PLACEs to the corresponding values. \(fn PLACE VAL PLACE VAL ...)" + (declare (debug setf)) (let ((p args) (simple t) (vars nil)) (while p (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars)) @@ -2078,6 +2380,7 @@ before assigning any PLACEs to the corresponding values. "Remove TAG from property list PLACE. PLACE may be a symbol, or any generalized variable allowed by `setf'. The form returns true if TAG was found and removed, nil otherwise." + (declare (debug (place form))) (let* ((method (cl-setf-do-modify place t)) (tag-temp (and (not (cl-const-expr-p tag)) (make-symbol "--cl-remf-tag--"))) (val-temp (and (not (cl-simple-expr-p place)) @@ -2101,6 +2404,7 @@ Example: (shiftf A B C) sets A to B, B to C, and returns the old A. Each PLACE may be a symbol, or any generalized variable allowed by `setf'. \(fn PLACE... VAL)" + (declare (debug (&rest place))) (cond ((null args) place) ((symbolp place) `(prog1 ,place (setq ,place (shiftf ,@args)))) @@ -2117,6 +2421,7 @@ Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. Each PLACE may be a symbol, or any generalized variable allowed by `setf'. \(fn PLACE...)" + (declare (debug (&rest place))) (if (not (memq nil (mapcar 'symbolp args))) (and (cdr args) (let ((sets nil) @@ -2148,6 +2453,7 @@ As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', the PLACE is not modified before executing BODY. \(fn ((PLACE VALUE) ...) BODY...)" + (declare (indent 1) (debug ((&rest (gate place &optional form)) body))) (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) (list* 'let bindings body) (let ((lets nil) (sets nil) @@ -2205,6 +2511,7 @@ As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', the PLACE is not modified before executing BODY. \(fn ((PLACE VALUE) ...) BODY...)" + (declare (indent 1) (debug letf)) (if (null bindings) (cons 'progn body) (setq bindings (reverse bindings)) @@ -2219,6 +2526,7 @@ FUNC should be an unquoted function name. PLACE may be a symbol, or any generalized variable allowed by `setf'. \(fn FUNC PLACE ARGS...)" + (declare (indent 2) (debug (function* place &rest form))) (let* ((method (cl-setf-do-modify place (cons 'list args))) (rargs (cons (nth 2 method) args))) (list 'let* (car method) @@ -2233,6 +2541,7 @@ or any generalized variable allowed by `setf'. Like `callf', but PLACE is the second argument of FUNC, not the first. \(fn FUNC ARG1 PLACE ARGS...)" + (declare (indent 3) (debug (function* form place &rest form))) (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func)) (list 'setf place (list* func arg1 place args)) (let* ((method (cl-setf-do-modify place (cons 'list args))) @@ -2249,6 +2558,9 @@ Like `callf', but PLACE is the second argument of FUNC, not the first. "Define a `setf'-like modify macro. If NAME is called, it combines its PLACE argument with the other arguments from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" + (declare (debug + (&define name cl-lambda-list ;; should exclude &key + symbolp &optional stringp))) (if (memq '&key arglist) (error "&key not allowed in define-modify-macro")) (let ((place (make-symbol "--cl-place--"))) (list 'defmacro* name (cons place arglist) doc @@ -2277,6 +2589,26 @@ one keyword is supported, `:read-only'. If this has a non-nil value, that slot cannot be set via `setf'. \(fn NAME SLOTS...)" + (declare (doc-string 2) + (debug + (&define ;Makes top-level form not be wrapped. + [&or symbolp + (gate + symbolp &rest + (&or [":conc-name" symbolp] + [":constructor" symbolp &optional cl-lambda-list] + [":copier" symbolp] + [":predicate" symbolp] + [":include" symbolp &rest sexp] ;; Not finished. + ;; The following are not supported. + ;; [":print-function" ...] + ;; [":type" ...] + ;; [":initial-offset" ...] + ))] + [&optional stringp] + ;; All the above is for the following def-form. + &rest &or symbolp (symbolp def-form + &optional ":read-only" sexp)))) (let* ((name (if (consp struct) (car struct) struct)) (opts (cdr-safe struct)) (slots nil) @@ -2525,6 +2857,7 @@ value, that slot cannot be set via `setf'. (defmacro deftype (name arglist &rest body) "Define NAME as a new data type. The type name can then be used in `typecase', `check-type', etc." + (declare (debug defmacro*) (doc-string 3)) (list 'eval-when '(compile load eval) (cl-transform-function-property name 'cl-deftype-handler (cons (list* '&cl-defs ''('*) arglist) body)))) @@ -2576,6 +2909,7 @@ TYPE is a Common Lisp-style type specifier." (defmacro check-type (form type &optional string) "Verify that FORM is of type TYPE; signal an error if not. STRING is an optional description of the desired type." + (declare (debug (place cl-type-spec &optional stringp))) (and (or (not (cl-compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) (let* ((temp (if (cl-simple-expr-p form 3) @@ -2594,6 +2928,7 @@ Second arg SHOW-ARGS means to include arguments of FORM in message. Other args STRING and ARGS... are arguments to be passed to `error'. They are not evaluated unless the assertion fails. If STRING is omitted, a default message listing FORM itself is used." + (declare (debug (form &rest form))) (and (or (not (cl-compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) (let ((sargs (and show-args @@ -2624,6 +2959,7 @@ compiler macros are expanded repeatedly until no further expansions are possible. Unlike regular macros, BODY can decide to \"punt\" and leave the original function call alone by declaring an initial `&whole foo' parameter and then returning foo." + (declare (debug defmacro*)) (let ((p args) (res nil)) (while (consp p) (push (pop p) res)) (setq args (nconc (nreverse res) (and p (list '&rest p))))) @@ -2698,6 +3034,7 @@ ARGLIST allows full Common Lisp conventions, and BODY is implicitly surrounded by (block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug defun*)) (let* ((argns (cl-arglist-args args)) (p argns) (pbody (cons 'progn body)) (unsafe (not (cl-safe-expr-p pbody)))) diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index f1890fbccf6..233f0c83a6e 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -213,8 +213,8 @@ to avoid corrupting the original SEQ. (if (<= (or cl-count (setq cl-count 8000000)) 0) cl-seq (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000))) - (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end - cl-from-end))) + (let ((cl-i (cl--position cl-item cl-seq cl-start cl-end + cl-from-end))) (if cl-i (let ((cl-res (apply 'delete* cl-item (append cl-seq nil) (append (if cl-from-end @@ -279,8 +279,8 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (if (and cl-from-end (< cl-count 4000000)) (let (cl-i) (while (and (>= (setq cl-count (1- cl-count)) 0) - (setq cl-i (cl-position cl-item cl-seq cl-start - cl-end cl-from-end))) + (setq cl-i (cl--position cl-item cl-seq cl-start + cl-end cl-from-end))) (if (= cl-i 0) (setq cl-seq (cdr cl-seq)) (let ((cl-tail (nthcdr (1- cl-i) cl-seq))) (setcdr cl-tail (cdr (cdr cl-tail))))) @@ -330,16 +330,16 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. "Return a copy of SEQ with all duplicate elements removed. \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn SEQ [KEYWORD VALUE]...)" - (cl-delete-duplicates cl-seq cl-keys t)) + (cl--delete-duplicates cl-seq cl-keys t)) ;;;###autoload (defun delete-duplicates (cl-seq &rest cl-keys) "Remove all duplicate elements from SEQ (destructively). \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn SEQ [KEYWORD VALUE]...)" - (cl-delete-duplicates cl-seq cl-keys nil)) + (cl--delete-duplicates cl-seq cl-keys nil)) -(defun cl-delete-duplicates (cl-seq cl-keys cl-copy) +(defun cl--delete-duplicates (cl-seq cl-keys cl-copy) (if (listp cl-seq) (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) () @@ -348,8 +348,8 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) (while (> cl-end 1) (setq cl-i 0) - (while (setq cl-i (cl-position (cl-check-key (car cl-p)) - (cdr cl-p) cl-i (1- cl-end))) + (while (setq cl-i (cl--position (cl-check-key (car cl-p)) + (cdr cl-p) cl-i (1- cl-end))) (if cl-copy (setq cl-seq (copy-sequence cl-seq) cl-p (nthcdr cl-start cl-seq) cl-copy nil)) (let ((cl-tail (nthcdr cl-i cl-p))) @@ -360,14 +360,14 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. cl-seq) (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1) - (cl-position (cl-check-key (car cl-seq)) - (cdr cl-seq) 0 (1- cl-end))) + (cl--position (cl-check-key (car cl-seq)) + (cdr cl-seq) 0 (1- cl-end))) (setq cl-seq (cdr cl-seq) cl-end (1- cl-end))) (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq) (setq cl-end (1- cl-end) cl-start 1) cl-seq))) (while (and (cdr (cdr cl-p)) (> cl-end 1)) - (if (cl-position (cl-check-key (car (cdr cl-p))) - (cdr (cdr cl-p)) 0 (1- cl-end)) + (if (cl--position (cl-check-key (car (cdr cl-p))) + (cdr (cdr cl-p)) 0 (1- cl-end)) (progn (if cl-copy (setq cl-seq (copy-sequence cl-seq) cl-p (nthcdr (1- cl-start) cl-seq) @@ -376,7 +376,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. (setq cl-p (cdr cl-p))) (setq cl-end (1- cl-end) cl-start (1+ cl-start))) cl-seq))) - (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil))) + (let ((cl-res (cl--delete-duplicates (append cl-seq nil) cl-keys nil))) (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))) ;;;###autoload @@ -391,7 +391,7 @@ to avoid corrupting the original SEQ. (if (or (eq cl-old cl-new) (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0)) cl-seq - (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end))) + (let ((cl-i (cl--position cl-old cl-seq cl-start cl-end))) (if (not cl-i) cl-seq (setq cl-seq (copy-sequence cl-seq)) @@ -502,9 +502,9 @@ Return the index of the matching item, or nil if not found. \n(fn ITEM SEQ [KEYWORD VALUE]...)" (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end :from-end) () - (cl-position cl-item cl-seq cl-start cl-end cl-from-end))) + (cl--position cl-item cl-seq cl-start cl-end cl-from-end))) -(defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end) +(defun cl--position (cl-item cl-seq cl-start &optional cl-end cl-from-end) (if (listp cl-seq) (let ((cl-p (nthcdr cl-start cl-seq))) (or cl-end (setq cl-end 8000000)) @@ -619,8 +619,8 @@ return nil if there are no matches. (cl-if nil) cl-pos) (setq cl-end2 (- cl-end2 (1- cl-len))) (while (and (< cl-start2 cl-end2) - (setq cl-pos (cl-position cl-first cl-seq2 - cl-start2 cl-end2 cl-from-end)) + (setq cl-pos (cl--position cl-first cl-seq2 + cl-start2 cl-end2 cl-from-end)) (apply 'mismatch cl-seq1 cl-seq2 :start1 (1+ cl-start1) :end1 cl-end1 :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len) @@ -702,7 +702,7 @@ Return the sublist of LIST whose car matches. (apply 'member* nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun cl-adjoin (cl-item cl-list &rest cl-keys) +(defun cl--adjoin (cl-item cl-list &rest cl-keys) (if (cl-parsing-keywords (:key) t (apply 'member* (cl-check-key cl-item) cl-list cl-keys)) cl-list diff --git a/lisp/emacs-lisp/cl-specs.el b/lisp/emacs-lisp/cl-specs.el deleted file mode 100644 index dbadf06944f..00000000000 --- a/lisp/emacs-lisp/cl-specs.el +++ /dev/null @@ -1,471 +0,0 @@ -;;; cl-specs.el --- Edebug specs for cl.el -*- no-byte-compile: t -*- - -;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. -;; Author: Daniel LaLiberte <liberte@holonexus.org> -;; Keywords: lisp, tools, maint -;; Package: emacs - -;; LCD Archive Entry: -;; cl-specs.el|Daniel LaLiberte|liberte@holonexus.org -;; |Edebug specs for cl.el - -;; 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; These specs are to be used with edebug.el version 3.3 or later and -;; cl.el version 2.03 or later, by Dave Gillespie <daveg@synaptics.com>. - -;; This file need not be byte-compiled, but it shouldn't hurt. - -;;; Code: - -(provide 'cl-specs) -;; Do the above provide before the following require. -;; Otherwise if you load this before edebug if cl is already loaded -;; an infinite loading loop would occur. -(require 'edebug) - -;; Blocks - -(def-edebug-spec block (symbolp body)) -(def-edebug-spec return (&optional form)) -(def-edebug-spec return-from (symbolp &optional form)) - -;; Loops - -(def-edebug-spec case (form &rest (sexp body))) -(def-edebug-spec ecase case) -(def-edebug-spec do - ((&rest &or symbolp (symbolp &optional form form)) - (form body) - cl-declarations body)) -(def-edebug-spec do* do) -(def-edebug-spec dolist - ((symbolp form &optional form) cl-declarations body)) -(def-edebug-spec dotimes dolist) -(def-edebug-spec do-symbols - ((symbolp &optional form form) cl-declarations body)) -(def-edebug-spec do-all-symbols - ((symbolp &optional form) cl-declarations body)) - -;; Multiple values - -(def-edebug-spec multiple-value-list (form)) -(def-edebug-spec multiple-value-call (function-form body)) -(def-edebug-spec multiple-value-bind - ((&rest symbolp) form body)) -(def-edebug-spec multiple-value-setq ((&rest symbolp) form)) -(def-edebug-spec multiple-value-prog1 (form body)) - -;; Bindings - -(def-edebug-spec lexical-let let) -(def-edebug-spec lexical-let* let) - -(def-edebug-spec psetq setq) -(def-edebug-spec progv (form form body)) - -(def-edebug-spec flet ((&rest (defun*)) cl-declarations body)) -(def-edebug-spec labels flet) - -(def-edebug-spec macrolet - ((&rest (&define name (&rest arg) cl-declarations-or-string def-body)) - cl-declarations body)) - -(def-edebug-spec symbol-macrolet - ((&rest (symbol sexp)) cl-declarations body)) - -(def-edebug-spec destructuring-bind - (&define cl-macro-list def-form cl-declarations def-body)) - -;; Setf - -(def-edebug-spec setf (&rest [place form])) ;; sexp is not specific enough -(def-edebug-spec psetf setf) - -(def-edebug-spec letf ;; *not* available in Common Lisp - ((&rest (gate place &optional form)) - body)) -(def-edebug-spec letf* letf) - - -(def-edebug-spec defsetf - (&define name - [&or [symbolp &optional stringp] - [cl-lambda-list (symbolp)]] - cl-declarations-or-string def-body)) - -(def-edebug-spec define-setf-method - (&define name cl-lambda-list cl-declarations-or-string def-body)) - -(def-edebug-spec define-modify-macro - (&define name cl-lambda-list ;; should exclude &key - symbolp &optional stringp)) - -(def-edebug-spec callf (function* place &rest form)) -(def-edebug-spec callf2 (function* form place &rest form)) - -;; Other operations on places - -(def-edebug-spec remf (place form)) - -(def-edebug-spec incf (place &optional form)) -(def-edebug-spec decf incf) -(def-edebug-spec push (form place)) ; different for CL -(def-edebug-spec pushnew - (form place &rest - &or [[&or ":test" ":test-not" ":key"] function-form] - [keywordp form])) -(def-edebug-spec pop (place)) ; different for CL - -(def-edebug-spec shiftf (&rest place)) ;; really [&rest place] form -(def-edebug-spec rotatef (&rest place)) - - -;; Functions with function args. These are only useful if the -;; function arg is quoted with ' instead of function. - -(def-edebug-spec some (function-form form &rest form)) -(def-edebug-spec every some) -(def-edebug-spec notany some) -(def-edebug-spec notevery some) - -;; Mapping - -(def-edebug-spec map (form function-form form &rest form)) -(def-edebug-spec maplist (function-form form &rest form)) -(def-edebug-spec mapc maplist) -(def-edebug-spec mapl maplist) -(def-edebug-spec mapcan maplist) -(def-edebug-spec mapcon maplist) - -;; Sequences - -(def-edebug-spec reduce (function-form form &rest form)) - -;; Types and assertions - -(def-edebug-spec cl-type-spec (sexp)) ;; not worth the trouble to specify, yet. - -(def-edebug-spec deftype defmacro*) -(def-edebug-spec check-type (place cl-type-spec &optional stringp)) -;; (def-edebug-spec assert (form &optional form stringp &rest form)) -(def-edebug-spec assert (form &rest form)) -(def-edebug-spec typecase (form &rest ([&or cl-type-spec "otherwise"] body))) -(def-edebug-spec etypecase typecase) - -(def-edebug-spec ignore-errors t) - -;; Time of Evaluation - -(def-edebug-spec eval-when - ((&rest &or "compile" "load" "eval") body)) -(def-edebug-spec load-time-value (form &optional &or "t" "nil")) - -;; Declarations - -(def-edebug-spec cl-decl-spec - ((symbolp &rest sexp))) - -(def-edebug-spec cl-declarations - (&rest ("declare" &rest cl-decl-spec))) - -(def-edebug-spec cl-declarations-or-string - (&or stringp cl-declarations)) - -(def-edebug-spec declaim (&rest cl-decl-spec)) -(def-edebug-spec declare (&rest cl-decl-spec)) ;; probably not needed. -(def-edebug-spec locally (cl-declarations &rest form)) -(def-edebug-spec the (cl-type-spec form)) - -;;====================================================== -;; Lambda things - -(def-edebug-spec cl-lambda-list - (([&rest arg] - [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] - [&optional ["&rest" arg]] - [&optional ["&key" [cl-&key-arg &rest cl-&key-arg] - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - ))) - -(def-edebug-spec cl-&optional-arg - (&or (arg &optional def-form arg) arg)) - -(def-edebug-spec cl-&key-arg - (&or ([&or (symbolp arg) arg] &optional def-form arg) arg)) - -;; The lambda list for macros is different from that of normal lambdas. -;; Note that &environment is only allowed as first or last items in the -;; top level list. - -(def-edebug-spec cl-macro-list - (([&optional "&environment" arg] - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - [&optional "&environment" arg] - ))) - -(def-edebug-spec cl-macro-arg - (&or arg cl-macro-list1)) - -(def-edebug-spec cl-macro-list1 - (([&optional "&whole" arg] ;; only allowed at lower levels - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] - . [&or arg nil]))) - - -(def-edebug-spec defun* - ;; Same as defun but use cl-lambda-list. - (&define [&or name - ("setf" :name setf name)] - cl-lambda-list - cl-declarations-or-string - [&optional ("interactive" interactive)] - def-body)) -(def-edebug-spec defsubst* defun*) - -(def-edebug-spec defmacro* - (&define name cl-macro-list cl-declarations-or-string def-body)) -(def-edebug-spec define-compiler-macro defmacro*) - - -(def-edebug-spec function* - (&or symbolp cl-lambda-expr)) - -(def-edebug-spec cl-lambda-expr - (&define ("lambda" cl-lambda-list - ;;cl-declarations-or-string - ;;[&optional ("interactive" interactive)] - def-body))) - -;; Redefine function-form to also match function* -(def-edebug-spec function-form - ;; form at the end could also handle "function", - ;; but recognize it specially to avoid wrapping function forms. - (&or ([&or "quote" "function"] &or symbolp lambda-expr) - ("function*" function*) - form)) - -;;====================================================== -;; Structures -;; (def-edebug-spec defstruct (&rest sexp)) would be sufficient, but... - -;; defstruct may contain forms that are evaluated when a structure is created. -(def-edebug-spec defstruct - (&define ; makes top-level form not be wrapped - [&or symbolp - (gate - symbolp &rest - (&or [":conc-name" symbolp] - [":constructor" symbolp &optional cl-lambda-list] - [":copier" symbolp] - [":predicate" symbolp] - [":include" symbolp &rest sexp];; not finished - ;; The following are not supported. - ;; [":print-function" ...] - ;; [":type" ...] - ;; [":initial-offset" ...] - ))] - [&optional stringp] - ;; All the above is for the following def-form. - &rest &or symbolp (symbolp def-form &optional ":read-only" sexp))) - -;;====================================================== -;; Loop - -;; The loop macro is very complex, and a full spec is found below. -;; The following spec only minimally specifies that -;; parenthesized forms are executable, but single variables used as -;; expressions will be missed. You may want to use this if the full -;; spec causes problems for you. - -(def-edebug-spec loop - (&rest &or symbolp form)) - -;; Below is a complete spec for loop, in several parts that correspond -;; to the syntax given in CLtL2. The specs do more than specify where -;; the forms are; it also specifies, as much as Edebug allows, all the -;; syntactically valid loop clauses. The disadvantage of this -;; completeness is rigidity, but the "for ... being" clause allows -;; arbitrary extensions of the form: [symbolp &rest &or symbolp form]. - -(def-edebug-spec loop - ([&optional ["named" symbolp]] - [&rest - &or - ["repeat" form] - loop-for-as - loop-with - loop-initial-final] - [&rest loop-clause] - )) - -(def-edebug-spec loop-with - ("with" loop-var - loop-type-spec - [&optional ["=" form]] - &rest ["and" loop-var - loop-type-spec - [&optional ["=" form]]])) - -(def-edebug-spec loop-for-as - ([&or "for" "as"] loop-for-as-subclause - &rest ["and" loop-for-as-subclause])) - -(def-edebug-spec loop-for-as-subclause - (loop-var - loop-type-spec - &or - [[&or "in" "on" "in-ref" "across-ref"] - form &optional ["by" function-form]] - - ["=" form &optional ["then" form]] - ["across" form] - ["being" - [&or "the" "each"] - &or - [[&or "element" "elements"] - [&or "of" "in" "of-ref"] form - &optional "using" ["index" symbolp]];; is this right? - [[&or "hash-key" "hash-keys" - "hash-value" "hash-values"] - [&or "of" "in"] - hash-table-p &optional ["using" ([&or "hash-value" "hash-values" - "hash-key" "hash-keys"] sexp)]] - - [[&or "symbol" "present-symbol" "external-symbol" - "symbols" "present-symbols" "external-symbols"] - [&or "in" "of"] package-p] - - ;; Extensions for Emacs Lisp, including Lucid Emacs. - [[&or "frame" "frames" - "screen" "screens" - "buffer" "buffers"]] - - [[&or "window" "windows"] - [&or "of" "in"] form] - - [[&or "overlay" "overlays" - "extent" "extents"] - [&or "of" "in"] form - &optional [[&or "from" "to"] form]] - - [[&or "interval" "intervals"] - [&or "in" "of"] form - &optional [[&or "from" "to"] form] - ["property" form]] - - [[&or "key-code" "key-codes" - "key-seq" "key-seqs" - "key-binding" "key-bindings"] - [&or "in" "of"] form - &optional ["using" ([&or "key-code" "key-codes" - "key-seq" "key-seqs" - "key-binding" "key-bindings"] - sexp)]] - ;; For arbitrary extensions, recognize anything else. - [symbolp &rest &or symbolp form] - ] - - ;; arithmetic - must be last since all parts are optional. - [[&optional [[&or "from" "downfrom" "upfrom"] form]] - [&optional [[&or "to" "downto" "upto" "below" "above"] form]] - [&optional ["by" form]] - ])) - -(def-edebug-spec loop-initial-final - (&or ["initially" - ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this. - &rest loop-non-atomic-expr] - ["finally" &or - [[&optional &or "do" "doing"] &rest loop-non-atomic-expr] - ["return" form]])) - -(def-edebug-spec loop-and-clause - (loop-clause &rest ["and" loop-clause])) - -(def-edebug-spec loop-clause - (&or - [[&or "while" "until" "always" "never" "thereis"] form] - - [[&or "collect" "collecting" - "append" "appending" - "nconc" "nconcing" - "concat" "vconcat"] form - [&optional ["into" loop-var]]] - - [[&or "count" "counting" - "sum" "summing" - "maximize" "maximizing" - "minimize" "minimizing"] form - [&optional ["into" loop-var]] - loop-type-spec] - - [[&or "if" "when" "unless"] - form loop-and-clause - [&optional ["else" loop-and-clause]] - [&optional "end"]] - - [[&or "do" "doing"] &rest loop-non-atomic-expr] - - ["return" form] - loop-initial-final - )) - -(def-edebug-spec loop-non-atomic-expr - ([¬ atom] form)) - -(def-edebug-spec loop-var - ;; The symbolp must be last alternative to recognize e.g. (a b . c) - ;; loop-var => - ;; (loop-var . [&or nil loop-var]) - ;; (symbolp . [&or nil loop-var]) - ;; (symbolp . loop-var) - ;; (symbolp . (symbolp . [&or nil loop-var])) - ;; (symbolp . (symbolp . loop-var)) - ;; (symbolp . (symbolp . symbolp)) == (symbolp symbolp . symbolp) - (&or (loop-var . [&or nil loop-var]) [gate symbolp])) - -(def-edebug-spec loop-type-spec - (&optional ["of-type" loop-d-type-spec])) - -(def-edebug-spec loop-d-type-spec - (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) - -;;; cl-specs.el ends here diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 971024fcbba..137dd1bfb84 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -120,6 +120,7 @@ a future Emacs interpreter will be able to use it.") "Increment PLACE by X (1 by default). PLACE may be a symbol, or any generalized variable allowed by `setf'. The return value is the incremented value of PLACE." + (declare (debug (place &optional form))) (if (symbolp place) (list 'setq place (if x (list '+ place x) (list '1+ place))) (list 'callf '+ place (or x 1)))) @@ -128,6 +129,7 @@ The return value is the incremented value of PLACE." "Decrement PLACE by X (1 by default). PLACE may be a symbol, or any generalized variable allowed by `setf'. The return value is the decremented value of PLACE." + (declare (debug incf)) (if (symbolp place) (list 'setq place (if x (list '- place x) (list '1- place))) (list 'callf '- place (or x 1)))) @@ -140,6 +142,7 @@ The return value is the decremented value of PLACE." Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more careful about evaluating each argument only once and in the right order. PLACE may be a symbol, or any generalized variable allowed by `setf'." + (declare (debug (place))) (if (symbolp place) (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))) (cl-do-pop place))) @@ -149,6 +152,7 @@ PLACE may be a symbol, or any generalized variable allowed by `setf'." Analogous to (setf PLACE (cons X PLACE)), though more careful about evaluating each argument only once and in the right order. PLACE may be a symbol, or any generalized variable allowed by `setf'." + (declare (debug (form place))) (if (symbolp place) (list 'setq place (list 'cons x place)) (list 'callf2 'cons x place))) @@ -158,6 +162,10 @@ Like (push X PLACE), except that the list is unmodified if X is `eql' to an element already on the list. \nKeywords supported: :test :test-not :key \n(fn X PLACE [KEYWORD VALUE]...)" + (declare (debug + (form place &rest + &or [[&or ":test" ":test-not" ":key"] function-form] + [keywordp form]))) (if (symbolp place) (if (null keys) `(let ((x ,x)) @@ -304,7 +312,7 @@ definitions to shadow the loaded ones for use in file byte-compilation. (while (>= (decf i) 0) (setq v (+ (* v 3) (aref time i)))) v)) -(defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100)) +(defvar cl--gensym-counter (* (logand (cl-random-time) 1023) 100)) ;;; Numbers. @@ -331,7 +339,7 @@ always returns nil." "Return t if INTEGER is even." (eq (logand integer 1) 0)) -(defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time))) +(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl-random-time))) (defconst most-positive-float nil "The largest value that a Lisp float can hold. @@ -608,7 +616,7 @@ Otherwise, return LIST unmodified. (if (memq cl-item cl-list) cl-list (cons cl-item cl-list))) ((or (equal cl-keys '(:test equal)) (null cl-keys)) (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) - (t (apply 'cl-adjoin cl-item cl-list cl-keys)))) + (t (apply 'cl--adjoin cl-item cl-list cl-keys)))) (defun subst (cl-new cl-old cl-tree &rest cl-keys) "Substitute NEW for OLD everywhere in TREE (non-destructively). @@ -643,47 +651,20 @@ If ALIST is non-nil, the new pairs are prepended to it." ;;; Miscellaneous. -;; Define data for indentation and edebug. -(dolist (entry - '(((defun* defmacro*) 2) - ((function*) nil - (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form))) - ((eval-when) 1 (sexp &rest form)) - ((declare) nil (&rest sexp)) - ((the) 1 (sexp &rest form)) - ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form))) - ((block return-from) 1 (sexp &rest form)) - ((return) nil (&optional form)) - ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form)) - (form &rest form) - &rest form)) - ((do-symbols) 1 ((symbolp form &optional form form) &rest form)) - ((do-all-symbols) 1 ((symbolp form &optional form) &rest form)) - ((psetq setf psetf) nil edebug-setq-form) - ((progv) 2 (&rest form)) - ((flet labels macrolet) 1 - ((&rest (sexp sexp &rest form)) &rest form)) - ((symbol-macrolet lexical-let lexical-let*) 1 - ((&rest &or symbolp (symbolp form)) &rest form)) - ((multiple-value-bind) 2 ((&rest symbolp) &rest form)) - ((multiple-value-setq) 1 ((&rest symbolp) &rest form)) - ((incf decf remf pushnew shiftf rotatef) nil (&rest form)) - ((letf letf*) 1 ((&rest (&rest form)) &rest form)) - ((callf destructuring-bind) 2 (sexp form &rest form)) - ((callf2) 3 (sexp form form &rest form)) - ((loop) nil (&rest &or symbolp form)) - ((ignore-errors) 0 (&rest form)))) - (dolist (func (car entry)) - (put func 'lisp-indent-function (nth 1 entry)) - (put func 'lisp-indent-hook (nth 1 entry)) - (or (get func 'edebug-form-spec) - (put func 'edebug-form-spec (nth 2 entry))))) - ;; Autoload the other portions of the package. ;; We want to replace the basic versions of dolist, dotimes, declare below. (fmakunbound 'dolist) (fmakunbound 'dotimes) (fmakunbound 'declare) +;;;###autoload +(progn + ;; Autoload, so autoload.el and font-lock can use it even when CL + ;; is not loaded. + (put 'defun* 'doc-string-elt 3) + (put 'defmacro* 'doc-string-elt 3) + (put 'defsubst 'doc-string-elt 3) + (put 'defstruct 'doc-string-elt 2)) + (load "cl-loaddefs" nil 'quiet) ;; This goes here so that cl-macs can find it if it loads right now. diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 09b456b54ba..8e96d95c5dd 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -110,7 +110,7 @@ When this is `function', only ask when called non-interactively." ;; This is a defvar rather than a defconst, because the year can ;; change during the Emacs session. -(defvar copyright-current-year (substring (current-time-string) -4) +(defvar copyright-current-year (format-time-string "%Y") "String representing the current year.") (defsubst copyright-limit () ; re-search-forward BOUND @@ -181,8 +181,7 @@ skips to the end of all the years." ;; This uses the match-data from copyright-find-copyright/end. (goto-char (match-end 1)) (copyright-find-end) - ;; Note that `current-time-string' isn't locale-sensitive. - (setq copyright-current-year (substring (current-time-string) -4)) + (setq copyright-current-year (format-time-string "%Y")) (unless (string= (buffer-substring (- (match-end 3) 2) (match-end 3)) (substring copyright-current-year -2)) (if (or noquery @@ -347,7 +346,7 @@ independently replaces consecutive years with a range." "Insert a copyright by $ORGANIZATION notice at cursor." "Company: " comment-start - "Copyright (C) " `(substring (current-time-string) -4) " by " + "Copyright (C) " `(format-time-string "%Y") " by " (or (getenv "ORGANIZATION") str) '(if (copyright-offset-too-large-p) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 0d6716a2e63..d522f07249a 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -142,7 +142,8 @@ For example, you could write (define-minor-mode foo-mode \"If enabled, foo on you!\" :lighter \" Foo\" :require 'foo :global t :group 'hassle :version \"27.5\" ...BODY CODE...)" - (declare (debug (&define name stringp + (declare (doc-string 2) + (debug (&define name stringp [&optional [¬ keywordp] sexp &optional [¬ keywordp] sexp &optional [¬ keywordp] sexp] @@ -228,6 +229,7 @@ For example, you could write (variable nil) ((not globalp) `(progn + :autoload-end (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))) @@ -335,7 +337,7 @@ enabled, then disabling and reenabling MODE should make MODE work correctly with the current major mode. This is important to prevent problems with derived modes, that is, major modes that call another major mode in their body." - + (declare (doc-string 2)) (let* ((global-mode-name (symbol-name global-mode)) (pretty-name (easy-mmode-pretty-mode-name mode)) (pretty-global-name (easy-mmode-pretty-mode-name global-mode)) @@ -365,8 +367,10 @@ call another major mode in their body." "-mode\\'" "" (symbol-name mode)))))) `(progn - (defvar ,MODE-major-mode nil) - (make-variable-buffer-local ',MODE-major-mode) + (progn + :autoload-end + (defvar ,MODE-major-mode nil) + (make-variable-buffer-local ',MODE-major-mode)) ;; The actual global minor-mode (define-minor-mode ,global-mode ;; Very short lines to avoid too long lines in the generated @@ -572,8 +576,6 @@ BODY is executed after moving to the destination location." (when was-narrowed (,narrowfun))))))) (unless name (setq name base-name)) `(progn - (add-to-list 'debug-ignored-errors - ,(concat "^No \\(previous\\|next\\) " (regexp-quote name))) (defun ,next-sym (&optional count) ,(format "Go to the next COUNT'th %s." name) (interactive "p") @@ -584,7 +586,7 @@ BODY is executed after moving to the destination location." `(if (not (re-search-forward ,re nil t count)) (if (looking-at ,re) (goto-char (or ,(if endfun `(,endfun)) (point-max))) - (error "No next %s" ,name)) + (user-error "No next %s" ,name)) (goto-char (match-beginning 0)) (when (and (eq (current-buffer) (window-buffer (selected-window))) (called-interactively-p 'interactive)) @@ -603,7 +605,7 @@ BODY is executed after moving to the destination location." (if (< count 0) (,next-sym (- count)) ,(funcall when-narrowed `(unless (re-search-backward ,re nil t count) - (error "No previous %s" ,name))) + (user-error "No previous %s" ,name))) ,@body)) (put ',prev-sym 'definition-name ',base)))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 67ffd6d5d31..ee5e5d0ff89 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -527,6 +527,7 @@ the minibuffer." (setq face-new-frame-defaults (assq-delete-all (nth 1 form) face-new-frame-defaults)) (put (nth 1 form) 'face-defface-spec nil) + (put (nth 1 form) 'face-documentation (nth 3 form)) ;; See comments in `eval-defun-1' for purpose of code below (setq form (prog1 `(prog1 ,form (put ',(nth 1 form) 'saved-face @@ -1938,7 +1939,6 @@ expressions; a `progn' form will be returned enclosing these forms." ;;;; Edebug Form Specs ;;; ========================================================== -;;; See cl-specs.el for common lisp specs. ;;;;* Spec for def-edebug-spec ;;; Out of date. @@ -2011,12 +2011,6 @@ expressions; a `progn' form will be returned enclosing these forms." ;; A macro is allowed by Emacs. (def-edebug-spec function (&or symbolp lambda-expr)) -;; lambda is a macro in emacs 19. -(def-edebug-spec lambda (&define lambda-list - [&optional stringp] - [&optional ("interactive" interactive)] - def-body)) - ;; A macro expression is a lambda expression with "macro" prepended. (def-edebug-spec macro (&define "lambda" lambda-list def-body)) @@ -3744,7 +3738,7 @@ This prints the value into current buffer." ;; FIXME eh? (defvar gud-inhibit-global-bindings - "*Non-nil means don't do global rebindings of C-x C-a subcommands.") + "Non-nil means don't do global rebindings of C-x C-a subcommands.") ;; Global GUD bindings for all emacs-lisp-mode buffers. (unless gud-inhibit-global-bindings @@ -4437,13 +4431,6 @@ With prefix argument, make it a temporary breakpoint." ;;; Autoloading of Edebug accessories -(if (featurep 'cl) - (add-hook 'edebug-setup-hook - (function (lambda () (require 'cl-specs)))) - ;; The following causes cl-specs to be loaded if you load cl.el. - (add-hook 'cl-load-hook - (function (lambda () (require 'cl-specs))))) - ;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu (if (featurep 'cl-read) (add-hook 'edebug-setup-hook diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 10816aaa43c..a899839f68a 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -72,8 +72,7 @@ Argument CH-PREFIX is another character prefix to display." ;;; CLASS COMPLETION / DOCUMENTATION -;;;###autoload -(defalias 'describe-class 'eieio-describe-class) +;;;###autoload(defalias 'describe-class 'eieio-describe-class) ;;;###autoload (defun eieio-describe-class (class &optional headerfcn) @@ -305,8 +304,7 @@ are not abstract." ;;; METHOD COMPLETION / DOC (defalias 'describe-method 'eieio-describe-generic) -;;;###autoload -(defalias 'describe-generic 'eieio-describe-generic) +;;;###autoload(defalias 'describe-generic 'eieio-describe-generic) (defalias 'eieio-describe-method 'eieio-describe-generic) ;;;###autoload diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index cdf7237b766..768eba58ee1 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -79,7 +79,7 @@ ;; (defvar eieio-hook nil - "*This hook is executed, then cleared each time `defclass' is called.") + "This hook is executed, then cleared each time `defclass' is called.") (defvar eieio-error-unsupported-class-tags nil "Non-nil to throw an error if an encountered tag is unsupported. @@ -87,7 +87,7 @@ This may prevent classes from CLOS applications from being used with EIEIO since EIEIO does not support all CLOS tags.") (defvar eieio-skip-typecheck nil - "*If non-nil, skip all slot typechecking. + "If non-nil, skip all slot typechecking. Set this to t permanently if a program is functioning well to get a small speed increase. This variable is also used internally to handle default setting for optimization purposes.") @@ -2044,7 +2044,7 @@ During executions, the list is first generated, then as each next method is called, the next method is popped off the stack.") (defvar eieio-pre-method-execution-hooks nil - "*Hooks run just before a method is executed. + "Hooks run just before a method is executed. The hook function must accept one argument, the list of forms about to be executed.") @@ -3051,7 +3051,7 @@ Optional argument GROUP is the sub-group of slots to display. ;;;### (autoloads (eieio-help-mode-augmentation-maybee eieio-describe-generic ;;;;;; eieio-describe-constructor eieio-describe-class eieio-browse) -;;;;;; "eieio-opt" "eieio-opt.el" "e2814881441ad23759409687502f0ee1") +;;;;;; "eieio-opt" "eieio-opt.el" "d808328f9c0156ecbd412d77ba8c569e") ;;; Generated autoloads from eieio-opt.el (autoload 'eieio-browse "eieio-opt" "\ @@ -3060,7 +3060,6 @@ If optional ROOT-CLASS, then start with that, otherwise start with variable `eieio-default-superclass'. \(fn &optional ROOT-CLASS)" t nil) - (defalias 'describe-class 'eieio-describe-class) (autoload 'eieio-describe-class "eieio-opt" "\ @@ -3075,7 +3074,6 @@ Describe the constructor function FCN. Uses `eieio-describe-class' to describe the class being constructed. \(fn FCN)" t nil) - (defalias 'describe-generic 'eieio-describe-generic) (autoload 'eieio-describe-generic "eieio-opt" "\ diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index 5b82cd477f9..82e958533e8 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -357,6 +357,8 @@ Returns the forms." (set (make-local-variable 'elint-buffer-env) (elint-init-env elint-buffer-forms)) (if elint-preloaded-env + ;; FIXME: This doesn't do anything! Should we setq the result to + ;; elint-buffer-env? (elint-env-add-env elint-preloaded-env elint-buffer-env)) (set (make-local-variable 'elint-last-env-time) (buffer-modified-tick)) elint-buffer-forms)) diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 257d0528cbc..a7916354c91 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc. ;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Author: Christian Ohler <ohler@gnu.org> +;; Christian Ohler <ohler@gnu.org> ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 9cbe29bf322..ad5e20cb8a4 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1405,7 +1405,7 @@ RESULT must be an `ert-test-result-with-condition'." ;;; Running tests in batch mode. (defvar ert-batch-backtrace-right-margin 70 - "*The maximum line length for printing backtraces in `ert-run-tests-batch'.") + "The maximum line length for printing backtraces in `ert-run-tests-batch'.") ;;;###autoload (defun ert-run-tests-batch (&optional selector) diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el index 4fd87209b38..9e214a9703c 100644 --- a/lisp/emacs-lisp/ewoc.el +++ b/lisp/emacs-lisp/ewoc.el @@ -1,4 +1,4 @@ -;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer +;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer -*- lexical-binding: t -*- ;; Copyright (C) 1991-2012 Free Software Foundation, Inc. @@ -216,10 +216,9 @@ NODE and leaving the new node's start there. Return the new node." (ewoc--adjust m (point) R dll))) (defun ewoc--wrap (func) - (lexical-let ((ewoc--user-pp func)) - (lambda (data) - (funcall ewoc--user-pp data) - (insert "\n")))) + (lambda (data) + (funcall func data) + (insert "\n"))) ;;; =========================================================================== diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index 6667a101865..80b6122822e 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -97,10 +97,11 @@ ;; Internal Variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define-obsolete-variable-alias 'generic-font-lock-defaults + 'generic-font-lock-keywords "22.1") (defvar generic-font-lock-keywords nil "Keywords for `font-lock-defaults' in a generic mode.") (make-variable-buffer-local 'generic-font-lock-keywords) -(define-obsolete-variable-alias 'generic-font-lock-defaults 'generic-font-lock-keywords "22.1") ;;;###autoload (defvar generic-mode-list nil @@ -150,7 +151,8 @@ mode hook `MODE-hook'. See the file generic-x.el for some examples of `define-generic-mode'." (declare (debug (sexp def-form def-form def-form form def-form [&optional stringp] &rest [keywordp form])) - (indent 1)) + (indent 1) + (doc-string 7)) ;; Backward compatibility. (when (eq (car-safe mode) 'quote) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 95eb8c963be..2a4cd704a43 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -135,35 +135,12 @@ It has `lisp-mode-abbrev-table' as its parent." ;; This was originally in autoload.el and is still used there. (put 'autoload 'doc-string-elt 3) -(put 'defun 'doc-string-elt 3) -(put 'defun* 'doc-string-elt 3) (put 'defmethod 'doc-string-elt 3) (put 'defvar 'doc-string-elt 3) -(put 'defcustom 'doc-string-elt 3) -(put 'deftheme 'doc-string-elt 2) -(put 'deftype 'doc-string-elt 3) (put 'defconst 'doc-string-elt 3) -(put 'defmacro 'doc-string-elt 3) -(put 'defmacro* 'doc-string-elt 3) -(put 'defsubst 'doc-string-elt 3) -(put 'defstruct 'doc-string-elt 2) -(put 'define-skeleton 'doc-string-elt 2) -(put 'define-derived-mode 'doc-string-elt 4) -(put 'define-compilation-mode 'doc-string-elt 3) -(put 'easy-mmode-define-minor-mode 'doc-string-elt 2) -(put 'define-minor-mode 'doc-string-elt 2) -(put 'easy-mmode-define-global-mode 'doc-string-elt 2) -(put 'define-global-minor-mode 'doc-string-elt 2) -(put 'define-globalized-minor-mode 'doc-string-elt 2) -(put 'define-generic-mode 'doc-string-elt 7) -(put 'define-ibuffer-filter 'doc-string-elt 2) -(put 'define-ibuffer-op 'doc-string-elt 3) -(put 'define-ibuffer-sorter 'doc-string-elt 2) -(put 'lambda 'doc-string-elt 2) (put 'defalias 'doc-string-elt 3) (put 'defvaralias 'doc-string-elt 3) (put 'define-category 'doc-string-elt 2) -(put 'define-overloadable-function 'doc-string-elt 3) (defvar lisp-doc-string-elt-property 'doc-string-elt "The symbol property that holds the docstring position info.") @@ -850,10 +827,10 @@ Return the result of evaluation." (end-of-defun) (beginning-of-defun) (setq beg (point)) - (setq form (eval-sexp-add-defvars (read (current-buffer)))) + (setq form (read (current-buffer))) (setq end (point))) ;; Alter the form if necessary. - (setq form (eval-defun-1 (macroexpand form))) + (setq form (eval-sexp-add-defvars (eval-defun-1 (macroexpand form)))) (list beg end standard-output `(lambda (ignore) ;; Skipping to the end of the specified region @@ -1233,7 +1210,6 @@ Lisp function does not specify a special indentation." ;; like defun if the first form is placed on the next line, otherwise ;; it is indented like any other form (i.e. forms line up under first). -(put 'lambda 'lisp-indent-function 'defun) (put 'autoload 'lisp-indent-function 'defun) (put 'progn 'lisp-indent-function 0) (put 'prog1 'lisp-indent-function 1) diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 4efdc3240cd..bcb7fab026b 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -447,7 +447,21 @@ Optional ARG is ignored." ;; Try first in this order for the sake of languages with nested ;; functions where several can end at the same place as with ;; the offside rule, e.g. Python. - (beginning-of-defun) + + ;; Finding the start of the function is a bit problematic since + ;; `beginning-of-defun' when we are on the first character of + ;; the function might go to the previous function. + ;; + ;; Therefore we first move one character forward and then call + ;; `beginning-of-defun'. However now we must check that we did + ;; not move into the next function. + (let ((here (point))) + (unless (eolp) + (forward-char)) + (beginning-of-defun) + (when (< (point) here) + (goto-char here) + (beginning-of-defun))) (setq beg (point)) (end-of-defun) (setq end (point)) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 21c351159c2..ba8f9c4c148 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -65,7 +65,7 @@ result will be eq to LIST). (,unshared nil) (,tail ,shared) ,var ,new-el) - (while ,tail + (while (consp ,tail) (setq ,var (car ,tail) ,new-el (progn ,@body)) (unless (eq ,var ,new-el) @@ -128,20 +128,6 @@ Assumes the caller has bound `macroexpand-all-environment'." (cddr form)) (cdr form)) form)) - (`(defmacro ,name . ,args-and-body) - (push (cons name (cons 'lambda args-and-body)) - macroexpand-all-environment) - (let ((n 3)) - ;; Don't macroexpand `declare' since it should really be "expanded" - ;; away when `defmacro' is expanded, but currently defmacro is not - ;; itself a macro. So both `defmacro' and `declare' need to be - ;; handled directly in bytecomp.el. - ;; FIXME: Maybe a simpler solution is to (defalias 'declare 'quote). - (while (or (stringp (nth n form)) - (eq (car-safe (nth n form)) 'declare)) - (setq n (1+ n))) - (macroexpand-all-forms form n))) - (`(defun . ,_) (macroexpand-all-forms form 3)) (`(,(or `defvar `defconst) . ,_) (macroexpand-all-forms form 2)) (`(function ,(and f `(lambda . ,_))) (maybe-cons 'function diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 4ed8aacf0b6..66370c643bf 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -527,7 +527,7 @@ Required package `%s-%s' is unavailable" (defun define-package (name-string version-string &optional docstring requirements - &rest extra-properties) + &rest _extra-properties) "Define a new package. NAME-STRING is the name of the package, as a string. VERSION-STRING is the version of the package, as a string. @@ -587,7 +587,7 @@ EXTRA-PROPERTIES is currently unused." (defun package-generate-autoloads (name pkg-dir) (require 'autoload) ;Load before we let-bind generated-autoload-file! (let* ((auto-name (concat name "-autoloads.el")) - (ignore-name (concat name "-pkg.el")) + ;;(ignore-name (concat name "-pkg.el")) (generated-autoload-file (expand-file-name auto-name pkg-dir)) (version-control 'never)) (unless (fboundp 'autoload-ensure-default-file) @@ -1392,7 +1392,7 @@ If REMEMBER-POS is non-nil, keep point on the same entry. PACKAGES should be t, which means to display all known packages, or a list of package names (symbols) to display." ;; Construct list of ((PACKAGE . VERSION) STATUS DESCRIPTION). - (let (info-list name builtin) + (let (info-list name) ;; Installed packages: (dolist (elt package-alist) (setq name (car elt)) @@ -1477,21 +1477,21 @@ If optional arg BUTTON is non-nil, describe its associated package." (describe-package package)))) ;; fixme numeric argument -(defun package-menu-mark-delete (&optional num) +(defun package-menu-mark-delete (&optional _num) "Mark a package for deletion and move to the next line." (interactive "p") (if (member (package-menu-get-status) '("installed" "obsolete")) (tabulated-list-put-tag "D" t) (forward-line))) -(defun package-menu-mark-install (&optional num) +(defun package-menu-mark-install (&optional _num) "Mark a package for installation and move to the next line." (interactive "p") (if (string-equal (package-menu-get-status) "available") (tabulated-list-put-tag "I" t) (forward-line))) -(defun package-menu-mark-unmark (&optional num) +(defun package-menu-mark-unmark (&optional _num) "Clear any marks on a package and move to the next line." (interactive "p") (tabulated-list-put-tag " " t)) @@ -1533,8 +1533,7 @@ If optional arg BUTTON is non-nil, describe its associated package." (dolist (entry tabulated-list-entries) ;; ENTRY is ((NAME . VERSION) [NAME VERSION STATUS DOC]) (let ((pkg (car entry)) - (status (aref (cadr entry) 2)) - old) + (status (aref (cadr entry) 2))) (cond ((equal status "installed") (push pkg installed)) ((equal status "available") diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index afbc5df85ce..9f98b30adae 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -39,12 +39,15 @@ ;; - along these lines, provide patterns to match CL structs. ;; - provide something like (setq VAR) so a var can be set rather than ;; let-bound. -;; - provide a way to fallthrough to subsequent cases. +;; - provide a way to fallthrough to subsequent cases (not sure what I meant by +;; this :-() ;; - try and be more clever to reduce the size of the decision tree, and ;; to reduce the number of leaves that need to be turned into function: ;; - first, do the tests shared by all remaining branches (it will have -;; to be performed anyway, so better so it first so it's shared). +;; to be performed anyway, so better do it first so it's shared). ;; - then choose the test that discriminates more (?). +;; - provide Agda's `with' (along with its `...' companion). +;; - implement (not UPAT). This might require a significant redesign. ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to ;; generate a lex-style DFA to decide whether to run E1 or E2. @@ -113,7 +116,8 @@ like `(,a . ,(pred (< a))) or, with more checks: "Like `let*' but where you can use `pcase' patterns for bindings. BODY should be an expression, and BINDINGS should be a list of bindings of the form (UPAT EXP)." - (declare (indent 1) (debug let)) + (declare (indent 1) + (debug ((&rest &or (sexp &optional form) symbolp) body))) (cond ((null bindings) (if (> (length body) 1) `(progn ,@body) (car body))) ((pcase--trivial-upat-p (caar bindings)) @@ -132,7 +136,7 @@ of the form (UPAT EXP)." "Like `let' but where you can use `pcase' patterns for bindings. BODY should be a list of expressions, and BINDINGS should be a list of bindings of the form (UPAT EXP)." - (declare (indent 1) (debug let)) + (declare (indent 1) (debug pcase-let*)) (if (null (cdr bindings)) `(pcase-let* ,bindings ,@body) (let ((matches '())) @@ -148,6 +152,7 @@ of the form (UPAT EXP)." `(let ,(nreverse bindings) (pcase-let* ,matches ,@body))))) (defmacro pcase-dolist (spec &rest body) + (declare (indent 1)) (if (pcase--trivial-upat-p (car spec)) `(dolist ,spec ,@body) (let ((tmpvar (make-symbol "x"))) @@ -201,9 +206,12 @@ of the form (UPAT EXP)." (setq vars (delq v vars)) (cdr v))) prevvars))) - (when vars ;New additional vars. - (error "The vars %s are only bound in some paths" - (mapcar #'car vars))) + ;; If some of `vars' were not found in `prevvars', that's + ;; OK it just means those vars aren't present in all + ;; branches, so they can be used within the pattern + ;; (e.g. by a `guard/let/pred') but not in the branch. + ;; FIXME: But if some of `prevvars' are not in `vars' we + ;; should remove them from `prevvars'! `(funcall ,res ,@args))))))) (main (pcase--u @@ -217,9 +225,12 @@ of the form (UPAT EXP)." (cdr case)))) cases)))) (if (null defs) main - `(let ,defs ,main)))) + (pcase--let* defs main)))) (defun pcase-codegen (code vars) + ;; Don't use let*, otherwise pcase--let* may merge it with some surrounding + ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy + ;; codegen from later metamorphosing this let into a funcall. `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) ,@code)) @@ -255,6 +266,13 @@ of the form (UPAT EXP)." ((memq (car-safe then) '(if cond)) (pcase--if `(not ,test) else then)) (t `(if ,test ,then ,else)))) +;; Again, try and reduce nesting. +(defun pcase--let* (binders body) + (if (eq (car-safe body) 'let*) + `(let* ,(append binders (nth 1 body)) + ,@(nthcdr 2 body)) + `(let* ,binders ,body))) + (defun pcase--upat (qpattern) (cond ((eq (car-safe qpattern) '\,) (cadr qpattern)) @@ -433,26 +451,26 @@ MATCH is the pattern that needs to be matched, of the form: (defun pcase--split-pred (upat pat) ;; FIXME: For predicates like (pred (> a)), two such predicates may ;; actually refer to different variables `a'. - (cond - ((equal upat pat) (cons :pcase--succeed :pcase--fail)) - ((and (eq 'pred (car upat)) - (eq 'pred (car-safe pat)) - (or (member (cons (cadr upat) (cadr pat)) - pcase-mutually-exclusive-predicates) - (member (cons (cadr pat) (cadr upat)) - pcase-mutually-exclusive-predicates))) - (cons :pcase--fail nil)) - ;; ((and (eq 'pred (car upat)) - ;; (eq '\` (car-safe pat)) - ;; (symbolp (cadr upat)) - ;; (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat))) - ;; (get (cadr upat) 'side-effect-free) - ;; (progn (message "Trying predicate %S" (cadr upat)) - ;; (ignore-errors - ;; (funcall (cadr upat) (cadr pat))))) - ;; (message "Simplify pred %S against %S" upat pat) - ;; (cons nil :pcase--fail)) - )) + (let (test) + (cond + ((equal upat pat) (cons :pcase--succeed :pcase--fail)) + ((and (eq 'pred (car upat)) + (eq 'pred (car-safe pat)) + (or (member (cons (cadr upat) (cadr pat)) + pcase-mutually-exclusive-predicates) + (member (cons (cadr pat) (cadr upat)) + pcase-mutually-exclusive-predicates))) + (cons :pcase--fail nil)) + ((and (eq 'pred (car upat)) + (eq '\` (car-safe pat)) + (symbolp (cadr upat)) + (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat))) + (get (cadr upat) 'side-effect-free) + (ignore-errors + (setq test (list (funcall (cadr upat) (cadr pat)))))) + (if (car test) + (cons nil :pcase--fail) + (cons :pcase--fail nil)))))) (defun pcase--fgrep (vars sexp) "Check which of the symbols VARS appear in SEXP." @@ -548,7 +566,8 @@ Otherwise, it defers to REST which is a list of branches of the form (let ((newsym (make-symbol "x"))) (push (list newsym sym) env) (setq sym newsym))) - (if (functionp exp) `(,exp ,sym) + (if (functionp exp) + `(funcall #',exp ,sym) `(,@exp ,sym))))) (if (null vs) call @@ -606,6 +625,7 @@ Otherwise, it defers to REST which is a list of branches of the form sym (apply-partially #'pcase--split-member elems) rest)) (then-rest (car splitrest)) (else-rest (cdr splitrest))) + (put sym 'pcase-used t) (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) (pcase--u1 matches code vars then-rest) (pcase--u else-rest))) @@ -673,16 +693,22 @@ Otherwise, it defers to REST which is a list of branches of the form ;; The byte-compiler could do that for us, but it would have to pay ;; attention to the `consp' test in order to figure out that car/cdr ;; can't signal errors and our byte-compiler is not that clever. - `(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) + ;; FIXME: Some of those let bindings occur too early (they are used in + ;; `then-body', but only within some sub-branch). + (pcase--let* + `(,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) - ,then-body) + then-body) (pcase--u else-rest)))) ((or (integerp qpat) (symbolp qpat) (stringp qpat)) (let* ((splitrest (pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest)) (then-rest (car splitrest)) (else-rest (cdr splitrest))) - (pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat) + (pcase--if (cond + ((stringp qpat) `(equal ,sym ,qpat)) + ((null qpat) `(null ,sym)) + (t `(eq ,sym ',qpat))) (pcase--u1 matches code vars then-rest) (pcase--u else-rest)))) (t (error "Unknown QPattern %s" qpat)))) diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index 6d12fe19277..72e3c398dc0 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -136,9 +136,6 @@ This means the number of non-shy regexp grouping constructs ;;; Workhorse functions. -(eval-when-compile - (require 'cl)) - (defun regexp-opt-group (strings &optional paren lax) "Return a regexp to match a string in the sorted list STRINGS. If PAREN non-nil, output regexp parentheses around returned regexp. @@ -248,15 +245,15 @@ Merges keywords to avoid backtracking in Emacs's regexp matcher." ;; ;; Make a character map but extract character set meta characters. (dolist (char chars) - (case char - (?\] - (setq bracket "]")) - (?^ - (setq caret "^")) - (?- - (setq dash "-")) - (otherwise - (aset charmap char t)))) + (cond + ((eq char ?\]) + (setq bracket "]")) + ((eq char ?^) + (setq caret "^")) + ((eq char ?-) + (setq dash "-")) + (t + (aset charmap char t)))) ;; ;; Make a character set from the map using ranges where applicable. (map-char-table @@ -268,14 +265,14 @@ Merges keywords to avoid backtracking in Emacs's regexp matcher." (setq charset (format "%s%c-%c" charset start end)) (while (>= end start) (setq charset (format "%s%c" charset start)) - (incf start))) + (setq start (1+ start)))) (setq start (car c) end (cdr c))) (if (= (1- c) end) (setq end c) (if (> end (+ start 2)) (setq charset (format "%s%c-%c" charset start end)) (while (>= end start) (setq charset (format "%s%c" charset start)) - (incf start))) + (setq start (1+ start)))) (setq start c end c))))) charmap) (when (>= end start) @@ -283,7 +280,7 @@ Merges keywords to avoid backtracking in Emacs's regexp matcher." (setq charset (format "%s%c-%c" charset start end)) (while (>= end start) (setq charset (format "%s%c" charset start)) - (incf start)))) + (setq start (1+ start))))) ;; ;; Make sure a caret is not first and a dash is first or last. (if (and (string-equal charset "") (string-equal bracket "")) diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 2a12f03e514..01274b7ba20 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -688,6 +688,7 @@ Possible return values: 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. + Instead of t, the `car' can also be some other non-nil non-number value. (nil POS TOKEN): we skipped over a paren-like pair. nil: we skipped over an identifier, matched parentheses, ..." (catch 'return @@ -728,7 +729,8 @@ Possible return values: (if (and halfsexp (numberp (funcall op-forw toklevels))) (push toklevels levels) (throw 'return - (prog1 (list (or (car toklevels) t) (point) token) + (prog1 (list (or (funcall op-forw toklevels) t) + (point) token) (goto-char pos))))) (t (let ((lastlevels levels)) @@ -773,7 +775,8 @@ Possible return values: ((and lastlevels (smie--associative-p (car lastlevels))) (throw 'return - (prog1 (list (or (car toklevels) t) (point) token) + (prog1 (list (or (funcall op-forw toklevels) t) + (point) token) (goto-char pos)))) ;; - it's an associative operator within a larger construct ;; (e.g. an "elsif"), so we should just ignore it and keep @@ -793,6 +796,7 @@ Possible return values: 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. + Instead of t, the `car' can also be some other non-nil non-number value. (nil POS TOKEN): we skipped over a paren-like pair. nil: we skipped over an identifier, matched parentheses, ..." (smie-next-sexp @@ -812,7 +816,8 @@ 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. + (t POS TOKEN): same thing but for a close-paren or the end of buffer. + Instead of t, the `car' can also be some other non-nil non-number value. (nil POS TOKEN): we skipped over a paren-like pair. nil: we skipped over an identifier, matched parentheses, ..." (smie-next-sexp @@ -1074,6 +1079,16 @@ the beginning of a line." "Return non-nil if the current token is the first on the line." (save-excursion (skip-chars-backward " \t") (bolp))) +(defun smie-indent--bolp-1 () + ;; Like smie-indent--bolp but also returns non-nil if it's the first + ;; non-comment token. Maybe we should simply always use this? + "Return non-nil if the current token is the first on the line. +Comments are treated as spaces." + (let ((bol (line-beginning-position))) + (save-excursion + (forward-comment (- (point))) + (<= (point) bol)))) + ;; Dynamically scoped. (defvar smie--parent) (defvar smie--after) (defvar smie--token) @@ -1350,9 +1365,12 @@ should not be computed on the basis of the following token." ;; - middle-of-line: "trust current position". (cond ((smie-indent--rule :before token)) - ((smie-indent--bolp) ;I.e. non-virtual indent. + ((smie-indent--bolp-1) ;I.e. non-virtual indent. ;; For an open-paren-like thingy at BOL, always indent only ;; based on other rules (typically smie-indent-after-keyword). + ;; FIXME: we do the same if after a comment, since we may be trying + ;; to compute the indentation of this comment and we shouldn't indent + ;; based on the indentation of subsequent code. nil) (t ;; By default use point unless we're hanging. @@ -1453,6 +1471,12 @@ should not be computed on the basis of the following token." (save-excursion (forward-comment (point-max)) (skip-chars-forward " \t\r\n") + ;; FIXME: We assume here that smie-indent-calculate will compute the + ;; indentation of the next token based on text before the comment, but + ;; this is not guaranteed, so maybe we should let + ;; smie-indent-calculate return some info about which buffer position + ;; was used as the "indentation base" and check that this base is + ;; before `pos'. (smie-indent-calculate)))) (defun smie-indent-comment-continue () @@ -1602,6 +1626,36 @@ 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-auto-fill () + (let ((fc (current-fill-column))) + (while (and fc (> (current-column) fc)) + (cond + ((not (or (nth 8 (save-excursion + (syntax-ppss (line-beginning-position)))) + (nth 8 (syntax-ppss)))) + (save-excursion + (beginning-of-line) + (smie-indent-forward-token) + (let ((bsf (point)) + (gain 0) + curcol) + (while (<= (setq curcol (current-column)) fc) + ;; FIXME? `smie-indent-calculate' can (and often will) + ;; return a result that actually depends on the presence/absence + ;; of a newline, so the gain computed here may not be accurate, + ;; but in practice it seems to works well enough. + (let* ((newcol (smie-indent-calculate)) + (newgain (- curcol newcol))) + (when (> newgain gain) + (setq gain newgain) + (setq bsf (point)))) + (smie-indent-forward-token)) + (when (> gain 0) + (goto-char bsf) + (newline-and-indent))))) + (t (do-auto-fill)))))) + + (defun smie-setup (grammar rules-function &rest keywords) "Setup SMIE navigation and indentation. GRAMMAR is a grammar table generated by `smie-prec2->grammar'. @@ -1612,6 +1666,7 @@ KEYWORDS are additional arguments, which can use the following keywords: (set (make-local-variable 'smie-rules-function) rules-function) (set (make-local-variable 'smie-grammar) grammar) (set (make-local-variable 'indent-line-function) 'smie-indent-line) + (set (make-local-variable 'normal-auto-fill-function) 'smie-auto-fill) (set (make-local-variable 'forward-sexp-function) 'smie-forward-sexp-command) (while keywords diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index 611a766922a..583d0b151c9 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -1,4 +1,4 @@ -;;; syntax.el --- helper functions to find syntactic context +;;; syntax.el --- helper functions to find syntactic context -*- lexical-binding: t -*- ;; Copyright (C) 2000-2012 Free Software Foundation, Inc. @@ -274,13 +274,12 @@ Note: back-references in REGEXPs do not work." "Propertize for syntax in START..END using font-lock syntax. KEYWORDS obeys the format used in `font-lock-syntactic-keywords'. The return value is a function suitable for `syntax-propertize-function'." - (lexical-let ((keywords keywords)) - (lambda (start end) - (with-no-warnings - (let ((font-lock-syntactic-keywords keywords)) - (font-lock-fontify-syntactic-keywords-region start end) - ;; In case it was eval'd/compiled. - (setq keywords font-lock-syntactic-keywords)))))) + (lambda (start end) + (with-no-warnings + (let ((font-lock-syntactic-keywords keywords)) + (font-lock-fontify-syntactic-keywords-region start end) + ;; In case it was eval'd/compiled. + (setq keywords font-lock-syntactic-keywords))))) (defun syntax-propertize (pos) "Ensure that syntax-table properties are set until POS." diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 9439fba2b86..a56a7619ea9 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -22,22 +22,31 @@ ;;; Commentary: -;; This file defines `tabulated-list-mode', a generic major mode for displaying -;; lists of tabulated data, intended for other major modes to inherit from. It -;; provides several utility routines, e.g. for pretty-printing lines of -;; tabulated data to fit into the appropriate columns. +;; This file defines Tabulated List mode, a generic major mode for +;; displaying lists of tabulated data, intended for other major modes +;; to inherit from. It provides several utility routines, e.g. for +;; pretty-printing lines of tabulated data to fit into the appropriate +;; columns. ;; For usage information, see the documentation of `tabulated-list-mode'. -;; This package originated from Tom Tromey's Package Menu mode, extended and -;; generalized to be used by other modes. +;; This package originated from Tom Tromey's Package Menu mode, +;; extended and generalized to be used by other modes. ;;; Code: +;; The reason `tabulated-list-format' and other variables are +;; permanent-local is to make it convenient to switch to a different +;; major mode, switch back, and have the original Tabulated List data +;; still valid. See, for example, ebuff-menu.el. + (defvar tabulated-list-format nil "The format of the current Tabulated List mode buffer. -This should be a vector of elements (NAME WIDTH SORT), where: +This should be a vector of elements (NAME WIDTH SORT . PROPS), +where: - NAME is a string describing the column. + This is the label for the column in the header line. + Different columns must have non-`equal' names. - WIDTH is the width to reserve for the column. For the final element, its numerical value is ignored. - SORT specifies how to sort entries by this column. @@ -45,8 +54,18 @@ This should be a vector of elements (NAME WIDTH SORT), where: If t, sort by comparing the string value printed in the column. Otherwise, it should be a predicate function suitable for `sort', accepting arguments with the same form as the elements - of `tabulated-list-entries'.") + of `tabulated-list-entries'. + - PROPS is a plist of additional column properties. + Currently supported properties are: + - `:right-align': if non-nil, the column should be right-aligned. + - `:pad-right': Number of additional padding spaces to the + right of the column (defaults to 1 if omitted).") (make-variable-buffer-local 'tabulated-list-format) +(put 'tabulated-list-format 'permanent-local t) + +(defvar tabulated-list-use-header-line t + "Whether the Tabulated List buffer should use a header line.") +(make-variable-buffer-local 'tabulated-list-use-header-line) (defvar tabulated-list-entries nil "Entries displayed in the current Tabulated List buffer. @@ -67,12 +86,14 @@ where: If `tabulated-list-entries' is a function, it is called with no arguments and must return a list of the above form.") (make-variable-buffer-local 'tabulated-list-entries) +(put 'tabulated-list-entries 'permanent-local t) (defvar tabulated-list-padding 0 "Number of characters preceding each Tabulated List mode entry. By default, lines are padded with spaces, but you can use the function `tabulated-list-put-tag' to change this.") (make-variable-buffer-local 'tabulated-list-padding) +(put 'tabulated-list-padding 'permanent-local t) (defvar tabulated-list-revert-hook nil "Hook run before reverting a Tabulated List buffer. @@ -94,13 +115,20 @@ NAME is a string matching one of the column names in `tabulated-list-format' then specifies how to sort). FLIP, if non-nil, means to invert the resulting sort.") (make-variable-buffer-local 'tabulated-list-sort-key) +(put 'tabulated-list-sort-key 'permanent-local t) -(defun tabulated-list-get-id (&optional pos) - "Obtain the entry ID of the Tabulated List mode entry at POS. -This is an ID object from `tabulated-list-entries', or nil. +(defsubst tabulated-list-get-id (&optional pos) + "Return the entry ID of the Tabulated List entry at POS. +The value is an ID object from `tabulated-list-entries', or nil. POS, if omitted or nil, defaults to point." (get-text-property (or pos (point)) 'tabulated-list-id)) +(defsubst tabulated-list-get-entry (&optional pos) + "Return the Tabulated List entry at POS. +The value is a vector of column descriptors, or nil if there is +no entry at POS. POS, if omitted or nil, defaults to point." + (get-text-property (or pos (point)) 'tabulated-list-entry)) + (defun tabulated-list-put-tag (tag &optional advance) "Put TAG in the padding area of the current line. TAG should be a string, with length <= `tabulated-list-padding'. @@ -111,16 +139,16 @@ If ADVANCE is non-nil, move forward by one line afterwards." (error "Unable to tag the current line")) (save-excursion (beginning-of-line) - (when (get-text-property (point) 'tabulated-list-id) + (when (tabulated-list-get-entry) (let ((beg (point)) (inhibit-read-only t)) (forward-char tabulated-list-padding) (insert-and-inherit - (if (<= (length tag) tabulated-list-padding) - (concat tag - (make-string (- tabulated-list-padding (length tag)) - ?\s)) - (substring tag 0 tabulated-list-padding))) + (let ((width (string-width tag))) + (if (<= width tabulated-list-padding) + (concat tag + (make-string (- tabulated-list-padding width) ?\s)) + (truncate-string-to-width tag tabulated-list-padding)))) (delete-region beg (+ beg tabulated-list-padding))))) (if advance (forward-line))) @@ -130,6 +158,7 @@ If ADVANCE is non-nil, move forward by one line afterwards." (set-keymap-parent map button-buffer-map) (define-key map "n" 'next-line) (define-key map "p" 'previous-line) + (define-key map "S" 'tabulated-list-sort) (define-key map [follow-link] 'mouse-face) (define-key map [mouse-2] 'mouse-select-window) map) @@ -139,6 +168,9 @@ If ADVANCE is non-nil, move forward by one line afterwards." (let ((map (make-sparse-keymap))) (define-key map [header-line mouse-1] 'tabulated-list-col-sort) (define-key map [header-line mouse-2] 'tabulated-list-col-sort) + (define-key map [mouse-1] 'tabulated-list-col-sort) + (define-key map [mouse-2] 'tabulated-list-col-sort) + (define-key map "\C-m" 'tabulated-list-sort) (define-key map [follow-link] 'mouse-face) map) "Local keymap for `tabulated-list-mode' sort buttons.") @@ -152,50 +184,79 @@ If ADVANCE is non-nil, move forward by one line afterwards." table) "The `glyphless-char-display' table in Tabulated List buffers.") +(defvar tabulated-list--header-string nil) +(defvar tabulated-list--header-overlay nil) + (defun tabulated-list-init-header () "Set up header line for the Tabulated List buffer." - (let ((x tabulated-list-padding) + ;; FIXME: Should share code with tabulated-list-print-col! + (let ((x (max tabulated-list-padding 0)) (button-props `(help-echo "Click to sort by column" mouse-face highlight keymap ,tabulated-list-sort-button-map)) (cols nil)) - (if (> tabulated-list-padding 0) - (push (propertize " " 'display `(space :align-to ,x)) cols)) + (push (propertize " " 'display `(space :align-to ,x)) cols) (dotimes (n (length tabulated-list-format)) (let* ((col (aref tabulated-list-format n)) + (label (nth 0 col)) (width (nth 1 col)) - (label (car col))) - (setq x (+ x 1 width)) - (and (<= tabulated-list-padding 0) - (= n 0) - (setq label (concat " " label))) + (props (nthcdr 3 col)) + (pad-right (or (plist-get props :pad-right) 1)) + (right-align (plist-get props :right-align)) + (next-x (+ x pad-right width))) (push (cond ;; An unsortable column - ((not (nth 2 col)) label) + ((not (nth 2 col)) + (propertize label 'tabulated-list-column-name label)) ;; The selected sort column ((equal (car col) (car tabulated-list-sort-key)) (apply 'propertize (concat label (cond - ((> (+ 2 (length label)) width) - "") - ((cdr tabulated-list-sort-key) - " ▲") + ((> (+ 2 (length label)) width) "") + ((cdr tabulated-list-sort-key) " ▲") (t " ▼"))) 'face 'bold - 'tabulated-list-column-name (car col) + 'tabulated-list-column-name label button-props)) ;; Unselected sortable column. (t (apply 'propertize label - 'tabulated-list-column-name (car col) + 'tabulated-list-column-name label button-props))) - cols)) - (push (propertize " " - 'display (list 'space :align-to x) - 'face 'fixed-pitch) - cols)) - (setq header-line-format (mapconcat 'identity (nreverse cols) "")))) + cols) + (when right-align + (let ((shift (- width (string-width (car cols))))) + (when (> shift 0) + (setq cols + (cons (car cols) + (cons (propertize (make-string shift ?\s) + 'display + `(space :align-to ,(+ x shift))) + (cdr cols)))) + (setq x (+ x shift))))) + (if (> pad-right 0) + (push (propertize " " + 'display `(space :align-to ,next-x) + 'face 'fixed-pitch) + cols)) + (setq x next-x))) + (setq cols (apply 'concat (nreverse cols))) + (if tabulated-list-use-header-line + (setq header-line-format cols) + (setq header-line-format nil) + (set (make-local-variable 'tabulated-list--header-string) cols)))) + +(defun tabulated-list-print-fake-header () + "Insert a fake Tabulated List \"header line\" at the start of the buffer." + (goto-char (point-min)) + (let ((inhibit-read-only t)) + (insert tabulated-list--header-string "\n") + (if tabulated-list--header-overlay + (move-overlay tabulated-list--header-overlay (point-min) (point)) + (set (make-local-variable 'tabulated-list--header-overlay) + (make-overlay (point-min) (point)))) + (overlay-put tabulated-list--header-overlay 'face 'underline))) (defun tabulated-list-revert (&rest ignored) "The `revert-buffer-function' for `tabulated-list-mode'. @@ -206,6 +267,17 @@ It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'." (run-hooks 'tabulated-list-revert-hook) (tabulated-list-print t)) +(defun tabulated-list--column-number (name) + (let ((len (length tabulated-list-format)) + (n 0) + found) + (while (and (< n len) (null found)) + (if (equal (car (aref tabulated-list-format n)) name) + (setq found n)) + (setq n (1+ n))) + (or found + (error "No column named %s" name)))) + (defun tabulated-list-print (&optional remember-pos) "Populate the current Tabulated List mode buffer. This sorts the `tabulated-list-entries' list if sorting is @@ -223,19 +295,16 @@ to the entry with the same ID element as the current line." (setq entry-id (tabulated-list-get-id)) (setq saved-col (current-column))) (erase-buffer) - ;; Sort the buffers, if necessary. - (when tabulated-list-sort-key - (let ((sort-column (car tabulated-list-sort-key)) - (len (length tabulated-list-format)) - (n 0) - sorter) - ;; Which column is to be sorted? - (while (and (< n len) - (not (equal (car (aref tabulated-list-format n)) - sort-column))) - (setq n (1+ n))) - (when (< n len) - (setq sorter (nth 2 (aref tabulated-list-format n))) + (unless tabulated-list-use-header-line + (tabulated-list-print-fake-header)) + ;; Sort the entries, if necessary. + (when (and tabulated-list-sort-key + (car tabulated-list-sort-key)) + (let* ((sort-column (car tabulated-list-sort-key)) + (n (tabulated-list--column-number sort-column)) + (sorter (nth 2 (aref tabulated-list-format n)))) + ;; Is the specified column sortable? + (when sorter (when (eq sorter t) (setq sorter ; Default sorter checks column N: (lambda (A B) @@ -267,53 +336,153 @@ to the entry with the same ID element as the current line." This is the default `tabulated-list-printer' function. ID is a Lisp object identifying the entry to print, and COLS is a vector of column descriptors." - (let ((beg (point)) - (x (max tabulated-list-padding 0)) - (len (length tabulated-list-format))) + (let ((beg (point)) + (x (max tabulated-list-padding 0)) + (ncols (length tabulated-list-format)) + (inhibit-read-only t)) (if (> tabulated-list-padding 0) (insert (make-string x ?\s))) - (dotimes (n len) - (let* ((format (aref tabulated-list-format n)) - (desc (aref cols n)) - (width (nth 1 format)) - (label (if (stringp desc) desc (car desc))) - (help-echo (concat (car format) ": " label))) - ;; Truncate labels if necessary (except last column). - (and (< (1+ n) len) - (> (string-width label) width) - (setq label (truncate-string-to-width label width nil nil t))) - (setq label (bidi-string-mark-left-to-right label)) - (if (stringp desc) - (insert (propertize label 'help-echo help-echo)) - (apply 'insert-text-button label (cdr desc))) - (setq x (+ x 1 width))) - ;; No need to append any spaces if this is the last column. - (if (< (1+ n) len) - (indent-to x 1))) + (dotimes (n ncols) + (setq x (tabulated-list-print-col n (aref cols n) x))) (insert ?\n) - (put-text-property beg (point) 'tabulated-list-id id))) + (put-text-property beg (point) 'tabulated-list-id id) + (put-text-property beg (point) 'tabulated-list-entry cols))) + +(defun tabulated-list-print-col (n col-desc x) + "Insert a specified Tabulated List entry at point. +N is the column number, COL-DESC is a column descriptor \(see +`tabulated-list-entries'), and X is the column number at point. +Return the column number after insertion." + ;; TODO: don't truncate to `width' if the next column is align-right + ;; and has some space left. + (let* ((format (aref tabulated-list-format n)) + (name (nth 0 format)) + (width (nth 1 format)) + (props (nthcdr 3 format)) + (pad-right (or (plist-get props :pad-right) 1)) + (right-align (plist-get props :right-align)) + (label (if (stringp col-desc) col-desc (car col-desc))) + (label-width (string-width label)) + (help-echo (concat (car format) ": " label)) + (opoint (point)) + (not-last-col (< (1+ n) (length tabulated-list-format)))) + ;; Truncate labels if necessary (except last column). + (and not-last-col + (> label-width width) + (setq label (truncate-string-to-width label width nil nil t) + label-width width)) + (setq label (bidi-string-mark-left-to-right label)) + (when (and right-align (> width label-width)) + (let ((shift (- width label-width))) + (insert (propertize (make-string shift ?\s) + 'display `(space :align-to ,(+ x shift)))) + (setq width (- width shift)) + (setq x (+ x shift)))) + (if (stringp col-desc) + (insert (propertize label 'help-echo help-echo)) + (apply 'insert-text-button label (cdr col-desc))) + (let ((next-x (+ x pad-right width))) + ;; No need to append any spaces if this is the last column. + (when not-last-col + (when (> pad-right 0) (insert (make-string pad-right ?\s))) + (insert (propertize + (make-string (- next-x x label-width pad-right) ?\s) + 'display `(space :align-to ,next-x)))) + (put-text-property opoint (point) 'tabulated-list-column-name name) + next-x))) + +(defun tabulated-list-delete-entry () + "Delete the Tabulated List entry at point. +Return a list (ID COLS), where ID is the ID of the deleted entry +and COLS is a vector of its column descriptors. Move point to +the beginning of the deleted entry. Return nil if there is no +entry at point. + +This function only changes the buffer contents; it does not alter +`tabulated-list-entries'." + ;; Assume that each entry occupies one line. + (let* ((id (tabulated-list-get-id)) + (cols (tabulated-list-get-entry)) + (inhibit-read-only t)) + (when cols + (delete-region (line-beginning-position) (1+ (line-end-position))) + (list id cols)))) + +(defun tabulated-list-set-col (col desc &optional change-entry-data) + "Change the Tabulated List entry at point, setting COL to DESC. +COL is the column number to change, or the name of the column to change. +DESC is the new column descriptor, which is inserted via +`tabulated-list-print-col'. + +If CHANGE-ENTRY-DATA is non-nil, modify the underlying entry data +by setting the appropriate slot of the vector originally used to +print this entry. If `tabulated-list-entries' has a list value, +this is the vector stored within it." + (let* ((opoint (point)) + (eol (line-end-position)) + (pos (line-beginning-position)) + (id (tabulated-list-get-id pos)) + (entry (tabulated-list-get-entry pos)) + (prop 'tabulated-list-column-name) + (inhibit-read-only t) + name) + (cond ((numberp col) + (setq name (car (aref tabulated-list-format col)))) + ((stringp col) + (setq name col + col (tabulated-list--column-number col))) + (t + (error "Invalid column %s" col))) + (unless entry + (error "No Tabulated List entry at position %s" opoint)) + (unless (equal (get-text-property pos prop) name) + (while (and (setq pos + (next-single-property-change pos prop nil eol)) + (< pos eol) + (not (equal (get-text-property pos prop) name))))) + (when (< pos eol) + (delete-region pos (next-single-property-change pos prop nil eol)) + (goto-char pos) + (tabulated-list-print-col col desc (current-column)) + (if change-entry-data + (aset entry col desc)) + (put-text-property pos (point) 'tabulated-list-id id) + (put-text-property pos (point) 'tabulated-list-entry entry) + (goto-char opoint)))) (defun tabulated-list-col-sort (&optional e) "Sort Tabulated List entries by the column of the mouse click E." (interactive "e") (let* ((pos (event-start e)) - (obj (posn-object pos)) - (name (get-text-property (if obj (cdr obj) (posn-point pos)) - 'tabulated-list-column-name - (car obj)))) + (obj (posn-object pos))) (with-current-buffer (window-buffer (posn-window pos)) - (when (derived-mode-p 'tabulated-list-mode) - ;; Flip the sort order on a second click. - (if (equal name (car tabulated-list-sort-key)) - (setcdr tabulated-list-sort-key - (not (cdr tabulated-list-sort-key))) - (setq tabulated-list-sort-key (cons name nil))) - (tabulated-list-init-header) - (tabulated-list-print t))))) + (tabulated-list--sort-by-column-name + (get-text-property (if obj (cdr obj) (posn-point pos)) + 'tabulated-list-column-name + (car obj)))))) + +(defun tabulated-list-sort (&optional n) + "Sort Tabulated List entries by the column at point. +With a numeric prefix argument N, sort the Nth column." + (interactive "P") + (let ((name (if n + (car (aref tabulated-list-format n)) + (get-text-property (point) + 'tabulated-list-column-name)))) + (tabulated-list--sort-by-column-name name))) + +(defun tabulated-list--sort-by-column-name (name) + (when (and name (derived-mode-p 'tabulated-list-mode)) + ;; Flip the sort order on a second click. + (if (equal name (car tabulated-list-sort-key)) + (setcdr tabulated-list-sort-key + (not (cdr tabulated-list-sort-key))) + (setq tabulated-list-sort-key (cons name nil))) + (tabulated-list-init-header) + (tabulated-list-print t))) ;;; The mode definition: -;;;###autoload (define-derived-mode tabulated-list-mode special-mode "Tabulated" "Generic major mode for browsing a list of items. This mode is usually not used directly; instead, other major diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index b6b7c266263..11ec0f0614c 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -240,12 +240,14 @@ and idle timers such as are scheduled by `run-with-idle-timer'." (defvar timer-event-last-2 nil "Third-to-last timer that was run.") -(defvar timer-max-repeats 10 - "*Maximum number of times to repeat a timer, if many repeats are delayed. +(defcustom timer-max-repeats 10 + "Maximum number of times to repeat a timer, if many repeats are delayed. Timer invocations can be delayed because Emacs is suspended or busy, or because the system's time changes. If such an occurrence makes it appear that many invocations are overdue, this variable controls -how many will really happen.") +how many will really happen." + :type 'integer + :group 'internal) (defun timer-until (timer time) "Calculate number of seconds from when TIMER will run, until TIME. |