diff options
Diffstat (limited to 'lisp/emacs-lisp')
41 files changed, 4586 insertions, 4894 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..babb5bf8fc9 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. @@ -176,6 +176,7 @@ files.") ("Torbjörn Einarsson" "Torbj.*rn Einarsson") ("Toru Tomabechi" "Toru Tomabechi,") ("Tsugutomo Enami" "enami tsugutomo") + ("Ulrich Müller" "Ulrich Mueller") ("Vincent Del Vecchio" "Vince Del Vecchio") ("William M. Perry" "Bill Perry") ("Wlodzimierz Bzyl" "W.*dek Bzyl") @@ -398,7 +399,7 @@ Changes to files in this list are not listed.") ("Lawrence R. Dodd" :cowrote "dired-x.el") ;; No longer distributed. ;;; ("Viktor Dukhovni" :wrote "unexsunos4.c") - ("Paul Eggert" :wrote "rcs2log" "vcdiff") + ("Paul Eggert" :wrote "rcs2log") ; "vcdiff" ("Fred Fish" :changed "unexcoff.c") ;; No longer distributed. ;;; ("Tim Fleehart" :wrote "makefile.nt") @@ -829,7 +830,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 +944,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..25b4686f87d 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -184,6 +184,7 @@ (require 'bytecomp) (eval-when-compile (require 'cl)) +(require 'macroexp) (defun byte-compile-log-lap-1 (format &rest args) ;; Newer byte codes for stack-ref make the slot 0 non-nil again. @@ -288,10 +289,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 @@ -430,11 +435,9 @@ clause)) (cdr form)))) ((eq fn 'progn) - ;; as an extra added bonus, this simplifies (progn <x>) --> <x> + ;; As an extra added bonus, this simplifies (progn <x>) --> <x>. (if (cdr (cdr form)) - (progn - (setq tmp (byte-optimize-body (cdr form) for-effect)) - (if (cdr tmp) (cons 'progn tmp) (car tmp))) + (macroexp-progn (byte-optimize-body (cdr form) for-effect)) (byte-optimize-form (nth 1 form) for-effect))) ((eq fn 'prog1) (if (cdr (cdr form)) @@ -496,7 +499,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) @@ -573,10 +576,10 @@ (cons fn args))))))) (defun byte-optimize-all-constp (list) - "Non-nil if all elements of LIST satisfy `byte-compile-constp'." + "Non-nil if all elements of LIST satisfy `macroexp-const-p" (let ((constant t)) (while (and list constant) - (unless (byte-compile-constp (car list)) + (unless (macroexp-const-p (car list)) (setq constant nil)) (setq list (cdr list))) constant)) @@ -866,8 +869,8 @@ (defun byte-optimize-binary-predicate (form) - (if (byte-compile-constp (nth 1 form)) - (if (byte-compile-constp (nth 2 form)) + (if (macroexp-const-p (nth 1 form)) + (if (macroexp-const-p (nth 2 form)) (condition-case () (list 'quote (eval form)) (error form)) @@ -879,7 +882,7 @@ (let ((ok t) (rest (cdr form))) (while (and rest ok) - (setq ok (byte-compile-constp (car rest)) + (setq ok (macroexp-const-p (car rest)) rest (cdr rest))) (if ok (condition-case () @@ -945,7 +948,7 @@ (defun byte-optimize-quote (form) (if (or (consp (nth 1 form)) (and (symbolp (nth 1 form)) - (not (byte-compile-const-symbol-p form)))) + (not (macroexp--const-symbol-p form)))) form (nth 1 form))) @@ -1155,15 +1158,15 @@ ;; optimize string-as-unibyte, string-as-multibyte, string-make-unibyte, ;; string-make-multibyte for constant args. -(put 'featurep 'byte-optimizer 'byte-optimize-featurep) -(defun byte-optimize-featurep (form) - ;; Emacs-21's byte-code doesn't run under XEmacs or SXEmacs anyway, so we - ;; can safely optimize away this test. - (if (member (cdr-safe form) '(((quote xemacs)) ((quote sxemacs)))) - nil - (if (member (cdr-safe form) '(((quote emacs)))) - t - form))) +(put 'featurep 'compiler-macro + (lambda (form &rest _ignore) + ;; Emacs-21's byte-code doesn't run under XEmacs or SXEmacs anyway, so + ;; we can safely optimize away this test. + (if (member (cdr-safe form) '(((quote xemacs)) ((quote sxemacs)))) + nil + (if (member (cdr-safe form) '(((quote emacs)))) + t + form)))) (put 'set 'byte-optimizer 'byte-optimize-set) (defun byte-optimize-set (form) @@ -1237,7 +1240,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 @@ -1582,13 +1585,13 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (not (eq (car lap0) 'byte-constant))) nil (setq keep-going t) - (if (memq (car lap0) '(byte-constant byte-dup)) - (progn - (setq tmp (if (or (not tmp) - (byte-compile-const-symbol-p - (car (cdr lap0)))) - (cdr lap0) - (byte-compile-get-constant t))) + (if (memq (car lap0) '(byte-constant byte-dup)) + (progn + (setq tmp (if (or (not tmp) + (macroexp--const-symbol-p + (car (cdr lap0)))) + (cdr lap0) + (byte-compile-get-constant t))) (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" lap0 lap1 lap2 lap0 lap1 (cons (car lap0) tmp)) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index dc7166bc2ea..635eef93d96 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,174 @@ ;;; 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 + (list + ;; We can only use backquotes inside the lambdas and not for those + ;; properties that are used by functions loaded before backquote.el. + (list 'advertised-calling-convention + #'(lambda (f _args arglist when) + (list 'set-advertised-calling-convention + (list 'quote f) (list 'quote arglist) (list 'quote when)))) + (list 'obsolete + #'(lambda (f _args new-name when) + `(make-obsolete ',f ',new-name ,when))) + (list 'compiler-macro + #'(lambda (f _args compiler-function) + `(put ',f 'compiler-macro #',compiler-function))) + (list 'doc-string + #'(lambda (f _args pos) + (list 'put (list 'quote f) ''doc-string-elt (list 'quote pos)))) + (list 'indent + #'(lambda (f _args 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, +the function's arglist, and the VALUES and should return the code to use +to set this property.") + +(defvar macro-declarations-alist + (cons + (list 'debug + #'(lambda (name _args 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 arglist (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 arglist (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 +230,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 +243,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 +258,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 +280,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 +296,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 +325,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 +337,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 +417,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..25a901fd248 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))) @@ -1459,57 +1464,40 @@ extra args." nil) -(defsubst byte-compile-const-symbol-p (symbol &optional any-value) - "Non-nil if SYMBOL is constant. -If ANY-VALUE is nil, only return non-nil if the value of the symbol is the -symbol itself." - (or (memq symbol '(nil t)) - (keywordp symbol) - (if any-value - (or (memq symbol byte-compile-const-variables) - ;; FIXME: We should provide a less intrusive way to find out - ;; if a variable is "constant". - (and (boundp symbol) - (condition-case nil - (progn (set symbol (symbol-value symbol)) nil) - (setting-constant t))))))) - -(defmacro byte-compile-constp (form) - "Return non-nil if FORM is a constant." - `(cond ((consp ,form) (eq (car ,form) 'quote)) - ((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 +1838,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 +1911,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." @@ -1959,7 +1942,7 @@ and will be removed soon. See (elisp)Backquote in the manual.")) ;; Because the header must fit in a fixed width, we cannot ;; insert arbitrary-length file names (Bug#11585). " (error \"`%s' was compiled for " - (format "Emacs %s or later\" load-file-name))\n\n" minimum-version)) + (format "Emacs %s or later\" #$))\n\n" minimum-version)) ;; Now compensate for any change in size, to make sure all ;; positions in the file remain valid. (setq delta (- (point-max) old-header-end)) @@ -2016,31 +1999,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 - ;; in defun, defmacro, defvar, defvaralias, defconst, autoload and + ;; Write the given form to the output buffer, being careful of docstrings + ;; in 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) '(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 +2052,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,19 +2064,18 @@ 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)) + (index 0) + ;; FIXME: The bindings below are only needed for when we're + ;; called from ...-defmumble. + (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))) (prin1 (car form) byte-compile--outbuffer) (while (setq form (cdr form)) (setq index (1+ index)) @@ -2116,8 +2096,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)) @@ -2203,7 +2181,7 @@ list that represents a doc string reference. (put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload) (defun byte-compile-file-form-autoload (form) (and (let ((form form)) - (while (if (setq form (cdr form)) (byte-compile-constp (car form)))) + (while (if (setq form (cdr form)) (macroexp-const-p (car form)))) (null form)) ;Constants only (eval (nth 5 form)) ;Macro (eval form)) ;Define the autoload. @@ -2265,19 +2243,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 +2290,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 +2440,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)))))) @@ -2533,7 +2487,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (when (symbolp arg) (byte-compile-set-symbol-position arg)) (cond ((or (not (symbolp arg)) - (byte-compile-const-symbol-p arg t)) + (macroexp--const-symbol-p arg t)) (error "Invalid lambda variable %s" arg)) ((eq arg '&rest) (unless (cdr list) @@ -2588,14 +2542,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 +2611,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) @@ -2802,7 +2756,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (if (eq (car (car rest)) 'byte-constant) (or (consp tmp) (and (symbolp tmp) - (not (byte-compile-const-symbol-p tmp))))) + (not (macroexp--const-symbol-p tmp))))) (if maycall (setq body (cons (list 'quote tmp) body))) (setq body (cons tmp body)))) @@ -2847,7 +2801,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (push (cons fn (if (and (consp args) (listp (car args))) (list 'declared (car args)) - t)) ; arglist not specified + t)) ; Arglist not specified. byte-compile-function-environment) ;; We are stating that it _will_ be defined at runtime. (setq byte-compile-noruntime-functions @@ -2873,7 +2827,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (let ((byte-compile--for-effect for-effect)) (cond ((not (consp form)) - (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form)) + (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) (when (symbolp form) (byte-compile-set-symbol-position form)) (byte-compile-constant form)) @@ -2886,7 +2840,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." ((symbolp (car form)) (let* ((fn (car form)) (handler (get fn 'byte-compile))) - (when (byte-compile-const-symbol-p fn) + (when (macroexp--const-symbol-p fn) (byte-compile-warn "`%s' called as a function" fn)) (and (byte-compile-warning-enabled-p 'interactive-only) (memq fn byte-compile-interactive-only-functions) @@ -2897,14 +2851,12 @@ That command is designed for interactive use only" fn)) (byte-compile-log-warning (format "Forgot to expand macro %s" (car form)) nil :error)) (if (and handler - ;; Make sure that function exists. This is important - ;; for CL compiler macros since the symbol may be - ;; `cl-byte-compile-compiler-macro' but if CL isn't - ;; loaded, this function doesn't exist. - (and (not (eq handler - ;; Already handled by macroexpand-all. - 'cl-byte-compile-compiler-macro)) - (functionp handler))) + ;; Make sure that function exists. + (and (functionp handler) + ;; Ignore obsolete byte-compile function used by former + ;; CL code to handle compiler macros (we do it + ;; differently now). + (not (eq handler 'cl-byte-compile-compiler-macro)))) (funcall handler form) (byte-compile-normal-call form)) (if (byte-compile-warning-enabled-p 'cl-functions) @@ -3022,7 +2974,7 @@ That command is designed for interactive use only" fn)) "Do various error checks before a use of the variable VAR." (when (symbolp var) (byte-compile-set-symbol-position var)) - (cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var)) + (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var)) (when (byte-compile-warning-enabled-p 'constants) (byte-compile-warn (if (eq access-type 'let-bind) "attempt to let-bind %s `%s`" @@ -3073,9 +3025,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 +3312,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) @@ -3592,7 +3545,7 @@ discarding." (byte-compile-form (cons 'progn (nreverse setters)))) (let ((var (car form))) (and (or (not (symbolp var)) - (byte-compile-const-symbol-p var t)) + (macroexp--const-symbol-p var t)) (byte-compile-warning-enabled-p 'constants) (byte-compile-warn "variable assignment to %s `%s'" @@ -4081,36 +4034,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 @@ -4166,8 +4094,8 @@ binding slots have been popped." (defun byte-compile-autoload (form) (byte-compile-set-symbol-position 'autoload) - (and (byte-compile-constp (nth 1 form)) - (byte-compile-constp (nth 5 form)) + (and (macroexp-const-p (nth 1 form)) + (macroexp-const-p (nth 5 form)) (eval (nth 5 form)) ; macro-p (not (fboundp (eval (nth 1 form)))) (byte-compile-warn @@ -4186,38 +4114,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 +4468,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..5c5802f0e02 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 @@ -37,12 +37,12 @@ ;;; Code: -(require 'cl) +(require 'cl-lib) ;;; Type coercion. ;;;###autoload -(defun coerce (x type) +(defun cl-coerce (x type) "Coerce OBJECT to type TYPE. TYPE is a Common Lisp type specifier. \n(fn OBJECT TYPE)" @@ -51,16 +51,16 @@ TYPE is a Common Lisp type specifier. ((eq type 'string) (if (stringp x) x (concat x))) ((eq type 'array) (if (arrayp x) x (vconcat x))) ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) - ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type)) + ((and (eq type 'character) (symbolp x)) (cl-coerce (symbol-name x) type)) ((eq type 'float) (float x)) - ((typep x type) x) + ((cl-typep x type) x) (t (error "Can't coerce %s to type %s" x type)))) ;;; Predicates. ;;;###autoload -(defun equalp (x y) +(defun cl-equalp (x y) "Return t if two Lisp objects have similar structures and contents. This is like `equal', except that it accepts numerically equal numbers of different types (float vs. integer), and also compares @@ -73,14 +73,14 @@ strings case-insensitively." ((numberp x) (and (numberp y) (= x y))) ((consp x) - (while (and (consp x) (consp y) (equalp (car x) (car y))) + (while (and (consp x) (consp y) (cl-equalp (car x) (car y))) (setq x (cdr x) y (cdr y))) - (and (not (consp x)) (equalp x y))) + (and (not (consp x)) (cl-equalp x y))) ((vectorp x) (and (vectorp y) (= (length x) (length y)) (let ((i (length x))) (while (and (>= (setq i (1- i)) 0) - (equalp (aref x i) (aref y i)))) + (cl-equalp (aref x i) (aref y i)))) (< i 0)))) (t (equal x y)))) @@ -115,21 +115,21 @@ strings case-insensitively." (cl-i -1)) (while (< (setq cl-i (1+ cl-i)) cl-n) (push (funcall cl-func - (if (consp cl-x) (pop cl-x) (aref cl-x cl-i)) - (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) - cl-res))) + (if (consp cl-x) (pop cl-x) (aref cl-x cl-i)) + (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) + cl-res))) (nreverse cl-res)))) ;;;###autoload -(defun map (cl-type cl-func cl-seq &rest cl-rest) +(defun cl-map (cl-type cl-func cl-seq &rest cl-rest) "Map a FUNCTION across one or more SEQUENCEs, returning a sequence. TYPE is the sequence type to return. \n(fn TYPE FUNCTION SEQUENCE...)" - (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest))) - (and cl-type (coerce cl-res cl-type)))) + (let ((cl-res (apply 'cl-mapcar cl-func cl-seq cl-rest))) + (and cl-type (cl-coerce cl-res cl-type)))) ;;;###autoload -(defun maplist (cl-func cl-list &rest cl-rest) +(defun cl-maplist (cl-func cl-list &rest cl-rest) "Map FUNCTION to each sublist of LIST or LISTs. Like `mapcar', except applies to lists and their cdr's rather than to the elements themselves. @@ -153,40 +153,40 @@ the elements themselves. "Like `mapcar', but does not accumulate values returned by the function. \n(fn FUNCTION SEQUENCE...)" (if cl-rest - (progn (apply 'map nil cl-func cl-seq cl-rest) + (progn (apply 'cl-map nil cl-func cl-seq cl-rest) cl-seq) (mapc cl-func cl-seq))) ;;;###autoload -(defun mapl (cl-func cl-list &rest cl-rest) - "Like `maplist', but does not accumulate values returned by the function. +(defun cl-mapl (cl-func cl-list &rest cl-rest) + "Like `cl-maplist', but does not accumulate values returned by the function. \n(fn FUNCTION LIST...)" (if cl-rest - (apply 'maplist cl-func cl-list cl-rest) + (apply 'cl-maplist cl-func cl-list cl-rest) (let ((cl-p cl-list)) (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p))))) cl-list) ;;;###autoload -(defun mapcan (cl-func cl-seq &rest cl-rest) +(defun cl-mapcan (cl-func cl-seq &rest cl-rest) "Like `mapcar', but nconc's together the values returned by the function. \n(fn FUNCTION SEQUENCE...)" - (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest))) + (apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest))) ;;;###autoload -(defun mapcon (cl-func cl-list &rest cl-rest) - "Like `maplist', but nconc's together the values returned by the function. +(defun cl-mapcon (cl-func cl-list &rest cl-rest) + "Like `cl-maplist', but nconc's together the values returned by the function. \n(fn FUNCTION LIST...)" - (apply 'nconc (apply 'maplist cl-func cl-list cl-rest))) + (apply 'nconc (apply 'cl-maplist cl-func cl-list cl-rest))) ;;;###autoload -(defun some (cl-pred cl-seq &rest cl-rest) +(defun cl-some (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is true of any element of SEQ or SEQs. If so, return the true (non-nil) value returned by PREDICATE. \n(fn PREDICATE SEQ...)" (if (or cl-rest (nlistp cl-seq)) (catch 'cl-some - (apply 'map nil + (apply 'cl-map nil (function (lambda (&rest cl-x) (let ((cl-res (apply cl-pred cl-x))) (if cl-res (throw 'cl-some cl-res))))) @@ -196,12 +196,12 @@ If so, return the true (non-nil) value returned by PREDICATE. cl-x))) ;;;###autoload -(defun every (cl-pred cl-seq &rest cl-rest) +(defun cl-every (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is true of every element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" (if (or cl-rest (nlistp cl-seq)) (catch 'cl-every - (apply 'map nil + (apply 'cl-map nil (function (lambda (&rest cl-x) (or (apply cl-pred cl-x) (throw 'cl-every nil)))) cl-seq cl-rest) t) @@ -210,20 +210,16 @@ If so, return the true (non-nil) value returned by PREDICATE. (null cl-seq))) ;;;###autoload -(defun notany (cl-pred cl-seq &rest cl-rest) +(defun cl-notany (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is false of every element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" - (not (apply 'some cl-pred cl-seq cl-rest))) + (not (apply 'cl-some cl-pred cl-seq cl-rest))) ;;;###autoload -(defun notevery (cl-pred cl-seq &rest cl-rest) +(defun cl-notevery (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is false of some element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" - (not (apply 'every cl-pred cl-seq cl-rest))) - -;;; Support for `loop'. -;;;###autoload -(defalias 'cl-map-keymap 'map-keymap) + (not (apply 'cl-every cl-pred cl-seq cl-rest))) ;;;###autoload (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) @@ -309,7 +305,7 @@ If so, return the true (non-nil) value returned by PREDICATE. (setq cl-ovl (cdr cl-ovl)))) (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))))) -;;; Support for `setf'. +;;; Support for `cl-setf'. ;;;###autoload (defun cl-set-frame-visible-p (frame val) (cond ((null val) (make-frame-invisible frame)) @@ -317,7 +313,7 @@ If so, return the true (non-nil) value returned by PREDICATE. (t (make-frame-visible frame))) val) -;;; Support for `progv'. +;;; Support for `cl-progv'. (defvar cl-progv-save) ;;;###autoload (defun cl-progv-before (syms values) @@ -340,7 +336,7 @@ If so, return the true (non-nil) value returned by PREDICATE. ;;; Numbers. ;;;###autoload -(defun gcd (&rest args) +(defun cl-gcd (&rest args) "Return the greatest common divisor of the arguments." (let ((a (abs (or (pop args) 0)))) (while args @@ -349,18 +345,18 @@ If so, return the true (non-nil) value returned by PREDICATE. a)) ;;;###autoload -(defun lcm (&rest args) +(defun cl-lcm (&rest args) "Return the least common multiple of the arguments." (if (memq 0 args) 0 (let ((a (abs (or (pop args) 1)))) (while args (let ((b (abs (pop args)))) - (setq a (* (/ a (gcd a b)) b)))) + (setq a (* (/ a (cl-gcd a b)) b)))) a))) ;;;###autoload -(defun isqrt (x) +(defun cl-isqrt (x) "Return the integer square root of the argument." (if (and (integerp x) (> x 0)) (let ((g (cond ((<= x 100) 10) ((<= x 10000) 100) @@ -372,35 +368,35 @@ If so, return the true (non-nil) value returned by PREDICATE. (if (eq x 0) 0 (signal 'arith-error nil)))) ;;;###autoload -(defun floor* (x &optional y) +(defun cl-floor (x &optional y) "Return a list of the floor of X and the fractional part of X. With two arguments, return floor and remainder of their quotient." (let ((q (floor x y))) (list q (- x (if y (* y q) q))))) ;;;###autoload -(defun ceiling* (x &optional y) +(defun cl-ceiling (x &optional y) "Return a list of the ceiling of X and the fractional part of X. With two arguments, return ceiling and remainder of their quotient." - (let ((res (floor* x y))) + (let ((res (cl-floor x y))) (if (= (car (cdr res)) 0) res (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) ;;;###autoload -(defun truncate* (x &optional y) +(defun cl-truncate (x &optional y) "Return a list of the integer part of X and the fractional part of X. With two arguments, return truncation and remainder of their quotient." (if (eq (>= x 0) (or (null y) (>= y 0))) - (floor* x y) (ceiling* x y))) + (cl-floor x y) (cl-ceiling x y))) ;;;###autoload -(defun round* (x &optional y) +(defun cl-round (x &optional y) "Return a list of X rounded to the nearest integer and the remainder. With two arguments, return rounding and remainder of their quotient." (if y (if (and (integerp x) (integerp y)) (let* ((hy (/ y 2)) - (res (floor* (+ x hy) y))) + (res (cl-floor (+ x hy) y))) (if (and (= (car (cdr res)) 0) (= (+ hy hy) y) (/= (% (car res) 2) 0)) @@ -413,29 +409,28 @@ With two arguments, return rounding and remainder of their quotient." (list q (- x q)))))) ;;;###autoload -(defun mod* (x y) +(defun cl-mod (x y) "The remainder of X divided by Y, with the same sign as Y." - (nth 1 (floor* x y))) + (nth 1 (cl-floor x y))) ;;;###autoload -(defun rem* (x y) +(defun cl-rem (x y) "The remainder of X divided by Y, with the same sign as X." - (nth 1 (truncate* x y))) + (nth 1 (cl-truncate x y))) ;;;###autoload -(defun signum (x) +(defun cl-signum (x) "Return 1 if X is positive, -1 if negative, 0 if zero." (cond ((> x 0) 1) ((< x 0) -1) (t 0))) ;; Random numbers. -(defvar *random-state*) ;;;###autoload -(defun random* (lim &optional state) +(defun cl-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) @@ -444,29 +439,29 @@ Optional second arg STATE is a random-state object." (aset vec 0 j) (while (> (setq i (% (+ i 21) 55)) 0) (aset vec i (setq j (prog1 k (setq k (- j k)))))) - (while (< (setq i (1+ i)) 200) (random* 2 state)))) + (while (< (setq i (1+ i)) 200) (cl-random 2 state)))) (let* ((i (aset state 1 (% (1+ (aref state 1)) 55))) (j (aset state 2 (% (1+ (aref state 2)) 55))) (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j)))))) (if (integerp lim) (if (<= lim 512) (% n lim) - (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state)))) + (if (> lim 8388607) (setq n (+ (lsh n 9) (cl-random 512 state)))) (let ((mask 1023)) (while (< mask (1- lim)) (setq mask (1+ (+ mask mask)))) - (if (< (setq n (logand n mask)) lim) n (random* lim state)))) + (if (< (setq n (logand n mask)) lim) n (cl-random lim state)))) (* (/ n '8388608e0) lim))))) ;;;###autoload -(defun make-random-state (&optional state) - "Return a copy of random-state STATE, or of `*random-state*' if omitted. +(defun cl-make-random-state (&optional state) + "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*)) - ((vectorp state) (cl-copy-tree state t)) + (cond ((null state) (cl-make-random-state cl--random-state)) + ((vectorp state) (copy-tree state t)) ((integerp state) (vector 'cl-random-state-tag -1 30 state)) - (t (make-random-state (cl-random-time))))) + (t (cl-make-random-state (cl-random-time))))) ;;;###autoload -(defun random-state-p (object) +(defun cl-random-state-p (object) "Return t if OBJECT is a random-state object." (and (vectorp object) (= (length object) 4) (eq (aref object 0) 'cl-random-state-tag))) @@ -483,48 +478,48 @@ If STATE is t, return a new state object seeded from the time of day." ;;;###autoload (defun cl-float-limits () "Initialize the Common Lisp floating-point parameters. -This sets the values of: `most-positive-float', `most-negative-float', -`least-positive-float', `least-negative-float', `float-epsilon', -`float-negative-epsilon', `least-positive-normalized-float', and -`least-negative-normalized-float'." - (or most-positive-float (not (numberp '2e1)) +This sets the values of: `cl-most-positive-float', `cl-most-negative-float', +`cl-least-positive-float', `cl-least-negative-float', `cl-float-epsilon', +`cl-float-negative-epsilon', `cl-least-positive-normalized-float', and +`cl-least-negative-normalized-float'." + (or cl-most-positive-float (not (numberp '2e1)) (let ((x '2e0) y z) ;; Find maximum exponent (first two loops are optimizations) (while (cl-finite-do '* x x) (setq x (* x x))) (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2)))) (while (cl-finite-do '+ x x) (setq x (+ x x))) (setq z x y (/ x 2)) - ;; Now fill in 1's in the mantissa. + ;; Now cl-fill in 1's in the mantissa. (while (and (cl-finite-do '+ x y) (/= (+ x y) x)) (setq x (+ x y) y (/ y 2))) - (setq most-positive-float x - most-negative-float (- x)) + (setq cl-most-positive-float x + cl-most-negative-float (- x)) ;; Divide down until mantissa starts rounding. (setq x (/ x z) y (/ 16 z) x (* x y)) (while (condition-case err (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) (arith-error nil)) (setq x (/ x 2) y (/ y 2))) - (setq least-positive-normalized-float y - least-negative-normalized-float (- y)) + (setq cl-least-positive-normalized-float y + cl-least-negative-normalized-float (- y)) ;; Divide down until value underflows to zero. (setq x (/ 1 z) y x) (while (condition-case err (> (/ x 2) 0) (arith-error nil)) (setq x (/ x 2))) - (setq least-positive-float x - least-negative-float (- x)) + (setq cl-least-positive-float x + cl-least-negative-float (- x)) (setq x '1e0) (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2))) - (setq float-epsilon (* x 2)) + (setq cl-float-epsilon (* x 2)) (setq x '1e0) (while (/= (- '1e0 x) '1e0) (setq x (/ x 2))) - (setq float-negative-epsilon (* x 2)))) + (setq cl-float-negative-epsilon (* x 2)))) nil) ;;; Sequence functions. ;;;###autoload -(defun subseq (seq start &optional end) +(defun cl-subseq (seq start &optional end) "Return the subsequence of SEQ from START to END. If END is omitted, it defaults to the length of the sequence. If START or END is negative, it counts from the end." @@ -550,7 +545,7 @@ If START or END is negative, it counts from the end." res)))))) ;;;###autoload -(defun concatenate (type &rest seqs) +(defun cl-concatenate (type &rest seqs) "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. \n(fn TYPE SEQUENCE...)" (cond ((eq type 'vector) (apply 'vconcat seqs)) @@ -562,17 +557,17 @@ If START or END is negative, it counts from the end." ;;; List functions. ;;;###autoload -(defun revappend (x y) +(defun cl-revappend (x y) "Equivalent to (append (reverse X) Y)." (nconc (reverse x) y)) ;;;###autoload -(defun nreconc (x y) +(defun cl-nreconc (x y) "Equivalent to (nconc (nreverse X) Y)." (nconc (nreverse x) y)) ;;;###autoload -(defun list-length (x) +(defun cl-list-length (x) "Return the length of list X. Return nil if list is circular." (let ((n 0) (fast x) (slow x)) (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) @@ -580,37 +575,36 @@ If START or END is negative, it counts from the end." (if fast (if (cdr fast) nil (1+ n)) n))) ;;;###autoload -(defun tailp (sublist list) +(defun cl-tailp (sublist list) "Return true if SUBLIST is a tail of LIST." (while (and (consp list) (not (eq sublist list))) (setq list (cdr list))) (if (numberp sublist) (equal sublist list) (eq sublist list))) -(defalias 'cl-copy-tree 'copy-tree) - - ;;; Property lists. ;;;###autoload -(defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el +(defun cl-get (sym tag &optional def) "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none. \n(fn SYMBOL PROPNAME &optional DEFAULT)" + (declare (compiler-macro cl--compiler-macro-get)) (or (get sym tag) (and def (let ((plist (symbol-plist sym))) (while (and plist (not (eq (car plist) tag))) (setq plist (cdr (cdr plist)))) (if plist (car (cdr plist)) def))))) +(autoload 'cl--compiler-macro-get "cl-macs") ;;;###autoload -(defun getf (plist tag &optional def) +(defun cl-getf (plist tag &optional def) "Search PROPLIST for property PROPNAME; return its value or DEFAULT. PROPLIST is a list of the sort returned by `symbol-plist'. \n(fn PROPLIST PROPNAME &optional DEFAULT)" (setplist '--cl-getf-symbol-- plist) (or (get '--cl-getf-symbol-- tag) - ;; Originally we called get* here, - ;; but that fails, because get* has a compiler macro + ;; Originally we called cl-get here, + ;; but that fails, because cl-get has a compiler macro ;; definition that uses getf! (when def (while (and plist (not (eq (car plist) tag))) @@ -621,7 +615,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (defun cl-set-getf (plist tag val) (let ((p plist)) (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p)))) - (if p (progn (setcar (cdr p) val) plist) (list* tag val plist)))) + (if p (progn (setcar (cdr p) val) plist) (cl-list* tag val plist)))) ;;;###autoload (defun cl-do-remf (plist tag) @@ -637,40 +631,6 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (if (and plist (eq tag (car plist))) (progn (setplist sym (cdr (cdr plist))) t) (cl-do-remf plist tag)))) -;;;###autoload -(defalias 'remprop 'cl-remprop) - - - -;;; Hash tables. -;; This is just kept for compatibility with code byte-compiled by Emacs-20. - -;; No idea if this might still be needed. -(defun cl-not-hash-table (x &optional y &rest z) - (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x)))) - -(defvar cl-builtin-gethash (symbol-function 'gethash)) -(defvar cl-builtin-remhash (symbol-function 'remhash)) -(defvar cl-builtin-clrhash (symbol-function 'clrhash)) -(defvar cl-builtin-maphash (symbol-function 'maphash)) - -;;;###autoload -(defalias 'cl-gethash 'gethash) -;;;###autoload -(defalias 'cl-puthash 'puthash) -;;;###autoload -(defalias 'cl-remhash 'remhash) -;;;###autoload -(defalias 'cl-clrhash 'clrhash) -;;;###autoload -(defalias 'cl-maphash 'maphash) -;; These three actually didn't exist in Emacs-20. -;;;###autoload -(defalias 'cl-make-hash-table 'make-hash-table) -;;;###autoload -(defalias 'cl-hash-table-p 'hash-table-p) -;;;###autoload -(defalias 'cl-hash-table-count 'hash-table-count) ;;; Some debugging aids. @@ -715,93 +675,13 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (forward-char 1)))) (forward-sexp))) -(defvar cl-macroexpand-cmacs nil) -(defvar cl-closure-vars nil) - -;;;###autoload -(defun cl-macroexpand-all (form &optional env) - "Expand all macro calls through a Lisp FORM. -This also does some trivial optimizations to make the form prettier." - (while (or (not (eq form (setq form (macroexpand form env)))) - (and cl-macroexpand-cmacs - (not (eq form (setq form (compiler-macroexpand form))))))) - (cond ((not (consp form)) form) - ((memq (car form) '(let let*)) - (if (null (nth 1 form)) - (cl-macroexpand-all (cons 'progn (cddr form)) env) - (let ((letf nil) (res nil) (lets (cadr form))) - (while lets - (push (if (consp (car lets)) - (let ((exp (cl-macroexpand-all (caar lets) env))) - (or (symbolp exp) (setq letf t)) - (cons exp (cl-macroexpand-body (cdar lets) env))) - (let ((exp (cl-macroexpand-all (car lets) env))) - (if (symbolp exp) exp - (setq letf t) (list exp nil)))) res) - (setq lets (cdr lets))) - (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form)) - (nreverse res) (cl-macroexpand-body (cddr form) env))))) - ((eq (car form) 'cond) - (cons (car form) - (mapcar (function (lambda (x) (cl-macroexpand-body x env))) - (cdr form)))) - ((eq (car form) 'condition-case) - (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env) - (mapcar (function - (lambda (x) - (cons (car x) (cl-macroexpand-body (cdr x) env)))) - (cdddr form)))) - ((memq (car form) '(quote function)) - (if (eq (car-safe (nth 1 form)) 'lambda) - (let ((body (cl-macroexpand-body (cddadr form) env))) - (if (and cl-closure-vars (eq (car form) 'function) - (cl-expr-contains-any body cl-closure-vars)) - (let* ((new (mapcar 'gensym cl-closure-vars)) - (sub (pairlis cl-closure-vars new)) (decls nil)) - (while (or (stringp (car body)) - (eq (car-safe (car body)) 'interactive)) - (push (list 'quote (pop body)) decls)) - (put (car (last cl-closure-vars)) 'used t) - `(list 'lambda '(&rest --cl-rest--) - ,@(sublis sub (nreverse decls)) - (list 'apply - (list 'quote - #'(lambda ,(append new (cadadr form)) - ,@(sublis sub body))) - ,@(nconc (mapcar (lambda (x) `(list 'quote ,x)) - cl-closure-vars) - '((quote --cl-rest--)))))) - (list (car form) (list* 'lambda (cadadr form) body)))) - (let ((found (assq (cadr form) env))) - (if (and found (ignore-errors - (eq (cadr (caddr found)) 'cl-labels-args))) - (cl-macroexpand-all (cadr (caddr (cadddr found))) env) - form)))) - ((memq (car form) '(defun defmacro)) - (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) - ((and (eq (car form) 'progn) (not (cddr form))) - (cl-macroexpand-all (nth 1 form) env)) - ((eq (car form) 'setq) - (let* ((args (cl-macroexpand-body (cdr form) env)) (p args)) - (while (and p (symbolp (car p))) (setq p (cddr p))) - (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args)))) - ((consp (car form)) - (cl-macroexpand-all (list* 'funcall - (list 'function (car form)) - (cdr form)) - env)) - (t (cons (car form) (cl-macroexpand-body (cdr form) env))))) - -(defun cl-macroexpand-body (body &optional env) - (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body)) - ;;;###autoload (defun cl-prettyexpand (form &optional full) (message "Expanding...") (let ((cl-macroexpand-cmacs full) (cl-compiling-file full) (byte-compile-macro-environment nil)) - (setq form (cl-macroexpand-all form - (and (not full) '((block) (eval-when))))) + (setq form (macroexpand-all form + (and (not full) '((cl-block) (cl-eval-when))))) (message "Formatting...") (prog1 (cl-prettyprint form) (message "")))) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el new file mode 100644 index 00000000000..6ec1060e39f --- /dev/null +++ b/lisp/emacs-lisp/cl-lib.el @@ -0,0 +1,679 @@ +;;; cl-lib.el --- Common Lisp extensions for Emacs + +;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. + +;; Author: Dave Gillespie <daveg@synaptics.com> +;; Version: 2.02 +;; 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: + +;; These are extensions to Emacs Lisp that provide a degree of +;; Common Lisp compatibility, beyond what is already built-in +;; in Emacs Lisp. +;; +;; This package was written by Dave Gillespie; it is a complete +;; rewrite of Cesar Quiroz's original cl.el package of December 1986. +;; +;; Bug reports, comments, and suggestions are welcome! + +;; This file contains the portions of the Common Lisp extensions +;; package which should always be present. + + +;;; Future notes: + +;; Once Emacs 19 becomes standard, many things in this package which are +;; messy for reasons of compatibility can be greatly simplified. For now, +;; I prefer to maintain one unified version. + + +;;; Change Log: + +;; Version 2.02 (30 Jul 93): +;; * Added "cl-compat.el" file, extra compatibility with old package. +;; * Added `lexical-let' and `lexical-let*'. +;; * Added `define-modify-macro', `callf', and `callf2'. +;; * Added `ignore-errors'. +;; * Changed `(setf (nthcdr N PLACE) X)' to work when N is zero. +;; * Merged `*gentemp-counter*' into `*gensym-counter*'. +;; * Extended `subseq' to allow negative START and END like `substring'. +;; * Added `in-ref', `across-ref', `elements of-ref' loop clauses. +;; * Added `concat', `vconcat' loop clauses. +;; * Cleaned up a number of compiler warnings. + +;; Version 2.01 (7 Jul 93): +;; * Added support for FSF version of Emacs 19. +;; * Added `add-hook' for Emacs 18 users. +;; * Added `defsubst*' and `symbol-macrolet'. +;; * Added `maplist', `mapc', `mapl', `mapcan', `mapcon'. +;; * Added `map', `concatenate', `reduce', `merge'. +;; * Added `revappend', `nreconc', `tailp', `tree-equal'. +;; * Added `assert', `check-type', `typecase', `typep', and `deftype'. +;; * Added destructuring and `&environment' support to `defmacro*'. +;; * Added destructuring to `loop', and added the following clauses: +;; `elements', `frames', `overlays', `intervals', `buffers', `key-seqs'. +;; * Renamed `delete' to `delete*' and `remove' to `remove*'. +;; * Completed support for all keywords in `remove*', `substitute', etc. +;; * Added `most-positive-float' and company. +;; * Fixed hash tables to work with latest Lucid Emacs. +;; * `proclaim' forms are no longer compile-time-evaluating; use `declaim'. +;; * Syntax for `warn' declarations has changed. +;; * Improved implementation of `random*'. +;; * Moved most sequence functions to a new file, cl-seq.el. +;; * Moved `eval-when' into cl-macs.el. +;; * Moved `pushnew' and `adjoin' to cl.el for most common cases. +;; * Moved `provide' forms down to ends of files. +;; * Changed expansion of `pop' to something that compiles to better code. +;; * Changed so that no patch is required for Emacs 19 byte compiler. +;; * Made more things dependent on `optimize' declarations. +;; * Added a partial implementation of struct print functions. +;; * Miscellaneous minor changes. + +;; Version 2.00: +;; * First public release of this package. + + +;;; Code: + +(defvar cl-optimize-speed 1) +(defvar cl-optimize-safety 1) + +;;;###autoload +(define-obsolete-variable-alias + ;; This alias is needed for compatibility with .elc files that use defstruct + ;; and were compiled with Emacs<24.2. + 'custom-print-functions 'cl-custom-print-functions "24.2") + +;;;###autoload +(defvar cl-custom-print-functions nil + "This is a list of functions that format user objects for printing. +Each function is called in turn with three arguments: the object, the +stream, and the print level (currently ignored). If it is able to +print the object it returns true; otherwise it returns nil and the +printer proceeds to the next function on the list. + +This variable is not used at present, but it is defined in hopes that +a future Emacs interpreter will be able to use it.") + +(defun cl-unload-function () + "Stop unloading of the Common Lisp extensions." + (message "Cannot unload the feature `cl'") + ;; stop standard unloading! + t) + +;;; Generalized variables. +;; These macros are defined here so that they +;; can safely be used in .emacs files. + +(defmacro cl-incf (place &optional x) + "Increment PLACE by X (1 by default). +PLACE may be a symbol, or any generalized variable allowed by `cl-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 'cl-callf '+ place (or x 1)))) + +(defmacro cl-decf (place &optional x) + "Decrement PLACE by X (1 by default). +PLACE may be a symbol, or any generalized variable allowed by `cl-setf'. +The return value is the decremented value of PLACE." + (declare (debug cl-incf)) + (if (symbolp place) + (list 'setq place (if x (list '- place x) (list '1- place))) + (list 'cl-callf '- place (or x 1)))) + +;; Autoloaded, but we haven't loaded cl-loaddefs yet. +(declare-function cl-do-pop "cl-macs" (place)) + +(defmacro cl-pop (place) + "Remove and return the head of the list stored in PLACE. +Analogous to (prog1 (car PLACE) (cl-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 `cl-setf'." + (declare (debug (place))) + (if (symbolp place) + (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))) + (cl-do-pop place))) + +(defmacro cl-push (x place) + "Insert X at the head of the list stored in PLACE. +Analogous to (cl-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 `cl-setf'." + (declare (debug (form place))) + (if (symbolp place) (list 'setq place (list 'cons x place)) + (list 'cl-callf2 'cons x place))) + +(defmacro cl-pushnew (x place &rest keys) + "(cl-pushnew X PLACE): insert X at the head of the list if not already there. +Like (cl-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)) + (if (memql x ,place) + ;; This symbol may later on expand to actual code which then + ;; trigger warnings like "value unused" since cl-pushnew's return + ;; value is rarely used. It should not matter that other + ;; warnings may be silenced, since `place' is used earlier and + ;; should have triggered them already. + (with-no-warnings ,place) + (setq ,place (cons x ,place)))) + (list 'setq place (cl-list* 'cl-adjoin x place keys))) + (cl-list* 'cl-callf2 'cl-adjoin x place keys))) + +(defun cl-set-elt (seq n val) + (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) + +(defsubst cl-set-nthcdr (n list x) + (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list)) + +(defun cl-set-buffer-substring (start end val) + (save-excursion (delete-region start end) + (goto-char start) + (insert val) + val)) + +(defun cl-set-substring (str start end val) + (if end (if (< end 0) (cl-incf end (length str))) + (setq end (length str))) + (if (< start 0) (cl-incf start (length str))) + (concat (and (> start 0) (substring str 0 start)) + val + (and (< end (length str)) (substring str end)))) + + +;;; Control structures. + +;; These macros are so simple and so often-used that it's better to have +;; them all the time than to load them from cl-macs.el. + +(defun cl-map-extents (&rest cl-args) + (apply 'cl-map-overlays cl-args)) + + +;;; Blocks and exits. + +(defalias 'cl-block-wrapper 'identity) +(defalias 'cl-block-throw 'throw) + + +;;; Multiple values. +;; True multiple values are not supported, or even +;; simulated. Instead, cl-multiple-value-bind and friends simply expect +;; the target form to return the values as a list. + +(defalias 'cl-values #'list + "Return multiple values, Common Lisp style. +The arguments of `cl-values' are the values +that the containing function should return. + +\(fn &rest VALUES)") +(put 'cl-values 'byte-optimizer 'byte-compile-inline-expand) + +(defalias 'cl-values-list #'identity + "Return multiple values, Common Lisp style, taken from a list. +LIST specifies the list of values +that the containing function should return. + +\(fn LIST)") +(put 'cl-values-list 'byte-optimizer 'byte-compile-inline-expand) + +(defsubst cl-multiple-value-list (expression) + "Return a list of the multiple values produced by EXPRESSION. +This handles multiple values in Common Lisp style, but it does not +work right when EXPRESSION calls an ordinary Emacs Lisp function +that returns just one value." + expression) + +(defsubst cl-multiple-value-apply (function expression) + "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them. +This handles multiple values in Common Lisp style, but it does not work +right when EXPRESSION calls an ordinary Emacs Lisp function that returns just +one value." + (apply function expression)) + +(defalias 'cl-multiple-value-call 'apply + "Apply FUNCTION to ARGUMENTS, taking multiple values into account. +This implementation only handles the case where there is only one argument.") + +(defsubst cl-nth-value (n expression) + "Evaluate EXPRESSION to get multiple values and return the Nth one. +This handles multiple values in Common Lisp style, but it does not work +right when EXPRESSION calls an ordinary Emacs Lisp function that returns just +one value." + (nth n expression)) + +;;; Declarations. + +(defvar cl-compiling-file nil) +(defun cl-compiling-file () + (or cl-compiling-file + (and (boundp 'byte-compile--outbuffer) + (bufferp (symbol-value 'byte-compile--outbuffer)) + (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) + " *Compiler Output*")))) + +(defvar cl-proclaims-deferred nil) + +(defun cl-proclaim (spec) + (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t) + (push spec cl-proclaims-deferred)) + nil) + +(defmacro cl-declaim (&rest specs) + (let ((body (mapcar (function (lambda (x) (list 'cl-proclaim (list 'quote x)))) + specs))) + (if (cl-compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body) + (cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when + + +;;; Symbols. + +(defun cl-random-time () + (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) + (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i)))) + v)) + +(defvar cl--gensym-counter (* (logand (cl-random-time) 1023) 100)) + + +;;; Numbers. + +(defun cl-floatp-safe (object) + "Return t if OBJECT is a floating point number. +On Emacs versions that lack floating-point support, this function +always returns nil." + (and (numberp object) (not (integerp object)))) + +(defun cl-plusp (number) + "Return t if NUMBER is positive." + (> number 0)) + +(defun cl-minusp (number) + "Return t if NUMBER is negative." + (< number 0)) + +(defun cl-oddp (integer) + "Return t if INTEGER is odd." + (eq (logand integer 1) 1)) + +(defun cl-evenp (integer) + "Return t if INTEGER is even." + (eq (logand integer 1) 0)) + +(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl-random-time))) + +(defconst cl-most-positive-float nil + "The largest value that a Lisp float can hold. +If your system supports infinities, this is the largest finite value. +For IEEE machines, this is approximately 1.79e+308. +Call `cl-float-limits' to set this.") + +(defconst cl-most-negative-float nil + "The largest negative value that a Lisp float can hold. +This is simply -`cl-most-positive-float'. +Call `cl-float-limits' to set this.") + +(defconst cl-least-positive-float nil + "The smallest value greater than zero that a Lisp float can hold. +For IEEE machines, it is about 4.94e-324 if denormals are supported, +or 2.22e-308 if they are not. +Call `cl-float-limits' to set this.") + +(defconst cl-least-negative-float nil + "The smallest value less than zero that a Lisp float can hold. +This is simply -`cl-least-positive-float'. +Call `cl-float-limits' to set this.") + +(defconst cl-least-positive-normalized-float nil + "The smallest normalized Lisp float greater than zero. +This is the smallest value for which IEEE denormalization does not lose +precision. For IEEE machines, this value is about 2.22e-308. +For machines that do not support the concept of denormalization +and gradual underflow, this constant equals `cl-least-positive-float'. +Call `cl-float-limits' to set this.") + +(defconst cl-least-negative-normalized-float nil + "The smallest normalized Lisp float less than zero. +This is simply -`cl-least-positive-normalized-float'. +Call `cl-float-limits' to set this.") + +(defconst cl-float-epsilon nil + "The smallest positive float that adds to 1.0 to give a distinct value. +Adding a number less than this to 1.0 returns 1.0 due to roundoff. +For IEEE machines, epsilon is about 2.22e-16. +Call `cl-float-limits' to set this.") + +(defconst cl-float-negative-epsilon nil + "The smallest positive float that subtracts from 1.0 to give a distinct value. +For IEEE machines, it is about 1.11e-16. +Call `cl-float-limits' to set this.") + + +;;; Sequence functions. + +(defalias 'cl-copy-seq 'copy-sequence) + +(declare-function cl-mapcar-many "cl-extra" (cl-func cl-seqs)) + +(defun cl-mapcar (cl-func cl-x &rest cl-rest) + "Apply FUNCTION to each element of SEQ, and make a list of the results. +If there are several SEQs, FUNCTION is called with that many arguments, +and mapping stops as soon as the shortest list runs out. With just one +SEQ, this is like `mapcar'. With several, it is like the Common Lisp +`mapcar' function extended to arbitrary sequence types. +\n(fn FUNCTION SEQ...)" + (if cl-rest + (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) + (cl-mapcar-many cl-func (cons cl-x cl-rest)) + (let ((cl-res nil) (cl-y (car cl-rest))) + (while (and cl-x cl-y) + (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) + (nreverse cl-res))) + (mapcar cl-func cl-x))) + +(defalias 'cl-svref 'aref) + +;;; List functions. + +(defalias 'cl-first 'car) +(defalias 'cl-second 'cadr) +(defalias 'cl-rest 'cdr) +(defalias 'cl-endp 'null) + +(defun cl-third (x) + "Return the cl-third element of the list X." + (car (cdr (cdr x)))) + +(defun cl-fourth (x) + "Return the cl-fourth element of the list X." + (nth 3 x)) + +(defun cl-fifth (x) + "Return the cl-fifth element of the list X." + (nth 4 x)) + +(defun cl-sixth (x) + "Return the cl-sixth element of the list X." + (nth 5 x)) + +(defun cl-seventh (x) + "Return the cl-seventh element of the list X." + (nth 6 x)) + +(defun cl-eighth (x) + "Return the cl-eighth element of the list X." + (nth 7 x)) + +(defun cl-ninth (x) + "Return the cl-ninth element of the list X." + (nth 8 x)) + +(defun cl-tenth (x) + "Return the cl-tenth element of the list X." + (nth 9 x)) + +(defun cl-caaar (x) + "Return the `car' of the `car' of the `car' of X." + (car (car (car x)))) + +(defun cl-caadr (x) + "Return the `car' of the `car' of the `cdr' of X." + (car (car (cdr x)))) + +(defun cl-cadar (x) + "Return the `car' of the `cdr' of the `car' of X." + (car (cdr (car x)))) + +(defun cl-caddr (x) + "Return the `car' of the `cdr' of the `cdr' of X." + (car (cdr (cdr x)))) + +(defun cl-cdaar (x) + "Return the `cdr' of the `car' of the `car' of X." + (cdr (car (car x)))) + +(defun cl-cdadr (x) + "Return the `cdr' of the `car' of the `cdr' of X." + (cdr (car (cdr x)))) + +(defun cl-cddar (x) + "Return the `cdr' of the `cdr' of the `car' of X." + (cdr (cdr (car x)))) + +(defun cl-cdddr (x) + "Return the `cdr' of the `cdr' of the `cdr' of X." + (cdr (cdr (cdr x)))) + +(defun cl-caaaar (x) + "Return the `car' of the `car' of the `car' of the `car' of X." + (car (car (car (car x))))) + +(defun cl-caaadr (x) + "Return the `car' of the `car' of the `car' of the `cdr' of X." + (car (car (car (cdr x))))) + +(defun cl-caadar (x) + "Return the `car' of the `car' of the `cdr' of the `car' of X." + (car (car (cdr (car x))))) + +(defun cl-caaddr (x) + "Return the `car' of the `car' of the `cdr' of the `cdr' of X." + (car (car (cdr (cdr x))))) + +(defun cl-cadaar (x) + "Return the `car' of the `cdr' of the `car' of the `car' of X." + (car (cdr (car (car x))))) + +(defun cl-cadadr (x) + "Return the `car' of the `cdr' of the `car' of the `cdr' of X." + (car (cdr (car (cdr x))))) + +(defun cl-caddar (x) + "Return the `car' of the `cdr' of the `cdr' of the `car' of X." + (car (cdr (cdr (car x))))) + +(defun cl-cadddr (x) + "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." + (car (cdr (cdr (cdr x))))) + +(defun cl-cdaaar (x) + "Return the `cdr' of the `car' of the `car' of the `car' of X." + (cdr (car (car (car x))))) + +(defun cl-cdaadr (x) + "Return the `cdr' of the `car' of the `car' of the `cdr' of X." + (cdr (car (car (cdr x))))) + +(defun cl-cdadar (x) + "Return the `cdr' of the `car' of the `cdr' of the `car' of X." + (cdr (car (cdr (car x))))) + +(defun cl-cdaddr (x) + "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." + (cdr (car (cdr (cdr x))))) + +(defun cl-cddaar (x) + "Return the `cdr' of the `cdr' of the `car' of the `car' of X." + (cdr (cdr (car (car x))))) + +(defun cl-cddadr (x) + "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." + (cdr (cdr (car (cdr x))))) + +(defun cl-cdddar (x) + "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." + (cdr (cdr (cdr (car x))))) + +(defun cl-cddddr (x) + "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." + (cdr (cdr (cdr (cdr x))))) + +;;(defun last* (x &optional n) +;; "Returns the last link in the list LIST. +;;With optional argument N, returns Nth-to-last link (default 1)." +;; (if n +;; (let ((m 0) (p x)) +;; (while (consp p) (cl-incf m) (pop p)) +;; (if (<= n 0) p +;; (if (< n m) (nthcdr (- m n) x) x))) +;; (while (consp (cdr x)) (pop x)) +;; x)) + +(defun cl-list* (arg &rest rest) + "Return a new list with specified ARGs as elements, consed to last ARG. +Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to +`(cons A (cons B (cons C D)))'. +\n(fn ARG...)" + (declare (compiler-macro cl--compiler-macro-list*)) + (cond ((not rest) arg) + ((not (cdr rest)) (cons arg (car rest))) + (t (let* ((n (length rest)) + (copy (copy-sequence rest)) + (last (nthcdr (- n 2) copy))) + (setcdr last (car (cdr last))) + (cons arg copy))))) +(autoload 'cl--compiler-macro-list* "cl-macs") + +(defun cl-ldiff (list sublist) + "Return a copy of LIST with the tail SUBLIST removed." + (let ((res nil)) + (while (and (consp list) (not (eq list sublist))) + (push (pop list) res)) + (nreverse res))) + +(defun cl-copy-list (list) + "Return a copy of LIST, which may be a dotted list. +The elements of LIST are not copied, just the list structure itself." + (if (consp list) + (let ((res nil)) + (while (consp list) (push (pop list) res)) + (prog1 (nreverse res) (setcdr res list))) + (car list))) + +(defun cl-maclisp-member (item list) + (while (and list (not (equal item (car list)))) (setq list (cdr list))) + list) + +;; Autoloaded, but we have not loaded cl-loaddefs yet. +(declare-function cl-floor "cl-extra" (x &optional y)) +(declare-function cl-ceiling "cl-extra" (x &optional y)) +(declare-function cl-truncate "cl-extra" (x &optional y)) +(declare-function cl-round "cl-extra" (x &optional y)) +(declare-function cl-mod "cl-extra" (x y)) + +(defun cl-adjoin (cl-item cl-list &rest cl-keys) + "Return ITEM consed onto the front of LIST only if it's not already there. +Otherwise, return LIST unmodified. +\nKeywords supported: :test :test-not :key +\n(fn ITEM LIST [KEYWORD VALUE]...)" + (declare (compiler-macro cl--compiler-macro-adjoin)) + (cond ((or (equal cl-keys '(:test eq)) + (and (null cl-keys) (not (numberp cl-item)))) + (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)))) +(autoload 'cl--compiler-macro-adjoin "cl-macs") + +(defun cl-subst (cl-new cl-old cl-tree &rest cl-keys) + "Substitute NEW for OLD everywhere in TREE (non-destructively). +Return a copy of TREE with all elements `eql' to OLD replaced by NEW. +\nKeywords supported: :test :test-not :key +\n(fn NEW OLD TREE [KEYWORD VALUE]...)" + (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) + (apply 'cl-sublis (list (cons cl-old cl-new)) cl-tree cl-keys) + (cl-do-subst cl-new cl-old cl-tree))) + +(defun cl-do-subst (cl-new cl-old cl-tree) + (cond ((eq cl-tree cl-old) cl-new) + ((consp cl-tree) + (let ((a (cl-do-subst cl-new cl-old (car cl-tree))) + (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) + (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) + cl-tree (cons a d)))) + (t cl-tree))) + +(defun cl-acons (key value alist) + "Add KEY and VALUE to ALIST. +Return a new list with (cons KEY VALUE) as car and ALIST as cdr." + (cons (cons key value) alist)) + +(defun cl-pairlis (keys values &optional alist) + "Make an alist from KEYS and VALUES. +Return a new alist composed by associating KEYS to corresponding VALUES; +the process stops as soon as KEYS or VALUES run out. +If ALIST is non-nil, the new pairs are prepended to it." + (nconc (cl-mapcar 'cons keys values) alist)) + + +;;; Miscellaneous. + +;;;###autoload +(progn + ;; Autoload, so autoload.el and font-lock can use it even when CL + ;; is not loaded. + (put 'cl-defun 'doc-string-elt 3) + (put 'cl-defmacro 'doc-string-elt 3) + (put 'cl-defsubst 'doc-string-elt 3) + (put 'cl-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. +(provide 'cl-lib) + +;; Things to do after byte-compiler is loaded. + +(defvar cl-hacked-flag nil) +(defun cl-hack-byte-compiler () + (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form) + (progn + (setq cl-hacked-flag t) ; Do it first, to prevent recursion. + (load "cl-macs" nil t) + (run-hooks 'cl-hack-bytecomp-hook)))) + +;; Try it now in case the compiler has already been loaded. +(cl-hack-byte-compiler) + +;; Also make a hook in case compiler is loaded after this file. +(add-hook 'bytecomp-load-hook 'cl-hack-byte-compiler) + + +;; The following ensures that packages which expect the old-style cl.el +;; will be happy with this one. + +(provide 'cl-lib) + +(run-hooks 'cl-load-hook) + +;; Local variables: +;; byte-compile-dynamic: t +;; byte-compile-warnings: (not cl-functions) +;; End: + +;;; cl-lib.el ends here diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index b75239d2a38..87ae4223737 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -3,23 +3,24 @@ ;;; Code: -;;;### (autoloads (cl-prettyexpand cl-macroexpand-all cl-remprop -;;;;;; cl-do-remf cl-set-getf getf get* tailp list-length nreconc -;;;;;; revappend concatenate subseq cl-float-limits random-state-p -;;;;;; make-random-state random* signum rem* mod* round* truncate* -;;;;;; 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") +;;;### (autoloads (cl-prettyexpand cl-remprop cl-do-remf cl-set-getf +;;;;;; cl-getf cl-get cl-tailp cl-list-length cl-nreconc cl-revappend +;;;;;; cl-concatenate cl-subseq cl-float-limits cl-random-state-p +;;;;;; cl-make-random-state cl-random cl-signum cl-rem cl-mod cl-round +;;;;;; cl-truncate cl-ceiling cl-floor cl-isqrt cl-lcm cl-gcd cl-progv-before +;;;;;; cl-set-frame-visible-p cl-map-overlays cl-map-intervals cl-map-keymap-recursively +;;;;;; cl-notevery cl-notany cl-every cl-some cl-mapcon cl-mapcan +;;;;;; cl-mapl cl-maplist cl-map cl-mapcar-many cl-equalp cl-coerce) +;;;;;; "cl-extra" "cl-extra.el" "6661c504c379dfde0c37a0f8e2ba6568") ;;; Generated autoloads from cl-extra.el -(autoload 'coerce "cl-extra" "\ +(autoload 'cl-coerce "cl-extra" "\ Coerce OBJECT to type TYPE. TYPE is a Common Lisp type specifier. \(fn OBJECT TYPE)" nil nil) -(autoload 'equalp "cl-extra" "\ +(autoload 'cl-equalp "cl-extra" "\ Return t if two Lisp objects have similar structures and contents. This is like `equal', except that it accepts numerically equal numbers of different types (float vs. integer), and also compares @@ -32,57 +33,55 @@ strings case-insensitively. \(fn CL-FUNC CL-SEQS)" nil nil) -(autoload 'map "cl-extra" "\ +(autoload 'cl-map "cl-extra" "\ Map a FUNCTION across one or more SEQUENCEs, returning a sequence. TYPE is the sequence type to return. \(fn TYPE FUNCTION SEQUENCE...)" nil nil) -(autoload 'maplist "cl-extra" "\ +(autoload 'cl-maplist "cl-extra" "\ Map FUNCTION to each sublist of LIST or LISTs. Like `mapcar', except applies to lists and their cdr's rather than to the elements themselves. \(fn FUNCTION LIST...)" nil nil) -(autoload 'mapl "cl-extra" "\ -Like `maplist', but does not accumulate values returned by the function. +(autoload 'cl-mapl "cl-extra" "\ +Like `cl-maplist', but does not accumulate values returned by the function. \(fn FUNCTION LIST...)" nil nil) -(autoload 'mapcan "cl-extra" "\ +(autoload 'cl-mapcan "cl-extra" "\ Like `mapcar', but nconc's together the values returned by the function. \(fn FUNCTION SEQUENCE...)" nil nil) -(autoload 'mapcon "cl-extra" "\ -Like `maplist', but nconc's together the values returned by the function. +(autoload 'cl-mapcon "cl-extra" "\ +Like `cl-maplist', but nconc's together the values returned by the function. \(fn FUNCTION LIST...)" nil nil) -(autoload 'some "cl-extra" "\ +(autoload 'cl-some "cl-extra" "\ Return true if PREDICATE is true of any element of SEQ or SEQs. If so, return the true (non-nil) value returned by PREDICATE. \(fn PREDICATE SEQ...)" nil nil) -(autoload 'every "cl-extra" "\ +(autoload 'cl-every "cl-extra" "\ Return true if PREDICATE is true of every element of SEQ or SEQs. \(fn PREDICATE SEQ...)" nil nil) -(autoload 'notany "cl-extra" "\ +(autoload 'cl-notany "cl-extra" "\ Return true if PREDICATE is false of every element of SEQ or SEQs. \(fn PREDICATE SEQ...)" nil nil) -(autoload 'notevery "cl-extra" "\ +(autoload 'cl-notevery "cl-extra" "\ Return true if PREDICATE is false of some element of SEQ or SEQs. \(fn PREDICATE SEQ...)" nil nil) -(defalias 'cl-map-keymap 'map-keymap) - (autoload 'cl-map-keymap-recursively "cl-extra" "\ @@ -108,124 +107,126 @@ Return true if PREDICATE is false of some element of SEQ or SEQs. \(fn SYMS VALUES)" nil nil) -(autoload 'gcd "cl-extra" "\ +(autoload 'cl-gcd "cl-extra" "\ Return the greatest common divisor of the arguments. \(fn &rest ARGS)" nil nil) -(autoload 'lcm "cl-extra" "\ +(autoload 'cl-lcm "cl-extra" "\ Return the least common multiple of the arguments. \(fn &rest ARGS)" nil nil) -(autoload 'isqrt "cl-extra" "\ +(autoload 'cl-isqrt "cl-extra" "\ Return the integer square root of the argument. \(fn X)" nil nil) -(autoload 'floor* "cl-extra" "\ +(autoload 'cl-floor "cl-extra" "\ Return a list of the floor of X and the fractional part of X. With two arguments, return floor and remainder of their quotient. \(fn X &optional Y)" nil nil) -(autoload 'ceiling* "cl-extra" "\ +(autoload 'cl-ceiling "cl-extra" "\ Return a list of the ceiling of X and the fractional part of X. With two arguments, return ceiling and remainder of their quotient. \(fn X &optional Y)" nil nil) -(autoload 'truncate* "cl-extra" "\ +(autoload 'cl-truncate "cl-extra" "\ Return a list of the integer part of X and the fractional part of X. With two arguments, return truncation and remainder of their quotient. \(fn X &optional Y)" nil nil) -(autoload 'round* "cl-extra" "\ +(autoload 'cl-round "cl-extra" "\ Return a list of X rounded to the nearest integer and the remainder. With two arguments, return rounding and remainder of their quotient. \(fn X &optional Y)" nil nil) -(autoload 'mod* "cl-extra" "\ +(autoload 'cl-mod "cl-extra" "\ The remainder of X divided by Y, with the same sign as Y. \(fn X Y)" nil nil) -(autoload 'rem* "cl-extra" "\ +(autoload 'cl-rem "cl-extra" "\ The remainder of X divided by Y, with the same sign as X. \(fn X Y)" nil nil) -(autoload 'signum "cl-extra" "\ +(autoload 'cl-signum "cl-extra" "\ Return 1 if X is positive, -1 if negative, 0 if zero. \(fn X)" nil nil) -(autoload 'random* "cl-extra" "\ +(autoload 'cl-random "cl-extra" "\ Return a random nonnegative number less than LIM, an integer or float. 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. +(autoload 'cl-make-random-state "cl-extra" "\ +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) -(autoload 'random-state-p "cl-extra" "\ +(autoload 'cl-random-state-p "cl-extra" "\ Return t if OBJECT is a random-state object. \(fn OBJECT)" nil nil) (autoload 'cl-float-limits "cl-extra" "\ Initialize the Common Lisp floating-point parameters. -This sets the values of: `most-positive-float', `most-negative-float', -`least-positive-float', `least-negative-float', `float-epsilon', -`float-negative-epsilon', `least-positive-normalized-float', and -`least-negative-normalized-float'. +This sets the values of: `cl-most-positive-float', `cl-most-negative-float', +`cl-least-positive-float', `cl-least-negative-float', `cl-float-epsilon', +`cl-float-negative-epsilon', `cl-least-positive-normalized-float', and +`cl-least-negative-normalized-float'. \(fn)" nil nil) -(autoload 'subseq "cl-extra" "\ +(autoload 'cl-subseq "cl-extra" "\ Return the subsequence of SEQ from START to END. If END is omitted, it defaults to the length of the sequence. If START or END is negative, it counts from the end. \(fn SEQ START &optional END)" nil nil) -(autoload 'concatenate "cl-extra" "\ +(autoload 'cl-concatenate "cl-extra" "\ Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. \(fn TYPE SEQUENCE...)" nil nil) -(autoload 'revappend "cl-extra" "\ +(autoload 'cl-revappend "cl-extra" "\ Equivalent to (append (reverse X) Y). \(fn X Y)" nil nil) -(autoload 'nreconc "cl-extra" "\ +(autoload 'cl-nreconc "cl-extra" "\ Equivalent to (nconc (nreverse X) Y). \(fn X Y)" nil nil) -(autoload 'list-length "cl-extra" "\ +(autoload 'cl-list-length "cl-extra" "\ Return the length of list X. Return nil if list is circular. \(fn X)" nil nil) -(autoload 'tailp "cl-extra" "\ +(autoload 'cl-tailp "cl-extra" "\ Return true if SUBLIST is a tail of LIST. \(fn SUBLIST LIST)" nil nil) -(autoload 'get* "cl-extra" "\ +(autoload 'cl-get "cl-extra" "\ Return the value of SYMBOL's PROPNAME property, or DEFAULT if none. \(fn SYMBOL PROPNAME &optional DEFAULT)" nil nil) -(autoload 'getf "cl-extra" "\ +(put 'cl-get 'compiler-macro #'cl--compiler-macro-get) + +(autoload 'cl-getf "cl-extra" "\ Search PROPLIST for property PROPNAME; return its value or DEFAULT. PROPLIST is a list of the sort returned by `symbol-plist'. @@ -246,30 +247,6 @@ Remove from SYMBOL's plist the property PROPNAME and its value. \(fn SYMBOL PROPNAME)" nil nil) -(defalias 'remprop 'cl-remprop) - -(defalias 'cl-gethash 'gethash) - -(defalias 'cl-puthash 'puthash) - -(defalias 'cl-remhash 'remhash) - -(defalias 'cl-clrhash 'clrhash) - -(defalias 'cl-maphash 'maphash) - -(defalias 'cl-make-hash-table 'make-hash-table) - -(defalias 'cl-hash-table-p 'hash-table-p) - -(defalias 'cl-hash-table-count 'hash-table-count) - -(autoload 'cl-macroexpand-all "cl-extra" "\ -Expand all macro calls through a Lisp FORM. -This also does some trivial optimizations to make the form prettier. - -\(fn FORM &optional ENV)" nil nil) - (autoload 'cl-prettyexpand "cl-extra" "\ @@ -277,105 +254,127 @@ This also does some trivial optimizations to make the form prettier. ;;;*** -;;;### (autoloads (defsubst* compiler-macroexpand define-compiler-macro -;;;;;; assert check-type typep deftype cl-struct-setf-expander defstruct -;;;;;; define-modify-macro callf2 callf letf* letf rotatef shiftf -;;;;;; remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method -;;;;;; declare the locally multiple-value-setq multiple-value-bind -;;;;;; lexical-let* lexical-let symbol-macrolet macrolet labels -;;;;;; 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") +;;;### (autoloads (cl-defsubst cl-compiler-macroexpand cl-define-compiler-macro +;;;;;; cl-assert cl-check-type cl-typep cl-deftype cl-struct-setf-expander +;;;;;; cl-defstruct cl-define-modify-macro cl-callf2 cl-callf cl-letf* +;;;;;; cl-letf cl-rotatef cl-shiftf cl-remf cl-do-pop cl-psetf cl-setf +;;;;;; cl-get-setf-method cl-defsetf cl-define-setf-expander cl-declare +;;;;;; cl-the cl-locally cl-multiple-value-setq cl-multiple-value-bind +;;;;;; cl-symbol-macrolet cl-macrolet cl-labels cl-flet cl-progv +;;;;;; cl-psetq cl-do-all-symbols cl-do-symbols cl-dotimes cl-dolist +;;;;;; cl-do* cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase +;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when +;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp +;;;;;; cl-gensym) "cl-macs" "cl-macs.el" "9eb287dd2a8d20f1c6459a9d095fa335") ;;; Generated autoloads from cl-macs.el -(autoload 'gensym "cl-macs" "\ +(autoload 'cl-gensym "cl-macs" "\ Generate a new uninterned symbol. The name is made by appending a number to PREFIX, default \"G\". \(fn &optional PREFIX)" nil nil) -(autoload 'gentemp "cl-macs" "\ +(autoload 'cl-gentemp "cl-macs" "\ Generate a new interned symbol with a unique name. The name is made by appending a number to PREFIX, default \"G\". \(fn &optional PREFIX)" nil nil) -(autoload 'defun* "cl-macs" "\ +(autoload 'cl-defun "cl-macs" "\ Define NAME as a function. Like normal `defun', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...). +and BODY is implicitly surrounded by (cl-block NAME ...). + +\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil t) + +(put 'cl-defun 'doc-string-elt '3) -\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil (quote macro)) +(put 'cl-defun 'lisp-indent-function '2) -(autoload 'defmacro* "cl-macs" "\ +(autoload 'cl-defmacro "cl-macs" "\ Define NAME as a macro. Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...). +and BODY is implicitly surrounded by (cl-block NAME ...). -\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil (quote macro)) +\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil t) -(autoload 'function* "cl-macs" "\ +(put 'cl-defmacro 'doc-string-elt '3) + +(put 'cl-defmacro 'lisp-indent-function '2) + +(autoload 'cl-function "cl-macs" "\ Introduce a function. Like normal `function', except that if argument is a lambda form, its argument list allows full Common Lisp conventions. -\(fn FUNC)" nil (quote macro)) +\(fn FUNC)" nil t) + +(autoload 'cl-destructuring-bind "cl-macs" "\ -(autoload 'destructuring-bind "cl-macs" "\ +\(fn ARGS EXPR &rest BODY)" nil t) -\(fn ARGS EXPR &rest BODY)" nil (quote macro)) +(put 'cl-destructuring-bind 'lisp-indent-function '2) -(autoload 'eval-when "cl-macs" "\ +(autoload 'cl-eval-when "cl-macs" "\ Control when BODY is evaluated. If `compile' is in WHEN, BODY is evaluated when compiled at top-level. 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...)" nil (quote macro)) +\(fn (WHEN...) BODY...)" nil t) -(autoload 'load-time-value "cl-macs" "\ +(put 'cl-eval-when 'lisp-indent-function '1) + +(autoload 'cl-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. -\(fn FORM &optional READ-ONLY)" nil (quote macro)) +\(fn FORM &optional READ-ONLY)" nil t) -(autoload 'case "cl-macs" "\ +(autoload 'cl-case "cl-macs" "\ Eval EXPR and choose among clauses on that value. Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared against each key in each KEYLIST; the corresponding BODY is evaluated. -If no clause succeeds, case returns nil. A single atom may be used in +If no clause succeeds, cl-case returns nil. A single atom may be used in 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'. -\(fn EXPR (KEYLIST BODY...)...)" nil (quote macro)) +\(fn EXPR (KEYLIST BODY...)...)" nil t) + +(put 'cl-case 'lisp-indent-function '1) -(autoload 'ecase "cl-macs" "\ -Like `case', but error if no case fits. +(autoload 'cl-ecase "cl-macs" "\ +Like `cl-case', but error if no cl-case fits. `otherwise'-clauses are not allowed. -\(fn EXPR (KEYLIST BODY...)...)" nil (quote macro)) +\(fn EXPR (KEYLIST BODY...)...)" nil t) + +(put 'cl-ecase 'lisp-indent-function '1) -(autoload 'typecase "cl-macs" "\ +(autoload 'cl-typecase "cl-macs" "\ Evals EXPR, chooses among clauses on that value. Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it 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 +cl-typecase returns nil. A TYPE of t or `otherwise' is allowed only in the final clause, and matches if no other keys match. -\(fn EXPR (TYPE BODY...)...)" nil (quote macro)) +\(fn EXPR (TYPE BODY...)...)" nil t) -(autoload 'etypecase "cl-macs" "\ -Like `typecase', but error if no case fits. +(put 'cl-typecase 'lisp-indent-function '1) + +(autoload 'cl-etypecase "cl-macs" "\ +Like `cl-typecase', but error if no case fits. `otherwise'-clauses are not allowed. -\(fn EXPR (TYPE BODY...)...)" nil (quote macro)) +\(fn EXPR (TYPE BODY...)...)" nil t) + +(put 'cl-etypecase 'lisp-indent-function '1) -(autoload 'block "cl-macs" "\ +(autoload 'cl-block "cl-macs" "\ Define a lexically-scoped block named NAME. -NAME may be any symbol. Code inside the BODY forms can call `return-from' +NAME may be any symbol. Code inside the BODY forms can call `cl-return-from' to jump prematurely out of the block. This differs from `catch' and `throw' in two respects: First, the NAME is an unevaluated symbol rather than a quoted symbol or other form; and second, NAME is lexically rather than @@ -383,25 +382,29 @@ dynamically scoped: Only references to it within BODY will work. These references may appear inside macro expansions, but not inside functions called from BODY. -\(fn NAME &rest BODY)" nil (quote macro)) +\(fn NAME &rest BODY)" nil t) + +(put 'cl-block 'lisp-indent-function '1) -(autoload 'return "cl-macs" "\ +(autoload 'cl-return "cl-macs" "\ Return from the block named nil. -This is equivalent to `(return-from nil RESULT)'. +This is equivalent to `(cl-return-from nil RESULT)'. -\(fn &optional RESULT)" nil (quote macro)) +\(fn &optional RESULT)" nil t) -(autoload 'return-from "cl-macs" "\ +(autoload 'cl-return-from "cl-macs" "\ Return from the block named NAME. -This jumps out to the innermost enclosing `(block NAME ...)' form, +This jumps out to the innermost enclosing `(cl-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. -\(fn NAME &optional RESULT)" nil (quote macro)) +\(fn NAME &optional RESULT)" nil t) -(autoload 'loop "cl-macs" "\ -The Common Lisp `loop' macro. +(put 'cl-return-from 'lisp-indent-function '1) + +(autoload 'cl-loop "cl-macs" "\ +The Common Lisp `cl-loop' macro. Valid clauses are: for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR, @@ -414,54 +417,62 @@ Valid clauses are: do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR, finally return EXPR, named NAME. -\(fn CLAUSE...)" nil (quote macro)) +\(fn CLAUSE...)" nil t) + +(autoload 'cl-do "cl-macs" "\ +The Common Lisp `cl-do' loop. + +\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil t) -(autoload 'do "cl-macs" "\ -The Common Lisp `do' loop. +(put 'cl-do 'lisp-indent-function '2) -\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil (quote macro)) +(autoload 'cl-do* "cl-macs" "\ +The Common Lisp `cl-do*' loop. -(autoload 'do* "cl-macs" "\ -The Common Lisp `do*' loop. +\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil t) -\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" nil (quote macro)) +(put 'cl-do* 'lisp-indent-function '2) -(autoload 'dolist "cl-macs" "\ +(autoload 'cl-dolist "cl-macs" "\ Loop over a list. Evaluate BODY with VAR bound to each `car' from LIST, in turn. Then evaluate RESULT to get return value, default nil. An implicit nil block is established around the loop. -\(fn (VAR LIST [RESULT]) BODY...)" nil (quote macro)) +\(fn (VAR LIST [RESULT]) BODY...)" nil t) -(autoload 'dotimes "cl-macs" "\ +(autoload 'cl-dotimes "cl-macs" "\ Loop a certain number of times. Evaluate BODY with VAR bound to successive integers from 0, inclusive, to COUNT, exclusive. Then evaluate RESULT to get return value, default nil. -\(fn (VAR COUNT [RESULT]) BODY...)" nil (quote macro)) +\(fn (VAR COUNT [RESULT]) BODY...)" nil t) -(autoload 'do-symbols "cl-macs" "\ +(autoload 'cl-do-symbols "cl-macs" "\ Loop over all symbols. Evaluate BODY with VAR bound to each interned symbol, or to each symbol from OBARRAY. -\(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil (quote macro)) +\(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil t) -(autoload 'do-all-symbols "cl-macs" "\ +(put 'cl-do-symbols 'lisp-indent-function '1) +(autoload 'cl-do-all-symbols "cl-macs" "\ -\(fn SPEC &rest BODY)" nil (quote macro)) -(autoload 'psetq "cl-macs" "\ +\(fn SPEC &rest BODY)" nil t) + +(put 'cl-do-all-symbols 'lisp-indent-function '1) + +(autoload 'cl-psetq "cl-macs" "\ Set SYMs to the values VALs in parallel. 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 ...)" nil (quote macro)) +\(fn SYM VAL SYM VAL ...)" nil t) -(autoload 'progv "cl-macs" "\ +(autoload 'cl-progv "cl-macs" "\ Bind SYMBOLS to VALUES dynamically in BODY. The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists. Each symbol in the first list is bound to the corresponding value in the @@ -469,224 +480,228 @@ 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. -\(fn SYMBOLS VALUES &rest BODY)" nil (quote macro)) +\(fn SYMBOLS VALUES &rest BODY)" nil t) + +(put 'cl-progv 'lisp-indent-function '2) -(autoload 'flet "cl-macs" "\ +(autoload 'cl-flet "cl-macs" "\ Make temporary function definitions. -This is an analogue of `let' that operates on the function cell of FUNC -rather than its value cell. The FORMs are evaluated with the specified -function definitions in place, then the definitions are undone (the FUNCs -go back to their previous definitions, or lack thereof). +Like `cl-labels' but the definitions are not recursive. -\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil (quote macro)) +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil t) -(autoload 'labels "cl-macs" "\ +(put 'cl-flet 'lisp-indent-function '1) + +(autoload 'cl-labels "cl-macs" "\ Make temporary function bindings. -This is like `flet', except the bindings are lexical instead of dynamic. -Unlike `flet', this macro is fully compliant with the Common Lisp standard. +The bindings can be recursive. Assumes the use of `lexical-binding'. + +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil t) -\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil (quote macro)) +(put 'cl-labels 'lisp-indent-function '1) -(autoload 'macrolet "cl-macs" "\ +(autoload 'cl-macrolet "cl-macs" "\ Make temporary macro definitions. -This is like `flet', but for macros instead of functions. +This is like `cl-flet', but for macros instead of functions. + +\(fn ((NAME ARGLIST BODY...) ...) FORM...)" nil t) -\(fn ((NAME ARGLIST BODY...) ...) FORM...)" nil (quote macro)) +(put 'cl-macrolet 'lisp-indent-function '1) -(autoload 'symbol-macrolet "cl-macs" "\ +(autoload 'cl-symbol-macrolet "cl-macs" "\ Make symbol macro definitions. 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...)" nil (quote macro)) - -(autoload 'lexical-let "cl-macs" "\ -Like `let', but lexically scoped. -The main visible difference is that lambdas inside BODY will create -lexical closures as in Common Lisp. - -\(fn BINDINGS BODY)" nil (quote macro)) +by EXPANSION, and (setq NAME ...) will act like (cl-setf EXPANSION ...). -(autoload 'lexical-let* "cl-macs" "\ -Like `let*', but lexically scoped. -The main visible difference is that lambdas inside BODY, and in -successive bindings within BINDINGS, will create lexical closures -as in Common Lisp. This is similar to the behavior of `let*' in -Common Lisp. +\(fn ((NAME EXPANSION) ...) FORM...)" nil t) -\(fn BINDINGS BODY)" nil (quote macro)) +(put 'cl-symbol-macrolet 'lisp-indent-function '1) -(autoload 'multiple-value-bind "cl-macs" "\ +(autoload 'cl-multiple-value-bind "cl-macs" "\ Collect multiple return values. FORM must return a list; the BODY is then executed with the first N elements of this list bound (`let'-style) to each of the symbols SYM in turn. This -is analogous to the Common Lisp `multiple-value-bind' macro, using lists to -simulate true multiple return values. For compatibility, (values A B C) is +is analogous to the Common Lisp `cl-multiple-value-bind' macro, using lists to +simulate true multiple return values. For compatibility, (cl-values A B C) is a synonym for (list A B C). -\(fn (SYM...) FORM BODY)" nil (quote macro)) +\(fn (SYM...) FORM BODY)" nil t) -(autoload 'multiple-value-setq "cl-macs" "\ +(put 'cl-multiple-value-bind 'lisp-indent-function '2) + +(autoload 'cl-multiple-value-setq "cl-macs" "\ Collect multiple return values. FORM must return a list; the first N elements of this list are stored in each of the symbols SYM in turn. This is analogous to the Common Lisp -`multiple-value-setq' macro, using lists to simulate true multiple return -values. For compatibility, (values A B C) is a synonym for (list A B C). +`cl-multiple-value-setq' macro, using lists to simulate true multiple return +values. For compatibility, (cl-values A B C) is a synonym for (list A B C). + +\(fn (SYM...) FORM)" nil t) + +(put 'cl-multiple-value-setq 'lisp-indent-function '1) -\(fn (SYM...) FORM)" nil (quote macro)) +(autoload 'cl-locally "cl-macs" "\ -(autoload 'locally "cl-macs" "\ +\(fn &rest BODY)" nil t) -\(fn &rest BODY)" nil (quote macro)) +(autoload 'cl-the "cl-macs" "\ -(autoload 'the "cl-macs" "\ +\(fn TYPE FORM)" nil t) -\(fn TYPE FORM)" nil (quote macro)) +(put 'cl-the 'lisp-indent-function '1) -(autoload 'declare "cl-macs" "\ +(autoload 'cl-declare "cl-macs" "\ Declare SPECS about the current function while compiling. For instance - (declare (warn 0)) + (cl-declare (warn 0)) will turn off byte-compile warnings in the function. See Info node `(cl)Declarations' for details. -\(fn &rest SPECS)" nil (quote macro)) +\(fn &rest SPECS)" nil t) -(autoload 'define-setf-method "cl-macs" "\ -Define a `setf' method. -This method shows how to handle `setf's to places of the form (NAME ARGS...). +(autoload 'cl-define-setf-expander "cl-macs" "\ +Define a `cl-setf' method. +This method shows how to handle `cl-setf's to places of the form (NAME ARGS...). The argument forms ARGS are bound according to ARGLIST, as if NAME were going to be expanded as a macro, then the BODY forms are executed and must return a list of five elements: a temporary-variables list, a value-forms 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. +form. See `cl-defsetf' for a simpler way to define most setf-methods. -\(fn NAME ARGLIST BODY...)" nil (quote macro)) +\(fn NAME ARGLIST BODY...)" nil t) -(autoload 'defsetf "cl-macs" "\ -Define a `setf' method. -This macro is an easy-to-use substitute for `define-setf-method' that works -well for simple place forms. In the simple `defsetf' form, `setf's of -the form (setf (NAME ARGS...) VAL) are transformed to function or macro +(autoload 'cl-defsetf "cl-macs" "\ +Define a `cl-setf' method. +This macro is an easy-to-use substitute for `cl-define-setf-expander' that works +well for simple place forms. In the simple `cl-defsetf' form, `cl-setf's of +the form (cl-setf (NAME ARGS...) VAL) are transformed to function or macro calls of the form (FUNC ARGS... VAL). Example: - (defsetf aref aset) + (cl-defsetf aref aset) -Alternate form: (defsetf NAME ARGLIST (STORE) BODY...). -Here, the above `setf' call is expanded by binding the argument forms ARGS +Alternate form: (cl-defsetf NAME ARGLIST (STORE) BODY...). +Here, the above `cl-setf' call is expanded by binding the argument forms ARGS according to ARGLIST, binding the value form VAL to STORE, then executing -BODY, which must return a Lisp form that does the necessary `setf' operation. +BODY, which must return a Lisp form that does the necessary `cl-setf' operation. Actually, ARGLIST and STORE may be bound to temporary variables which are introduced automatically to preserve proper execution order of the arguments. Example: - (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v)) + (cl-defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v)) -\(fn NAME [FUNC | ARGLIST (STORE) BODY...])" nil (quote macro)) +\(fn NAME [FUNC | ARGLIST (STORE) BODY...])" nil t) -(autoload 'get-setf-method "cl-macs" "\ +(autoload 'cl-get-setf-method "cl-macs" "\ Return a list of five values describing the setf-method for PLACE. PLACE may be any Lisp form which can appear as the PLACE argument to -a macro like `setf' or `incf'. +a macro like `cl-setf' or `cl-incf'. \(fn PLACE &optional ENV)" nil nil) -(autoload 'setf "cl-macs" "\ +(autoload 'cl-setf "cl-macs" "\ Set each PLACE to the value of its VAL. This is a generalized version of `setq'; the PLACEs may be symbolic references such as (car x) or (aref x i), as well as plain symbols. -For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y). +For example, (cl-setf (cl-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 ...)" nil (quote macro)) +\(fn PLACE VAL PLACE VAL ...)" nil t) -(autoload 'psetf "cl-macs" "\ +(autoload 'cl-psetf "cl-macs" "\ Set PLACEs to the values VALs in parallel. -This is like `setf', except that all VAL forms are evaluated (in order) +This is like `cl-setf', except that all VAL forms are evaluated (in order) before assigning any PLACEs to the corresponding values. -\(fn PLACE VAL PLACE VAL ...)" nil (quote macro)) +\(fn PLACE VAL PLACE VAL ...)" nil t) (autoload 'cl-do-pop "cl-macs" "\ \(fn PLACE)" nil nil) -(autoload 'remf "cl-macs" "\ +(autoload 'cl-remf "cl-macs" "\ Remove TAG from property list PLACE. -PLACE may be a symbol, or any generalized variable allowed by `setf'. +PLACE may be a symbol, or any generalized variable allowed by `cl-setf'. The form returns true if TAG was found and removed, nil otherwise. -\(fn PLACE TAG)" nil (quote macro)) +\(fn PLACE TAG)" nil t) -(autoload 'shiftf "cl-macs" "\ +(autoload 'cl-shiftf "cl-macs" "\ Shift left among PLACEs. -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'. +Example: (cl-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 `cl-setf'. -\(fn PLACE... VAL)" nil (quote macro)) +\(fn PLACE... VAL)" nil t) -(autoload 'rotatef "cl-macs" "\ +(autoload 'cl-rotatef "cl-macs" "\ Rotate left among PLACEs. -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'. +Example: (cl-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 `cl-setf'. -\(fn PLACE...)" nil (quote macro)) +\(fn PLACE...)" nil t) -(autoload 'letf "cl-macs" "\ +(autoload 'cl-letf "cl-macs" "\ Temporarily bind to PLACEs. This is the analogue of `let', but with generalized variables (in the -sense of `setf') for the PLACEs. Each PLACE is set to the corresponding +sense of `cl-setf') for the PLACEs. Each PLACE is set to the corresponding VALUE, then the BODY forms are executed. On exit, either normally or because of a `throw' or error, the PLACEs are set back to their original values. Note that this macro is *not* available in Common Lisp. As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', the PLACE is not modified before executing BODY. -\(fn ((PLACE VALUE) ...) BODY...)" nil (quote macro)) +\(fn ((PLACE VALUE) ...) BODY...)" nil t) -(autoload 'letf* "cl-macs" "\ +(put 'cl-letf 'lisp-indent-function '1) + +(autoload 'cl-letf* "cl-macs" "\ Temporarily bind to PLACEs. This is the analogue of `let*', but with generalized variables (in the -sense of `setf') for the PLACEs. Each PLACE is set to the corresponding +sense of `cl-setf') for the PLACEs. Each PLACE is set to the corresponding VALUE, then the BODY forms are executed. On exit, either normally or because of a `throw' or error, the PLACEs are set back to their original values. Note that this macro is *not* available in Common Lisp. As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', the PLACE is not modified before executing BODY. -\(fn ((PLACE VALUE) ...) BODY...)" nil (quote macro)) +\(fn ((PLACE VALUE) ...) BODY...)" nil t) + +(put 'cl-letf* 'lisp-indent-function '1) -(autoload 'callf "cl-macs" "\ +(autoload 'cl-callf "cl-macs" "\ Set PLACE to (FUNC PLACE ARGS...). FUNC should be an unquoted function name. PLACE may be a symbol, -or any generalized variable allowed by `setf'. +or any generalized variable allowed by `cl-setf'. + +\(fn FUNC PLACE ARGS...)" nil t) -\(fn FUNC PLACE ARGS...)" nil (quote macro)) +(put 'cl-callf 'lisp-indent-function '2) -(autoload 'callf2 "cl-macs" "\ +(autoload 'cl-callf2 "cl-macs" "\ Set PLACE to (FUNC ARG1 PLACE ARGS...). -Like `callf', but PLACE is the second argument of FUNC, not the first. +Like `cl-callf', but PLACE is the second argument of FUNC, not the first. -\(fn FUNC ARG1 PLACE ARGS...)" nil (quote macro)) +\(fn FUNC ARG1 PLACE ARGS...)" nil t) -(autoload 'define-modify-macro "cl-macs" "\ -Define a `setf'-like modify macro. +(put 'cl-callf2 'lisp-indent-function '3) + +(autoload 'cl-define-modify-macro "cl-macs" "\ +Define a `cl-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)) +) +from ARGLIST using FUNC: (cl-define-modify-macro cl-incf (&optional (n 1)) +) -\(fn NAME ARGLIST FUNC &optional DOC)" nil (quote macro)) +\(fn NAME ARGLIST FUNC &optional DOC)" nil t) -(autoload 'defstruct "cl-macs" "\ +(autoload 'cl-defstruct "cl-macs" "\ Define a struct type. This macro defines a new data type called NAME that stores data in SLOTs. It defines a `make-NAME' constructor, a `copy-NAME' copier, a `NAME-p' predicate, and slot accessors named `NAME-SLOT'. -You can use the accessors to set the corresponding slots, via `setf'. +You can use the accessors to set the corresponding slots, via `cl-setf'. NAME may instead take the form (NAME OPTIONS...), where each OPTION is either a single keyword or (KEYWORD VALUE). @@ -695,43 +710,47 @@ See Info node `(cl)Structures' for a list of valid keywords. Each SLOT may instead take the form (SLOT SLOT-OPTS...), where SLOT-OPTS are keyword-value pairs for that slot. Currently, only one keyword is supported, `:read-only'. If this has a non-nil -value, that slot cannot be set via `setf'. +value, that slot cannot be set via `cl-setf'. + +\(fn NAME SLOTS...)" nil t) -\(fn NAME SLOTS...)" nil (quote macro)) +(put 'cl-defstruct 'doc-string-elt '2) (autoload 'cl-struct-setf-expander "cl-macs" "\ \(fn X NAME ACCESSOR PRED-FORM POS)" nil nil) -(autoload 'deftype "cl-macs" "\ +(autoload 'cl-deftype "cl-macs" "\ Define NAME as a new data type. -The type name can then be used in `typecase', `check-type', etc. +The type name can then be used in `cl-typecase', `cl-check-type', etc. + +\(fn NAME ARGLIST &rest BODY)" nil t) -\(fn NAME ARGLIST &rest BODY)" nil (quote macro)) +(put 'cl-deftype 'doc-string-elt '3) -(autoload 'typep "cl-macs" "\ +(autoload 'cl-typep "cl-macs" "\ Check that OBJECT is of type TYPE. TYPE is a Common Lisp-style type specifier. \(fn OBJECT TYPE)" nil nil) -(autoload 'check-type "cl-macs" "\ +(autoload 'cl-check-type "cl-macs" "\ Verify that FORM is of type TYPE; signal an error if not. STRING is an optional description of the desired type. -\(fn FORM TYPE &optional STRING)" nil (quote macro)) +\(fn FORM TYPE &optional STRING)" nil t) -(autoload 'assert "cl-macs" "\ +(autoload 'cl-assert "cl-macs" "\ Verify that FORM returns non-nil; signal an error if not. 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. -\(fn FORM &optional SHOW-ARGS STRING &rest ARGS)" nil (quote macro)) +\(fn FORM &optional SHOW-ARGS STRING &rest ARGS)" nil t) -(autoload 'define-compiler-macro "cl-macs" "\ +(autoload 'cl-define-compiler-macro "cl-macs" "\ Define a compiler-only macro. This is like `defmacro', but macro expansion occurs only if the call to FUNC is compiled (i.e., not interpreted). Compiler macros should be used @@ -743,51 +762,53 @@ 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. -\(fn FUNC ARGS &rest BODY)" nil (quote macro)) +\(fn FUNC ARGS &rest BODY)" nil t) -(autoload 'compiler-macroexpand "cl-macs" "\ +(autoload 'cl-compiler-macroexpand "cl-macs" "\ \(fn FORM)" nil nil) -(autoload 'defsubst* "cl-macs" "\ +(autoload 'cl-defsubst "cl-macs" "\ Define NAME as a function. Like `defun', except the function is automatically declared `inline', ARGLIST allows full Common Lisp conventions, and BODY is implicitly -surrounded by (block NAME ...). +surrounded by (cl-block NAME ...). -\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil (quote macro)) +\(fn NAME ARGLIST [DOCSTRING] BODY...)" nil t) ;;;*** -;;;### (autoloads (tree-equal nsublis sublis nsubst-if-not nsubst-if -;;;;;; 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* -;;;;;; 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") +;;;### (autoloads (cl-tree-equal cl-nsublis cl-sublis cl-nsubst-if-not +;;;;;; cl-nsubst-if cl-nsubst cl-subst-if-not cl-subst-if cl-subsetp +;;;;;; cl-nset-exclusive-or cl-set-exclusive-or cl-nset-difference +;;;;;; cl-set-difference cl-nintersection cl-intersection cl-nunion +;;;;;; cl-union cl-rassoc-if-not cl-rassoc-if cl-rassoc cl-assoc-if-not +;;;;;; cl-assoc-if cl-assoc cl--adjoin cl-member-if-not cl-member-if +;;;;;; cl-member cl-merge cl-stable-sort cl-sort cl-search cl-mismatch +;;;;;; cl-count-if-not cl-count-if cl-count cl-position-if-not cl-position-if +;;;;;; cl-position cl-find-if-not cl-find-if cl-find cl-nsubstitute-if-not +;;;;;; cl-nsubstitute-if cl-nsubstitute cl-substitute-if-not cl-substitute-if +;;;;;; cl-substitute cl-delete-duplicates cl-remove-duplicates cl-delete-if-not +;;;;;; cl-delete-if cl-delete cl-remove-if-not cl-remove-if cl-remove +;;;;;; cl-replace cl-fill cl-reduce) "cl-seq" "cl-seq.el" "8877479cb008b43a94098f3e6ec85d91") ;;; Generated autoloads from cl-seq.el -(autoload 'reduce "cl-seq" "\ +(autoload 'cl-reduce "cl-seq" "\ Reduce two-argument FUNCTION across SEQ. Keywords supported: :start :end :from-end :initial-value :key \(fn FUNCTION SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'fill "cl-seq" "\ +(autoload 'cl-fill "cl-seq" "\ Fill the elements of SEQ with ITEM. Keywords supported: :start :end \(fn SEQ ITEM [KEYWORD VALUE]...)" nil nil) -(autoload 'replace "cl-seq" "\ +(autoload 'cl-replace "cl-seq" "\ Replace the elements of SEQ1 with the elements of SEQ2. SEQ1 is destructively modified, then returned. @@ -795,7 +816,7 @@ Keywords supported: :start1 :end1 :start2 :end2 \(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) -(autoload 'remove* "cl-seq" "\ +(autoload 'cl-remove "cl-seq" "\ Remove all occurrences of ITEM in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -804,7 +825,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'remove-if "cl-seq" "\ +(autoload 'cl-remove-if "cl-seq" "\ Remove all items satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -813,7 +834,7 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'remove-if-not "cl-seq" "\ +(autoload 'cl-remove-if-not "cl-seq" "\ Remove all items not satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -822,7 +843,7 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'delete* "cl-seq" "\ +(autoload 'cl-delete "cl-seq" "\ Remove all occurrences of ITEM in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -830,7 +851,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'delete-if "cl-seq" "\ +(autoload 'cl-delete-if "cl-seq" "\ Remove all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -838,7 +859,7 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'delete-if-not "cl-seq" "\ +(autoload 'cl-delete-if-not "cl-seq" "\ Remove all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -846,21 +867,21 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'remove-duplicates "cl-seq" "\ +(autoload 'cl-remove-duplicates "cl-seq" "\ Return a copy of SEQ with all duplicate elements removed. Keywords supported: :test :test-not :key :start :end :from-end \(fn SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'delete-duplicates "cl-seq" "\ +(autoload 'cl-delete-duplicates "cl-seq" "\ Remove all duplicate elements from SEQ (destructively). Keywords supported: :test :test-not :key :start :end :from-end \(fn SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'substitute "cl-seq" "\ +(autoload 'cl-substitute "cl-seq" "\ Substitute NEW for OLD in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -869,7 +890,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn NEW OLD SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'substitute-if "cl-seq" "\ +(autoload 'cl-substitute-if "cl-seq" "\ Substitute NEW for all items satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -878,7 +899,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'substitute-if-not "cl-seq" "\ +(autoload 'cl-substitute-if-not "cl-seq" "\ Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -887,7 +908,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'nsubstitute "cl-seq" "\ +(autoload 'cl-nsubstitute "cl-seq" "\ Substitute NEW for OLD in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -895,7 +916,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn NEW OLD SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'nsubstitute-if "cl-seq" "\ +(autoload 'cl-nsubstitute-if "cl-seq" "\ Substitute NEW for all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -903,7 +924,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'nsubstitute-if-not "cl-seq" "\ +(autoload 'cl-nsubstitute-if-not "cl-seq" "\ Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -911,7 +932,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'find "cl-seq" "\ +(autoload 'cl-find "cl-seq" "\ Find the first occurrence of ITEM in SEQ. Return the matching ITEM, or nil if not found. @@ -919,7 +940,7 @@ Keywords supported: :test :test-not :key :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'find-if "cl-seq" "\ +(autoload 'cl-find-if "cl-seq" "\ Find the first item satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. @@ -927,7 +948,7 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'find-if-not "cl-seq" "\ +(autoload 'cl-find-if-not "cl-seq" "\ Find the first item not satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. @@ -935,7 +956,7 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'position "cl-seq" "\ +(autoload 'cl-position "cl-seq" "\ Find the first occurrence of ITEM in SEQ. Return the index of the matching item, or nil if not found. @@ -943,7 +964,7 @@ Keywords supported: :test :test-not :key :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'position-if "cl-seq" "\ +(autoload 'cl-position-if "cl-seq" "\ Find the first item satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. @@ -951,7 +972,7 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'position-if-not "cl-seq" "\ +(autoload 'cl-position-if-not "cl-seq" "\ Find the first item not satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. @@ -959,28 +980,28 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'count "cl-seq" "\ +(autoload 'cl-count "cl-seq" "\ Count the number of occurrences of ITEM in SEQ. Keywords supported: :test :test-not :key :start :end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'count-if "cl-seq" "\ +(autoload 'cl-count-if "cl-seq" "\ Count the number of items satisfying PREDICATE in SEQ. Keywords supported: :key :start :end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'count-if-not "cl-seq" "\ +(autoload 'cl-count-if-not "cl-seq" "\ Count the number of items not satisfying PREDICATE in SEQ. Keywords supported: :key :start :end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload 'mismatch "cl-seq" "\ +(autoload 'cl-mismatch "cl-seq" "\ Compare SEQ1 with SEQ2, return index of first mismatching element. Return nil if the sequences match. If one sequence is a prefix of the other, the return value indicates the end of the shorter sequence. @@ -989,7 +1010,7 @@ Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end \(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) -(autoload 'search "cl-seq" "\ +(autoload 'cl-search "cl-seq" "\ Search for SEQ1 as a subsequence of SEQ2. Return the index of the leftmost element of the first match found; return nil if there are no matches. @@ -998,7 +1019,7 @@ Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end \(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) -(autoload 'sort* "cl-seq" "\ +(autoload 'cl-sort "cl-seq" "\ Sort the argument SEQ according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. @@ -1006,7 +1027,7 @@ Keywords supported: :key \(fn SEQ PREDICATE [KEYWORD VALUE]...)" nil nil) -(autoload 'stable-sort "cl-seq" "\ +(autoload 'cl-stable-sort "cl-seq" "\ Sort the argument SEQ stably according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. @@ -1014,7 +1035,7 @@ Keywords supported: :key \(fn SEQ PREDICATE [KEYWORD VALUE]...)" nil nil) -(autoload 'merge "cl-seq" "\ +(autoload 'cl-merge "cl-seq" "\ Destructively merge the two sequences to produce a new sequence. TYPE is the sequence type to return, SEQ1 and SEQ2 are the two argument sequences, and PREDICATE is a `less-than' predicate on the elements. @@ -1023,7 +1044,7 @@ Keywords supported: :key \(fn TYPE SEQ1 SEQ2 PREDICATE [KEYWORD VALUE]...)" nil nil) -(autoload 'member* "cl-seq" "\ +(autoload 'cl-member "cl-seq" "\ Find the first occurrence of ITEM in LIST. Return the sublist of LIST whose car is ITEM. @@ -1031,7 +1052,9 @@ Keywords supported: :test :test-not :key \(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'member-if "cl-seq" "\ +(put 'cl-member 'compiler-macro #'cl--compiler-macro-member) + +(autoload 'cl-member-if "cl-seq" "\ Find the first item satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. @@ -1039,7 +1062,7 @@ Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'member-if-not "cl-seq" "\ +(autoload 'cl-member-if-not "cl-seq" "\ Find the first item not satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. @@ -1047,54 +1070,56 @@ 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) -(autoload 'assoc* "cl-seq" "\ +(autoload 'cl-assoc "cl-seq" "\ Find the first item whose car matches ITEM in LIST. Keywords supported: :test :test-not :key \(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'assoc-if "cl-seq" "\ +(put 'cl-assoc 'compiler-macro #'cl--compiler-macro-assoc) + +(autoload 'cl-assoc-if "cl-seq" "\ Find the first item whose car satisfies PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'assoc-if-not "cl-seq" "\ +(autoload 'cl-assoc-if-not "cl-seq" "\ Find the first item whose car does not satisfy PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'rassoc* "cl-seq" "\ +(autoload 'cl-rassoc "cl-seq" "\ Find the first item whose cdr matches ITEM in LIST. Keywords supported: :test :test-not :key \(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'rassoc-if "cl-seq" "\ +(autoload 'cl-rassoc-if "cl-seq" "\ Find the first item whose cdr satisfies PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'rassoc-if-not "cl-seq" "\ +(autoload 'cl-rassoc-if-not "cl-seq" "\ Find the first item whose cdr does not satisfy PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload 'union "cl-seq" "\ +(autoload 'cl-union "cl-seq" "\ Combine LIST1 and LIST2 using a set-union operation. The resulting list contains all items that appear in either LIST1 or LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -1104,7 +1129,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'nunion "cl-seq" "\ +(autoload 'cl-nunion "cl-seq" "\ Combine LIST1 and LIST2 using a set-union operation. The resulting list contains all items that appear in either LIST1 or LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1114,7 +1139,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'intersection "cl-seq" "\ +(autoload 'cl-intersection "cl-seq" "\ Combine LIST1 and LIST2 using a set-intersection operation. The resulting list contains all items that appear in both LIST1 and LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -1124,7 +1149,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'nintersection "cl-seq" "\ +(autoload 'cl-nintersection "cl-seq" "\ Combine LIST1 and LIST2 using a set-intersection operation. The resulting list contains all items that appear in both LIST1 and LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1134,7 +1159,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'set-difference "cl-seq" "\ +(autoload 'cl-set-difference "cl-seq" "\ Combine LIST1 and LIST2 using a set-difference operation. The resulting list contains all items that appear in LIST1 but not LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -1144,7 +1169,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'nset-difference "cl-seq" "\ +(autoload 'cl-nset-difference "cl-seq" "\ Combine LIST1 and LIST2 using a set-difference operation. The resulting list contains all items that appear in LIST1 but not LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1154,7 +1179,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'set-exclusive-or "cl-seq" "\ +(autoload 'cl-set-exclusive-or "cl-seq" "\ Combine LIST1 and LIST2 using a set-exclusive-or operation. The resulting list contains all items appearing in exactly one of LIST1, LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -1164,7 +1189,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'nset-exclusive-or "cl-seq" "\ +(autoload 'cl-nset-exclusive-or "cl-seq" "\ Combine LIST1 and LIST2 using a set-exclusive-or operation. The resulting list contains all items appearing in exactly one of LIST1, LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1174,7 +1199,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'subsetp "cl-seq" "\ +(autoload 'cl-subsetp "cl-seq" "\ Return true if LIST1 is a subset of LIST2. I.e., if every element of LIST1 also appears in LIST2. @@ -1182,7 +1207,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload 'subst-if "cl-seq" "\ +(autoload 'cl-subst-if "cl-seq" "\ Substitute NEW for elements matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all matching elements replaced by NEW. @@ -1190,7 +1215,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload 'subst-if-not "cl-seq" "\ +(autoload 'cl-subst-if-not "cl-seq" "\ Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all non-matching elements replaced by NEW. @@ -1198,7 +1223,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload 'nsubst "cl-seq" "\ +(autoload 'cl-nsubst "cl-seq" "\ Substitute NEW for OLD everywhere in TREE (destructively). Any element of TREE which is `eql' to OLD is changed to NEW (via a call to `setcar'). @@ -1207,7 +1232,7 @@ Keywords supported: :test :test-not :key \(fn NEW OLD TREE [KEYWORD VALUE]...)" nil nil) -(autoload 'nsubst-if "cl-seq" "\ +(autoload 'cl-nsubst-if "cl-seq" "\ Substitute NEW for elements matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). @@ -1215,7 +1240,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload 'nsubst-if-not "cl-seq" "\ +(autoload 'cl-nsubst-if-not "cl-seq" "\ Substitute NEW for elements not matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). @@ -1223,7 +1248,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload 'sublis "cl-seq" "\ +(autoload 'cl-sublis "cl-seq" "\ Perform substitutions indicated by ALIST in TREE (non-destructively). Return a copy of TREE with all matching elements replaced. @@ -1231,7 +1256,7 @@ Keywords supported: :test :test-not :key \(fn ALIST TREE [KEYWORD VALUE]...)" nil nil) -(autoload 'nsublis "cl-seq" "\ +(autoload 'cl-nsublis "cl-seq" "\ Perform substitutions indicated by ALIST in TREE (destructively). Any matching element of TREE is changed via a call to `setcar'. @@ -1239,7 +1264,7 @@ Keywords supported: :test :test-not :key \(fn ALIST TREE [KEYWORD VALUE]...)" nil nil) -(autoload 'tree-equal "cl-seq" "\ +(autoload 'cl-tree-equal "cl-seq" "\ Return t if trees TREE1 and TREE2 have `eql' leaves. Atoms are compared by `eql'; cons cells are compared recursively. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index f58fc70053f..60f1189718b 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1,4 +1,4 @@ -;;; cl-macs.el --- Common Lisp macros +;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t; coding: utf-8 -*- ;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. @@ -43,89 +43,79 @@ ;;; Code: -(require 'cl) +(require 'cl-lib) +(require 'macroexp) (defmacro cl-pop2 (place) - (list 'prog1 (list 'car (list 'cdr place)) - (list 'setq place (list 'cdr (list 'cdr place))))) -(put 'cl-pop2 'edebug-form-spec 'edebug-sexps) + (declare (debug edebug-sexps)) + `(prog1 (car (cdr ,place)) + (setq ,place (cdr (cdr ,place))))) (defvar cl-optimize-safety) (defvar cl-optimize-speed) -;; This kludge allows macros which use cl-transform-function-property +;; This kludge allows macros which use cl--transform-function-property ;; to be called at compile-time. -(require - (progn - (or (fboundp 'cl-transform-function-property) - (defalias 'cl-transform-function-property - (function (lambda (n p f) - (list 'put (list 'quote n) (list 'quote p) - (list 'function (cons 'lambda f))))))) - (car (or features (setq features (list 'cl-kludge)))))) - +(eval-and-compile + (or (fboundp 'cl--transform-function-property) + (defun cl--transform-function-property (n p f) + `(put ',n ',p #'(lambda . ,f))))) ;;; Initialization. -(defvar cl-old-bc-file-form nil) - -;;; Some predicates for analyzing Lisp forms. These are used by various -;;; macro expanders to optimize the results in certain common cases. +;;; Some predicates for analyzing Lisp forms. +;; These are used by various +;; macro expanders to optimize the results in certain common cases. -(defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max +(defconst cl--simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max car-safe cdr-safe progn prog1 prog2)) -(defconst cl-safe-funcs '(* / % length memq list vector vectorp +(defconst cl--safe-funcs '(* / % length memq list vector vectorp < > <= >= = error)) -;;; Check if no side effects, and executes quickly. -(defun cl-simple-expr-p (x &optional size) +(defun cl--simple-expr-p (x &optional size) + "Check if no side effects, and executes quickly." (or size (setq size 10)) - (if (and (consp x) (not (memq (car x) '(quote function function*)))) + (if (and (consp x) (not (memq (car x) '(quote function cl-function)))) (and (symbolp (car x)) - (or (memq (car x) cl-simple-funcs) + (or (memq (car x) cl--simple-funcs) (get (car x) 'side-effect-free)) (progn (setq size (1- size)) (while (and (setq x (cdr x)) - (setq size (cl-simple-expr-p (car x) size)))) + (setq size (cl--simple-expr-p (car x) size)))) (and (null x) (>= size 0) size))) (and (> size 0) (1- size)))) -(defun cl-simple-exprs-p (xs) - (while (and xs (cl-simple-expr-p (car xs))) +(defun cl--simple-exprs-p (xs) + (while (and xs (cl--simple-expr-p (car xs))) (setq xs (cdr xs))) (not xs)) -;;; Check if no side effects. -(defun cl-safe-expr-p (x) - (or (not (and (consp x) (not (memq (car x) '(quote function function*))))) +(defun cl--safe-expr-p (x) + "Check if no side effects." + (or (not (and (consp x) (not (memq (car x) '(quote function cl-function))))) (and (symbolp (car x)) - (or (memq (car x) cl-simple-funcs) - (memq (car x) cl-safe-funcs) + (or (memq (car x) cl--simple-funcs) + (memq (car x) cl--safe-funcs) (get (car x) 'side-effect-free)) (progn - (while (and (setq x (cdr x)) (cl-safe-expr-p (car x)))) + (while (and (setq x (cdr x)) (cl--safe-expr-p (car x)))) (null x))))) ;;; Check if constant (i.e., no side effects or dependencies). -(defun cl-const-expr-p (x) +(defun cl--const-expr-p (x) (cond ((consp x) (or (eq (car x) 'quote) - (and (memq (car x) '(function function*)) + (and (memq (car x) '(function cl-function)) (or (symbolp (nth 1 x)) (and (eq (car-safe (nth 1 x)) 'lambda) 'func))))) ((symbolp x) (and (memq x '(nil t)) t)) (t t))) -(defun cl-const-exprs-p (xs) - (while (and xs (cl-const-expr-p (car xs))) - (setq xs (cdr xs))) - (not xs)) - -(defun cl-const-expr-val (x) - (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x))) +(defun cl--const-expr-val (x) + (and (macroexp-const-p x) (if (consp x) (nth 1 x) x))) (defun cl-expr-access-order (x v) ;; This apparently tries to return nil iff the expression X evaluates @@ -134,107 +124,194 @@ ;; to). ;; FIXME: This is very naive, it doesn't even check to see if those ;; variables appear more than once. - (if (cl-const-expr-p x) v + (if (macroexp-const-p x) v (if (consp x) (progn (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v))) v) (if (eq x (car v)) (cdr v) '(t))))) -;;; Count number of times X refers to Y. Return nil for 0 times. -(defun cl-expr-contains (x y) +(defun cl--expr-contains (x y) + "Count number of times X refers to Y. Return nil for 0 times." + ;; FIXME: This is naive, and it will cl-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*)))) + ((and (consp x) (not (memq (car x) '(quote function cl-function)))) (let ((sum 0)) - (while x - (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))) + (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))) -(defun cl-expr-contains-any (x y) - (while (and y (not (cl-expr-contains x (car y)))) (pop y)) +(defun cl--expr-contains-any (x y) + (while (and y (not (cl--expr-contains x (car y)))) (pop y)) y) -;;; Check whether X may depend on any of the symbols in Y. -(defun cl-expr-depends-p (x y) - (and (not (cl-const-expr-p x)) - (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y)))) +(defun cl--expr-depends-p (x y) + "Check whether X may depend on any of the symbols in Y." + (and (not (macroexp-const-p x)) + (or (not (cl--safe-expr-p x)) (cl--expr-contains-any x y)))) ;;; Symbols. -(defvar *gensym-counter*) +(defvar cl--gensym-counter) ;;;###autoload -(defun gensym (&optional prefix) +(defun cl-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 -(defun gentemp (&optional prefix) +(defun cl-gentemp (&optional prefix) "Generate a new interned symbol with a unique name. 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 ("cl-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) +(defmacro cl-defun (name args &rest body) "Define NAME as a function. Like normal `defun', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...). +and BODY is implicitly surrounded by (cl-block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" - (let* ((res (cl-transform-lambda (cons args body) name)) - (form (list* 'defun name (cdr res)))) - (if (car res) (list 'progn (car res) form) form))) + (declare (debug + ;; Same as defun but use cl-lambda-list. + (&define [&or name ("cl-setf" :name cl-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 `(defun ,name ,@(cdr res)))) + (if (car res) `(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) +(defmacro cl-defmacro (name args &rest body) "Define NAME as a macro. Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...). +and BODY is implicitly surrounded by (cl-block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" - (let* ((res (cl-transform-lambda (cons args body) name)) - (form (list* 'defmacro name (cdr res)))) - (if (car res) (list 'progn (car res) form) form))) + (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 `(defmacro ,name ,@(cdr res)))) + (if (car res) `(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 cl-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) + ("cl-function" cl-function) + form)) ;;;###autoload -(defmacro function* (func) +(defmacro cl-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))))) - (if (car res) (list 'progn (car res) form) form)) - (list 'function func))) - -(defun cl-transform-function-property (func prop form) - (let ((res (cl-transform-lambda form func))) - (append '(progn) (cdr (cdr (car res))) - (list (list 'put (list 'quote func) (list 'quote prop) - (list 'function (cons 'lambda (cdr res)))))))) - -(defconst lambda-list-keywords + (let* ((res (cl--transform-lambda (cdr func) 'cl-none)) + (form `(function (lambda . ,(cdr res))))) + (if (car res) `(progn ,(car res) ,form) form)) + `(function ,func))) + +(defun cl--transform-function-property (func prop form) + (let ((res (cl--transform-lambda form func))) + `(progn ,@(cdr (cdr (car res))) + (put ',func ',prop #'(lambda . ,(cdr res)))))) + +(defconst cl-lambda-list-keywords '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) -(defvar cl-macro-environment nil - "Keep the list of currently active macros. -It is a list of elements of the form either: -- (SYMBOL . FUNCTION) where FUNCTION is the macro expansion function. -- (SYMBOL-NAME . EXPANSION) where SYMBOL-NAME is the name of a symbol macro.") -(defvar bind-block) (defvar bind-defs) (defvar bind-enquote) -(defvar bind-inits) (defvar bind-lets) (defvar bind-forms) +(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote) +(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms) (declare-function help-add-fundoc-usage "help-fns" (docstring arglist)) @@ -260,7 +337,7 @@ It is a list of elements of the form either: ((not (consp x)) x) ((memq state '(nil &rest)) (cl--make-usage-args x)) (t ;(VAR INITFORM SVAR) or ((KEYWORD VAR) INITFORM SVAR). - (list* + (cl-list* (if (and (consp (car x)) (eq state '&key)) (list (caar x) (cl--make-usage-var (nth 1 (car x)))) (cl--make-usage-var (car x))) @@ -269,42 +346,43 @@ It is a list of elements of the form either: )))) arglist))) -(defun cl-transform-lambda (form bind-block) +(defun cl--transform-lambda (form bind-block) (let* ((args (car form)) (body (cdr form)) (orig-args args) - (bind-defs nil) (bind-enquote nil) - (bind-inits nil) (bind-lets nil) (bind-forms nil) + (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) + (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) (header nil) (simple-args nil)) (while (or (stringp (car body)) - (memq (car-safe (car body)) '(interactive declare))) + (memq (car-safe (car body)) '(interactive cl-declare))) (push (pop body) header)) - (setq args (if (listp args) (copy-list args) (list '&rest args))) + (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) - (if (setq bind-defs (cadr (memq '&cl-defs args))) - (setq args (delq '&cl-defs (delq bind-defs args)) - bind-defs (cadr bind-defs))) - (if (setq bind-enquote (memq '&cl-quote args)) + (if (setq cl--bind-defs (cadr (memq '&cl-defs args))) + (setq args (delq '&cl-defs (delq cl--bind-defs args)) + cl--bind-defs (cadr cl--bind-defs))) + (if (setq cl--bind-enquote (memq '&cl-quote args)) (setq args (delq '&cl-quote args))) (if (memq '&whole args) (error "&whole not currently implemented")) - (let* ((p (memq '&environment args)) (v (cadr p))) + (let* ((p (memq '&environment args)) (v (cadr p)) + (env-exp 'macroexpand-all-environment)) (if p (setq args (nconc (delq (car p) (delq v args)) - (list '&aux (list v 'cl-macro-environment)))))) + (list '&aux (list v env-exp)))))) (while (and args (symbolp (car args)) (not (memq (car args) '(nil &rest &body &key &aux))) (not (and (eq (car args) '&optional) - (or bind-defs (consp (cadr args)))))) + (or cl--bind-defs (consp (cadr args)))))) (push (pop args) simple-args)) - (or (eq bind-block 'cl-none) - (setq body (list (list* 'block bind-block body)))) + (or (eq cl--bind-block 'cl-none) + (setq body (list `(cl-block ,cl--bind-block ,@body)))) (if (null args) - (list* nil (nreverse simple-args) (nconc (nreverse header) body)) + (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) (if (memq '&optional simple-args) (push '&optional args)) - (cl-do-arglist args nil (- (length simple-args) - (if (memq '&optional simple-args) 1 0))) - (setq bind-lets (nreverse bind-lets)) - (list* (and bind-inits (list* 'eval-when '(compile load eval) - (nreverse bind-inits))) + (cl--do-arglist args nil (- (length simple-args) + (if (memq '&optional simple-args) 1 0))) + (setq cl--bind-lets (nreverse cl--bind-lets)) + (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval) + ,@(nreverse cl--bind-inits))) (nconc (nreverse simple-args) - (list '&rest (car (pop bind-lets)))) + (list '&rest (car (pop cl--bind-lets)))) (nconc (let ((hdr (nreverse header))) ;; Macro expansion can take place in the middle of ;; apparently harmless computation, so it should not @@ -317,15 +395,16 @@ It is a list of elements of the form either: (cons 'fn (cl--make-usage-args orig-args)))) hdr))) - (list (nconc (list 'let* bind-lets) - (nreverse bind-forms) body))))))) + (list `(let* ,cl--bind-lets + ,@(nreverse cl--bind-forms) + ,@body))))))) -(defun cl-do-arglist (args expr &optional num) ; uses bind-* +(defun cl--do-arglist (args expr &optional num) ; uses bind-* (if (nlistp args) - (if (or (memq args lambda-list-keywords) (not (symbolp args))) + (if (or (memq args cl-lambda-list-keywords) (not (symbolp args))) (error "Invalid argument name: %s" args) - (push (list args expr) bind-lets)) - (setq args (copy-list args)) + (push (list args expr) cl--bind-lets)) + (setq args (cl-copy-list args)) (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) (let ((p (memq '&body args))) (if p (setcar p '&rest))) (if (memq '&environment args) (error "&environment used incorrectly")) @@ -338,212 +417,205 @@ It is a list of elements of the form either: (if (listp (cadr restarg)) (setq restarg (make-symbol "--cl-rest--")) (setq restarg (cadr restarg))) - (push (list restarg expr) bind-lets) + (push (list restarg expr) cl--bind-lets) (if (eq (car args) '&whole) - (push (list (cl-pop2 args) restarg) bind-lets)) + (push (list (cl-pop2 args) restarg) cl--bind-lets)) (let ((p args)) (setq minarg restarg) - (while (and p (not (memq (car p) lambda-list-keywords))) + (while (and p (not (memq (car p) cl-lambda-list-keywords))) (or (eq p args) (setq minarg (list 'cdr minarg))) (setq p (cdr p))) (if (memq (car p) '(nil &aux)) - (setq minarg (list '= (list 'length restarg) - (length (ldiff args p))) + (setq minarg `(= (length ,restarg) + ,(length (cl-ldiff args p))) exactarg (not (eq args p))))) - (while (and args (not (memq (car args) lambda-list-keywords))) + (while (and args (not (memq (car args) cl-lambda-list-keywords))) (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) restarg))) - (cl-do-arglist + (cl--do-arglist (pop args) (if (or laterarg (= safety 0)) poparg - (list 'if minarg poparg - (list 'signal '(quote wrong-number-of-arguments) - (list 'list (and (not (eq bind-block 'cl-none)) - (list 'quote bind-block)) - (list 'length restarg))))))) + `(if ,minarg ,poparg + (signal 'wrong-number-of-arguments + (list ,(and (not (eq cl--bind-block 'cl-none)) + `',cl--bind-block) + (length ,restarg))))))) (setq num (1+ num) laterarg t)) (while (and (eq (car args) '&optional) (pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) + (while (and args (not (memq (car args) cl-lambda-list-keywords))) (let ((arg (pop args))) (or (consp arg) (setq arg (list arg))) - (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t))) + (if (cddr arg) (cl--do-arglist (nth 2 arg) `(and ,restarg t))) (let ((def (if (cdr arg) (nth 1 arg) - (or (car bind-defs) - (nth 1 (assq (car arg) bind-defs))))) - (poparg (list 'pop restarg))) - (and def bind-enquote (setq def (list 'quote def))) - (cl-do-arglist (car arg) - (if def (list 'if restarg poparg def) poparg)) + (or (car cl--bind-defs) + (nth 1 (assq (car arg) cl--bind-defs))))) + (poparg `(pop ,restarg))) + (and def cl--bind-enquote (setq def `',def)) + (cl--do-arglist (car arg) + (if def `(if ,restarg ,poparg ,def) poparg)) (setq num (1+ num)))))) (if (eq (car args) '&rest) (let ((arg (cl-pop2 args))) - (if (consp arg) (cl-do-arglist arg restarg))) + (if (consp arg) (cl--do-arglist arg restarg))) (or (eq (car args) '&key) (= safety 0) exactarg - (push (list 'if restarg - (list 'signal '(quote wrong-number-of-arguments) - (list 'list - (and (not (eq bind-block 'cl-none)) - (list 'quote bind-block)) - (list '+ num (list 'length restarg))))) - bind-forms))) + (push `(if ,restarg + (signal 'wrong-number-of-arguments + (list + ,(and (not (eq cl--bind-block 'cl-none)) + `',cl--bind-block) + (+ ,num (length ,restarg))))) + cl--bind-forms))) (while (and (eq (car args) '&key) (pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) + (while (and args (not (memq (car args) cl-lambda-list-keywords))) (let ((arg (pop args))) (or (consp arg) (setq arg (list arg))) (let* ((karg (if (consp (car arg)) (caar arg) (intern (format ":%s" (car arg))))) - (varg (if (consp (car arg)) (cadar arg) (car arg))) + (varg (if (consp (car arg)) (cl-cadar arg) (car arg))) (def (if (cdr arg) (cadr arg) - (or (car bind-defs) (cadr (assq varg bind-defs))))) - (look (list 'memq (list 'quote karg) restarg))) - (and def bind-enquote (setq def (list 'quote def))) + (or (car cl--bind-defs) (cadr (assq varg cl--bind-defs))))) + (look `(memq ',karg ,restarg))) + (and def cl--bind-enquote (setq def `',def)) (if (cddr arg) (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--"))) - (val (list 'car (list 'cdr temp)))) - (cl-do-arglist temp look) - (cl-do-arglist varg - (list 'if temp - (list 'prog1 val (list 'setq temp t)) - def))) - (cl-do-arglist + (val `(car (cdr ,temp)))) + (cl--do-arglist temp look) + (cl--do-arglist varg + `(if ,temp + (prog1 ,val (setq ,temp t)) + ,def))) + (cl--do-arglist varg - (list 'car - (list 'cdr - (if (null def) + `(car (cdr ,(if (null def) look - (list 'or look - (if (eq (cl-const-expr-p def) t) - (list - 'quote - (list nil (cl-const-expr-val def))) - (list 'list nil def)))))))) + `(or ,look + ,(if (eq (cl--const-expr-p def) t) + `'(nil ,(cl--const-expr-val def)) + `(list nil ,def)))))))) (push karg keys))))) (setq keys (nreverse keys)) (or (and (eq (car args) '&allow-other-keys) (pop args)) (null keys) (= safety 0) (let* ((var (make-symbol "--cl-keys--")) (allow '(:allow-other-keys)) - (check (list - 'while var - (list - 'cond - (list (list 'memq (list 'car var) - (list 'quote (append keys allow))) - (list 'setq var (list 'cdr (list 'cdr var)))) - (list (list 'car - (list 'cdr - (list 'memq (cons 'quote allow) - restarg))) - (list 'setq var nil)) - (list t - (list - 'error - (format "Keyword argument %%s not one of %s" - keys) - (list 'car var))))))) - (push (list 'let (list (list var restarg)) check) bind-forms))) + (check `(while ,var + (cond + ((memq (car ,var) ',(append keys allow)) + (setq ,var (cdr (cdr ,var)))) + ((car (cdr (memq (quote ,@allow) ,restarg))) + (setq ,var nil)) + (t + (error + ,(format "Keyword argument %%s not one of %s" + keys) + (car ,var))))))) + (push `(let ((,var ,restarg)) ,check) cl--bind-forms))) (while (and (eq (car args) '&aux) (pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) + (while (and args (not (memq (car args) cl-lambda-list-keywords))) (if (consp (car args)) - (if (and bind-enquote (cadar args)) - (cl-do-arglist (caar args) - (list 'quote (cadr (pop args)))) - (cl-do-arglist (caar args) (cadr (pop args)))) - (cl-do-arglist (pop args) nil)))) + (if (and cl--bind-enquote (cl-cadar args)) + (cl--do-arglist (caar args) + `',(cadr (pop args))) + (cl--do-arglist (caar args) (cadr (pop args)))) + (cl--do-arglist (pop args) nil)))) (if args (error "Malformed argument list %s" save-args))))) -(defun cl-arglist-args (args) +(defun cl--arglist-args (args) (if (nlistp args) (list args) (let ((res nil) (kind nil) arg) (while (consp args) (setq arg (pop args)) - (if (memq arg lambda-list-keywords) (setq kind arg) + (if (memq arg cl-lambda-list-keywords) (setq kind arg) (if (eq arg '&cl-defs) (pop args) (and (consp arg) kind (setq arg (car arg))) (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) - (setq res (nconc res (cl-arglist-args arg)))))) + (setq res (nconc res (cl--arglist-args arg)))))) (nconc res (and args (list args)))))) ;;;###autoload -(defmacro destructuring-bind (args expr &rest 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) - (append '(progn) bind-inits - (list (nconc (list 'let* (nreverse bind-lets)) - (nreverse bind-forms) body))))) +(defmacro cl-destructuring-bind (args expr &rest body) + (declare (indent 2) + (debug (&define cl-macro-list def-form cl-declarations def-body))) + (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-inits nil) + (cl--bind-defs nil) (cl--bind-block 'cl-none) (cl--bind-enquote nil)) + (cl--do-arglist (or args '(&aux)) expr) + (append '(progn) cl--bind-inits + (list `(let* ,(nreverse cl--bind-lets) + ,@(nreverse cl--bind-forms) ,@body))))) -;;; The `eval-when' form. +;;; The `cl-eval-when' form. (defvar cl-not-toplevel nil) ;;;###autoload -(defmacro eval-when (when &rest body) +(defmacro cl-eval-when (when &rest body) "Control when BODY is evaluated. If `compile' is in WHEN, BODY is evaluated when compiled at top-level. 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))) (cl-not-toplevel t)) (if (or (memq 'load when) (memq :load-toplevel when)) - (if comp (cons 'progn (mapcar 'cl-compile-time-too body)) - (list* 'if nil nil body)) + (if comp (cons 'progn (mapcar 'cl--compile-time-too body)) + `(if nil nil ,@body)) (progn (if comp (eval (cons 'progn body))) nil))) (and (or (memq 'eval when) (memq :execute when)) (cons 'progn body)))) -(defun cl-compile-time-too (form) +(defun cl--compile-time-too (form) (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler)) (setq form (macroexpand - form (cons '(eval-when) byte-compile-macro-environment)))) + form (cons '(cl-eval-when) byte-compile-macro-environment)))) (cond ((eq (car-safe form) 'progn) - (cons 'progn (mapcar 'cl-compile-time-too (cdr form)))) - ((eq (car-safe form) 'eval-when) + (cons 'progn (mapcar 'cl--compile-time-too (cdr form)))) + ((eq (car-safe form) 'cl-eval-when) (let ((when (nth 1 form))) (if (or (memq 'eval when) (memq :execute when)) - (list* 'eval-when (cons 'compile when) (cddr form)) + `(cl-eval-when (compile ,@when) ,@(cddr form)) form))) (t (eval form) form))) ;;;###autoload -(defmacro load-time-value (form &optional read-only) +(defmacro cl-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))) + (let* ((temp (cl-gentemp "--cl-load-time--")) + (set `(set ',temp ,form))) (if (and (fboundp 'byte-compile-file-form-defmumble) (boundp 'this-kind) (boundp 'that-one)) (fset 'byte-compile-file-form - (list 'lambda '(form) - (list 'fset '(quote byte-compile-file-form) - (list 'quote - (symbol-function 'byte-compile-file-form))) - (list 'byte-compile-file-form (list 'quote set)) - '(byte-compile-file-form form))) + `(lambda (form) + (fset 'byte-compile-file-form + ',(symbol-function 'byte-compile-file-form)) + (byte-compile-file-form ',set) + (byte-compile-file-form form))) (print set (symbol-value 'byte-compile--outbuffer))) - (list 'symbol-value (list 'quote temp))) - (list 'quote (eval form)))) + `(symbol-value ',temp)) + `',(eval form))) ;;; Conditional control structures. ;;;###autoload -(defmacro case (expr &rest clauses) +(defmacro cl-case (expr &rest clauses) "Eval EXPR and choose among clauses on that value. Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared against each key in each KEYLIST; the corresponding BODY is evaluated. -If no clause succeeds, case returns nil. A single atom may be used in +If no clause succeeds, cl-case returns nil. A single atom may be used in 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...)...)" - (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) + (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 'cond @@ -551,39 +623,42 @@ Key values are compared by `eql'. (function (lambda (c) (cons (cond ((memq (car c) '(t otherwise)) t) - ((eq (car c) 'ecase-error-flag) - (list 'error "ecase failed: %s, %s" - temp (list 'quote (reverse head-list)))) + ((eq (car c) 'cl--ecase-error-flag) + `(error "cl-ecase failed: %s, %s" + ,temp ',(reverse head-list))) ((listp (car c)) (setq head-list (append (car c) head-list)) - (list 'member* temp (list 'quote (car c)))) + `(cl-member ,temp ',(car c))) (t (if (memq (car c) head-list) (error "Duplicate key in case: %s" (car c))) (push (car c) head-list) - (list 'eql temp (list 'quote (car c))))) + `(eql ,temp ',(car c)))) (or (cdr c) '(nil))))) clauses)))) (if (eq temp expr) body - (list 'let (list (list temp expr)) body)))) + `(let ((,temp ,expr)) ,body)))) ;;;###autoload -(defmacro ecase (expr &rest clauses) - "Like `case', but error if no case fits. +(defmacro cl-ecase (expr &rest clauses) + "Like `cl-case', but error if no cl-case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (KEYLIST BODY...)...)" - (list* 'case expr (append clauses '((ecase-error-flag))))) + (declare (indent 1) (debug cl-case)) + `(cl-case ,expr ,@clauses (cl--ecase-error-flag))) ;;;###autoload -(defmacro typecase (expr &rest clauses) +(defmacro cl-typecase (expr &rest clauses) "Evals EXPR, chooses among clauses on that value. Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it 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 +cl-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...)...)" - (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) + (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 'cond @@ -591,71 +666,76 @@ final clause, and matches if no other keys match. (function (lambda (c) (cons (cond ((eq (car c) 'otherwise) t) - ((eq (car c) 'ecase-error-flag) - (list 'error "etypecase failed: %s, %s" - temp (list 'quote (reverse type-list)))) + ((eq (car c) 'cl--ecase-error-flag) + `(error "cl-etypecase failed: %s, %s" + ,temp ',(reverse type-list))) (t (push (car c) type-list) - (cl-make-type-test temp (car c)))) + (cl--make-type-test temp (car c)))) (or (cdr c) '(nil))))) clauses)))) (if (eq temp expr) body - (list 'let (list (list temp expr)) body)))) + `(let ((,temp ,expr)) ,body)))) ;;;###autoload -(defmacro etypecase (expr &rest clauses) - "Like `typecase', but error if no case fits. +(defmacro cl-etypecase (expr &rest clauses) + "Like `cl-typecase', but error if no case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (TYPE BODY...)...)" - (list* 'typecase expr (append clauses '((ecase-error-flag))))) + (declare (indent 1) (debug cl-typecase)) + `(cl-typecase ,expr ,@clauses (cl--ecase-error-flag))) ;;; Blocks and exits. ;;;###autoload -(defmacro block (name &rest body) +(defmacro cl-block (name &rest body) "Define a lexically-scoped block named NAME. -NAME may be any symbol. Code inside the BODY forms can call `return-from' +NAME may be any symbol. Code inside the BODY forms can call `cl-return-from' to jump prematurely out of the block. This differs from `catch' and `throw' in two respects: First, the NAME is an unevaluated symbol rather than a 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." - (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))) - body)))) + (declare (indent 1) (debug (symbolp body))) + (if (cl--safe-expr-p `(progn ,@body)) `(progn ,@body) + `(cl-block-wrapper + (catch ',(intern (format "--cl-block-%s--" name)) + ,@body)))) ;;;###autoload -(defmacro return (&optional result) +(defmacro cl-return (&optional result) "Return from the block named nil. -This is equivalent to `(return-from nil RESULT)'." - (list 'return-from nil result)) +This is equivalent to `(cl-return-from nil RESULT)'." + (declare (debug (&optional form))) + `(cl-return-from nil ,result)) ;;;###autoload -(defmacro return-from (name &optional result) +(defmacro cl-return-from (name &optional result) "Return from the block named NAME. -This jumps out to the innermost enclosing `(block NAME ...)' form, +This jumps out to the innermost enclosing `(cl-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))) + `(cl-block-throw ',name2 ,result))) -;;; The "loop" macro. +;;; The "cl-loop" macro. -(defvar loop-args) (defvar loop-accum-var) (defvar loop-accum-vars) -(defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps) -(defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag) -(defvar loop-initially) (defvar loop-map-form) (defvar loop-name) -(defvar loop-result) (defvar loop-result-explicit) -(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs) +(defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars) +(defvar cl--loop-bindings) (defvar cl--loop-body) (defvar cl--loop-destr-temps) +(defvar cl--loop-finally) (defvar cl--loop-finish-flag) +(defvar cl--loop-first-flag) +(defvar cl--loop-initially) (defvar cl--loop-map-form) (defvar cl--loop-name) +(defvar cl--loop-result) (defvar cl--loop-result-explicit) +(defvar cl--loop-result-var) (defvar cl--loop-steps) (defvar cl--loop-symbol-macs) ;;;###autoload -(defmacro loop (&rest loop-args) - "The Common Lisp `loop' macro. +(defmacro cl-loop (&rest loop-args) + "The Common Lisp `cl-loop' macro. Valid clauses are: for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR, @@ -669,119 +749,272 @@ Valid clauses are: finally return EXPR, named NAME. \(fn CLAUSE...)" - (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list loop-args)))))) - (list 'block nil (list* 'while t loop-args)) - (let ((loop-name nil) (loop-bindings nil) - (loop-body nil) (loop-steps nil) - (loop-result nil) (loop-result-explicit nil) - (loop-result-var nil) (loop-finish-flag nil) - (loop-accum-var nil) (loop-accum-vars nil) - (loop-initially nil) (loop-finally nil) - (loop-map-form nil) (loop-first-flag nil) - (loop-destr-temps nil) (loop-symbol-macs nil)) - (setq loop-args (append loop-args '(cl-end-loop))) - (while (not (eq (car loop-args) 'cl-end-loop)) (cl-parse-loop-clause)) - (if loop-finish-flag - (push `((,loop-finish-flag t)) loop-bindings)) - (if loop-first-flag - (progn (push `((,loop-first-flag t)) loop-bindings) - (push `(setq ,loop-first-flag nil) loop-steps))) - (let* ((epilogue (nconc (nreverse loop-finally) - (list (or loop-result-explicit loop-result)))) - (ands (cl-loop-build-ands (nreverse loop-body))) - (while-body (nconc (cadr ands) (nreverse loop-steps))) + (declare (debug (&rest &or symbolp form))) + (if (not (memq t (mapcar 'symbolp (delq nil (delq t (cl-copy-list loop-args)))))) + `(cl-block nil (while t ,@loop-args)) + (let ((cl--loop-args loop-args) (cl--loop-name nil) (cl--loop-bindings nil) + (cl--loop-body nil) (cl--loop-steps nil) + (cl--loop-result nil) (cl--loop-result-explicit nil) + (cl--loop-result-var nil) (cl--loop-finish-flag nil) + (cl--loop-accum-var nil) (cl--loop-accum-vars nil) + (cl--loop-initially nil) (cl--loop-finally nil) + (cl--loop-map-form nil) (cl--loop-first-flag nil) + (cl--loop-destr-temps nil) (cl--loop-symbol-macs nil)) + (setq cl--loop-args (append cl--loop-args '(cl-end-loop))) + (while (not (eq (car cl--loop-args) 'cl-end-loop)) (cl-parse-loop-clause)) + (if cl--loop-finish-flag + (push `((,cl--loop-finish-flag t)) cl--loop-bindings)) + (if cl--loop-first-flag + (progn (push `((,cl--loop-first-flag t)) cl--loop-bindings) + (push `(setq ,cl--loop-first-flag nil) cl--loop-steps))) + (let* ((epilogue (nconc (nreverse cl--loop-finally) + (list (or cl--loop-result-explicit cl--loop-result)))) + (ands (cl--loop-build-ands (nreverse cl--loop-body))) + (while-body (nconc (cadr ands) (nreverse cl--loop-steps))) (body (append - (nreverse loop-initially) - (list (if loop-map-form - (list 'block '--cl-finish-- - (subst - (if (eq (car ands) t) while-body - (cons `(or ,(car ands) - (return-from --cl-finish-- - nil)) - while-body)) - '--cl-map loop-map-form)) - (list* 'while (car ands) while-body))) - (if loop-finish-flag - (if (equal epilogue '(nil)) (list loop-result-var) - `((if ,loop-finish-flag - (progn ,@epilogue) ,loop-result-var))) + (nreverse cl--loop-initially) + (list (if cl--loop-map-form + `(cl-block --cl-finish-- + ,(cl-subst + (if (eq (car ands) t) while-body + (cons `(or ,(car ands) + (cl-return-from --cl-finish-- + nil)) + while-body)) + '--cl-map cl--loop-map-form)) + `(while ,(car ands) ,@while-body))) + (if cl--loop-finish-flag + (if (equal epilogue '(nil)) (list cl--loop-result-var) + `((if ,cl--loop-finish-flag + (progn ,@epilogue) ,cl--loop-result-var))) epilogue)))) - (if loop-result-var (push (list loop-result-var) loop-bindings)) - (while loop-bindings - (if (cdar loop-bindings) - (setq body (list (cl-loop-let (pop loop-bindings) body t))) + (if cl--loop-result-var (push (list cl--loop-result-var) cl--loop-bindings)) + (while cl--loop-bindings + (if (cdar cl--loop-bindings) + (setq body (list (cl--loop-let (pop cl--loop-bindings) body t))) (let ((lets nil)) - (while (and loop-bindings - (not (cdar loop-bindings))) - (push (car (pop loop-bindings)) lets)) - (setq body (list (cl-loop-let lets body nil)))))) - (if loop-symbol-macs - (setq body (list (list* 'symbol-macrolet loop-symbol-macs body)))) - (list* 'block loop-name body))))) + (while (and cl--loop-bindings + (not (cdar cl--loop-bindings))) + (push (car (pop cl--loop-bindings)) lets)) + (setq body (list (cl--loop-let lets body nil)))))) + (if cl--loop-symbol-macs + (setq body (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body)))) + `(cl-block ,cl--loop-name ,@body))))) + +;; Below is a complete spec for cl-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 cl-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 cl-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)) + (let ((word (pop cl--loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) (key-types '(key-code key-codes key-seq key-seqs key-binding key-bindings))) (cond - ((null loop-args) - (error "Malformed `loop' macro")) + ((null cl--loop-args) + (error "Malformed `cl-loop' macro")) ((eq word 'named) - (setq loop-name (pop loop-args))) + (setq cl--loop-name (pop cl--loop-args))) ((eq word 'initially) - (if (memq (car loop-args) '(do doing)) (pop loop-args)) - (or (consp (car loop-args)) (error "Syntax error on `initially' clause")) - (while (consp (car loop-args)) - (push (pop loop-args) loop-initially))) + (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) + (or (consp (car cl--loop-args)) (error "Syntax error on `initially' clause")) + (while (consp (car cl--loop-args)) + (push (pop cl--loop-args) cl--loop-initially))) ((eq word 'finally) - (if (eq (car loop-args) 'return) - (setq loop-result-explicit (or (cl-pop2 loop-args) '(quote nil))) - (if (memq (car loop-args) '(do doing)) (pop loop-args)) - (or (consp (car loop-args)) (error "Syntax error on `finally' clause")) - (if (and (eq (caar loop-args) 'return) (null loop-name)) - (setq loop-result-explicit (or (nth 1 (pop loop-args)) '(quote nil))) - (while (consp (car loop-args)) - (push (pop loop-args) loop-finally))))) + (if (eq (car cl--loop-args) 'return) + (setq cl--loop-result-explicit (or (cl-pop2 cl--loop-args) '(quote nil))) + (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) + (or (consp (car cl--loop-args)) (error "Syntax error on `finally' clause")) + (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name)) + (setq cl--loop-result-explicit (or (nth 1 (pop cl--loop-args)) '(quote nil))) + (while (consp (car cl--loop-args)) + (push (pop cl--loop-args) cl--loop-finally))))) ((memq word '(for as)) (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) (ands nil)) (while - ;; Use `gensym' rather than `make-symbol'. It's important that + ;; Use `cl-gensym' rather than `make-symbol'. It's important that ;; (not (eq (symbol-name var1) (symbol-name var2))) because - ;; these vars get added to the cl-macro-environment. - (let ((var (or (pop loop-args) (gensym "--cl-var--")))) - (setq word (pop loop-args)) - (if (eq word 'being) (setq word (pop loop-args))) - (if (memq word '(the each)) (setq word (pop loop-args))) + ;; these vars get added to the macro-environment. + (let ((var (or (pop cl--loop-args) (cl-gensym "--cl-var--")))) + (setq word (pop cl--loop-args)) + (if (eq word 'being) (setq word (pop cl--loop-args))) + (if (memq word '(the each)) (setq word (pop cl--loop-args))) (if (memq word '(buffer buffers)) - (setq word 'in loop-args (cons '(buffer-list) loop-args))) + (setq word 'in cl--loop-args (cons '(buffer-list) cl--loop-args))) (cond ((memq word '(from downfrom upfrom to downto upto above below by)) - (push word loop-args) - (if (memq (car loop-args) '(downto above)) - (error "Must specify `from' value for downward loop")) - (let* ((down (or (eq (car loop-args) 'downfrom) - (memq (caddr loop-args) '(downto above)))) - (excl (or (memq (car loop-args) '(above below)) - (memq (caddr loop-args) '(above below)))) - (start (and (memq (car loop-args) '(from upfrom downfrom)) - (cl-pop2 loop-args))) - (end (and (memq (car loop-args) + (push word cl--loop-args) + (if (memq (car cl--loop-args) '(downto above)) + (error "Must specify `from' value for downward cl-loop")) + (let* ((down (or (eq (car cl--loop-args) 'downfrom) + (memq (cl-caddr cl--loop-args) '(downto above)))) + (excl (or (memq (car cl--loop-args) '(above below)) + (memq (cl-caddr cl--loop-args) '(above below)))) + (start (and (memq (car cl--loop-args) '(from upfrom downfrom)) + (cl-pop2 cl--loop-args))) + (end (and (memq (car cl--loop-args) '(to upto downto above below)) - (cl-pop2 loop-args))) - (step (and (eq (car loop-args) 'by) (cl-pop2 loop-args))) - (end-var (and (not (cl-const-expr-p end)) + (cl-pop2 cl--loop-args))) + (step (and (eq (car cl--loop-args) 'by) (cl-pop2 cl--loop-args))) + (end-var (and (not (macroexp-const-p end)) (make-symbol "--cl-var--"))) - (step-var (and (not (cl-const-expr-p step)) + (step-var (and (not (macroexp-const-p step)) (make-symbol "--cl-var--")))) (and step (numberp step) (<= step 0) (error "Loop `by' value is not positive: %s" step)) @@ -792,7 +1025,7 @@ Valid clauses are: (if end (push (list (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)) loop-body)) + var (or end-var end)) cl--loop-body)) (push (list var (list (if down '- '+) var (or step-var step 1))) loop-for-steps))) @@ -801,44 +1034,44 @@ Valid clauses are: (let* ((on (eq word 'on)) (temp (if (and on (symbolp var)) var (make-symbol "--cl-var--")))) - (push (list temp (pop loop-args)) loop-for-bindings) - (push (list 'consp temp) loop-body) + (push (list temp (pop cl--loop-args)) loop-for-bindings) + (push `(consp ,temp) cl--loop-body) (if (eq word 'in-ref) - (push (list var (list 'car temp)) loop-symbol-macs) + (push (list var `(car ,temp)) cl--loop-symbol-macs) (or (eq temp var) (progn (push (list var nil) loop-for-bindings) - (push (list var (if on temp (list 'car temp))) + (push (list var (if on temp `(car ,temp))) loop-for-sets)))) (push (list temp - (if (eq (car loop-args) 'by) - (let ((step (cl-pop2 loop-args))) + (if (eq (car cl--loop-args) 'by) + (let ((step (cl-pop2 cl--loop-args))) (if (and (memq (car-safe step) '(quote function - function*)) + cl-function)) (symbolp (nth 1 step))) (list (nth 1 step) temp) - (list 'funcall step temp))) - (list 'cdr temp))) + `(funcall ,step ,temp))) + `(cdr ,temp))) loop-for-steps))) ((eq word '=) - (let* ((start (pop loop-args)) - (then (if (eq (car loop-args) 'then) (cl-pop2 loop-args) start))) + (let* ((start (pop cl--loop-args)) + (then (if (eq (car cl--loop-args) 'then) (cl-pop2 cl--loop-args) start))) (push (list var nil) loop-for-bindings) - (if (or ands (eq (car loop-args) 'and)) + (if (or ands (eq (car cl--loop-args) 'and)) (progn (push `(,var - (if ,(or loop-first-flag - (setq loop-first-flag + (if ,(or cl--loop-first-flag + (setq cl--loop-first-flag (make-symbol "--cl-var--"))) ,start ,var)) loop-for-sets) (push (list var then) loop-for-steps)) (push (list var (if (eq start then) start - `(if ,(or loop-first-flag - (setq loop-first-flag + `(if ,(or cl--loop-first-flag + (setq cl--loop-first-flag (make-symbol "--cl-var--"))) ,start ,then))) loop-for-sets)))) @@ -846,79 +1079,78 @@ Valid clauses are: ((memq word '(across across-ref)) (let ((temp-vec (make-symbol "--cl-vec--")) (temp-idx (make-symbol "--cl-idx--"))) - (push (list temp-vec (pop loop-args)) loop-for-bindings) + (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) - (push (list '< (list 'setq temp-idx (list '1+ temp-idx)) - (list 'length temp-vec)) loop-body) + (push `(< (setq ,temp-idx (1+ ,temp-idx)) + (length ,temp-vec)) cl--loop-body) (if (eq word 'across-ref) - (push (list var (list 'aref temp-vec temp-idx)) - loop-symbol-macs) + (push (list var `(aref ,temp-vec ,temp-idx)) + cl--loop-symbol-macs) (push (list var nil) loop-for-bindings) - (push (list var (list 'aref temp-vec temp-idx)) + (push (list var `(aref ,temp-vec ,temp-idx)) loop-for-sets)))) ((memq word '(element elements)) - (let ((ref (or (memq (car loop-args) '(in-ref of-ref)) - (and (not (memq (car loop-args) '(in of))) + (let ((ref (or (memq (car cl--loop-args) '(in-ref of-ref)) + (and (not (memq (car cl--loop-args) '(in of))) (error "Expected `of'")))) - (seq (cl-pop2 loop-args)) + (seq (cl-pop2 cl--loop-args)) (temp-seq (make-symbol "--cl-seq--")) - (temp-idx (if (eq (car loop-args) 'using) - (if (and (= (length (cadr loop-args)) 2) - (eq (caadr loop-args) 'index)) - (cadr (cl-pop2 loop-args)) + (temp-idx (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (eq (cl-caadr cl--loop-args) 'index)) + (cadr (cl-pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-idx--")))) (push (list temp-seq seq) loop-for-bindings) (push (list temp-idx 0) loop-for-bindings) (if ref (let ((temp-len (make-symbol "--cl-len--"))) - (push (list temp-len (list 'length temp-seq)) + (push (list temp-len `(length ,temp-seq)) loop-for-bindings) - (push (list var (list 'elt temp-seq temp-idx)) - loop-symbol-macs) - (push (list '< temp-idx temp-len) loop-body)) + (push (list var `(elt ,temp-seq temp-idx)) + cl--loop-symbol-macs) + (push `(< ,temp-idx ,temp-len) cl--loop-body)) (push (list var nil) loop-for-bindings) - (push (list 'and temp-seq - (list 'or (list 'consp temp-seq) - (list '< temp-idx - (list 'length temp-seq)))) - loop-body) - (push (list var (list 'if (list 'consp temp-seq) - (list 'pop temp-seq) - (list 'aref temp-seq temp-idx))) + (push `(and ,temp-seq + (or (consp ,temp-seq) + (< ,temp-idx (length ,temp-seq)))) + cl--loop-body) + (push (list var `(if (consp ,temp-seq) + (pop ,temp-seq) + (aref ,temp-seq ,temp-idx))) loop-for-sets)) - (push (list temp-idx (list '1+ temp-idx)) + (push (list temp-idx `(1+ ,temp-idx)) loop-for-steps))) ((memq word hash-types) - (or (memq (car loop-args) '(in of)) (error "Expected `of'")) - (let* ((table (cl-pop2 loop-args)) - (other (if (eq (car loop-args) 'using) - (if (and (= (length (cadr loop-args)) 2) - (memq (caadr loop-args) hash-types) - (not (eq (caadr loop-args) word))) - (cadr (cl-pop2 loop-args)) + (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) + (let* ((table (cl-pop2 cl--loop-args)) + (other (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (memq (cl-caadr cl--loop-args) hash-types) + (not (eq (cl-caadr cl--loop-args) word))) + (cadr (cl-pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(hash-value hash-values)) (setq var (prog1 other (setq other var)))) - (setq loop-map-form + (setq cl--loop-map-form `(maphash (lambda (,var ,other) . --cl-map) ,table)))) ((memq word '(symbol present-symbol external-symbol symbols present-symbols external-symbols)) - (let ((ob (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args)))) - (setq loop-map-form + (let ((ob (and (memq (car cl--loop-args) '(in of)) (cl-pop2 cl--loop-args)))) + (setq cl--loop-map-form `(mapatoms (lambda (,var) . --cl-map) ,ob)))) ((memq word '(overlay overlays extent extents)) (let ((buf nil) (from nil) (to nil)) - (while (memq (car loop-args) '(in of from to)) - (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args))) - ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args))) - (t (setq buf (cl-pop2 loop-args))))) - (setq loop-map-form + (while (memq (car cl--loop-args) '(in of from to)) + (cond ((eq (car cl--loop-args) 'from) (setq from (cl-pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args))) + (t (setq buf (cl-pop2 cl--loop-args))))) + (setq cl--loop-map-form `(cl-map-extents (lambda (,var ,(make-symbol "--cl-var--")) (progn . --cl-map) nil) @@ -928,246 +1160,246 @@ Valid clauses are: (let ((buf nil) (prop nil) (from nil) (to nil) (var1 (make-symbol "--cl-var1--")) (var2 (make-symbol "--cl-var2--"))) - (while (memq (car loop-args) '(in of property from to)) - (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args))) - ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args))) - ((eq (car loop-args) 'property) - (setq prop (cl-pop2 loop-args))) - (t (setq buf (cl-pop2 loop-args))))) + (while (memq (car cl--loop-args) '(in of property from to)) + (cond ((eq (car cl--loop-args) 'from) (setq from (cl-pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'property) + (setq prop (cl-pop2 cl--loop-args))) + (t (setq buf (cl-pop2 cl--loop-args))))) (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) (setq var1 (car var) var2 (cdr var)) - (push (list var (list 'cons var1 var2)) loop-for-sets)) - (setq loop-map-form + (push (list var `(cons ,var1 ,var2)) loop-for-sets)) + (setq cl--loop-map-form `(cl-map-intervals (lambda (,var1 ,var2) . --cl-map) ,buf ,prop ,from ,to)))) ((memq word key-types) - (or (memq (car loop-args) '(in of)) (error "Expected `of'")) - (let ((map (cl-pop2 loop-args)) - (other (if (eq (car loop-args) 'using) - (if (and (= (length (cadr loop-args)) 2) - (memq (caadr loop-args) key-types) - (not (eq (caadr loop-args) word))) - (cadr (cl-pop2 loop-args)) + (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) + (let ((cl-map (cl-pop2 cl--loop-args)) + (other (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (memq (cl-caadr cl--loop-args) key-types) + (not (eq (cl-caadr cl--loop-args) word))) + (cadr (cl-pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(key-binding key-bindings)) (setq var (prog1 other (setq other var)))) - (setq loop-map-form + (setq cl--loop-map-form `(,(if (memq word '(key-seq key-seqs)) 'cl-map-keymap-recursively 'map-keymap) - (lambda (,var ,other) . --cl-map) ,map)))) + (lambda (,var ,other) . --cl-map) ,cl-map)))) ((memq word '(frame frames screen screens)) (let ((temp (make-symbol "--cl-var--"))) (push (list var '(selected-frame)) loop-for-bindings) (push (list temp nil) loop-for-bindings) - (push (list 'prog1 (list 'not (list 'eq var temp)) - (list 'or temp (list 'setq temp var))) - loop-body) - (push (list var (list 'next-frame var)) + (push `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var))) + cl--loop-body) + (push (list var `(next-frame ,var)) loop-for-steps))) ((memq word '(window windows)) - (let ((scr (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args))) + (let ((scr (and (memq (car cl--loop-args) '(in of)) (cl-pop2 cl--loop-args))) (temp (make-symbol "--cl-var--")) (minip (make-symbol "--cl-minip--"))) (push (list var (if scr - (list 'frame-selected-window scr) + `(frame-selected-window ,scr) '(selected-window))) loop-for-bindings) ;; If we started in the minibuffer, we need to ;; ensure that next-window will bring us back there ;; at some point. (Bug#7492). - ;; (Consider using walk-windows instead of loop if + ;; (Consider using walk-windows instead of cl-loop if ;; you care about such things.) (push (list minip `(minibufferp (window-buffer ,var))) loop-for-bindings) (push (list temp nil) loop-for-bindings) - (push (list 'prog1 (list 'not (list 'eq var temp)) - (list 'or temp (list 'setq temp var))) - loop-body) - (push (list var (list 'next-window var minip)) + (push `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var))) + cl--loop-body) + (push (list var `(next-window ,var ,minip)) loop-for-steps))) (t (let ((handler (and (symbolp word) - (get word 'cl-loop-for-handler)))) + (get word 'cl--loop-for-handler)))) (if handler (funcall handler var) (error "Expected a `for' preposition, found %s" word))))) - (eq (car loop-args) 'and)) + (eq (car cl--loop-args) 'and)) (setq ands t) - (pop loop-args)) + (pop cl--loop-args)) (if (and ands loop-for-bindings) - (push (nreverse loop-for-bindings) loop-bindings) - (setq loop-bindings (nconc (mapcar 'list loop-for-bindings) - loop-bindings))) + (push (nreverse loop-for-bindings) cl--loop-bindings) + (setq cl--loop-bindings (nconc (mapcar 'list loop-for-bindings) + cl--loop-bindings))) (if loop-for-sets - (push (list 'progn - (cl-loop-let (nreverse loop-for-sets) 'setq ands) - t) loop-body)) + (push `(progn + ,(cl--loop-let (nreverse loop-for-sets) 'setq ands) + t) cl--loop-body)) (if loop-for-steps - (push (cons (if ands 'psetq 'setq) + (push (cons (if ands 'cl-psetq 'setq) (apply 'append (nreverse loop-for-steps))) - loop-steps)))) + cl--loop-steps)))) ((eq word 'repeat) (let ((temp (make-symbol "--cl-var--"))) - (push (list (list temp (pop loop-args))) loop-bindings) - (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body))) + (push (list (list temp (pop cl--loop-args))) cl--loop-bindings) + (push `(>= (setq ,temp (1- ,temp)) 0) cl--loop-body))) ((memq word '(collect collecting)) - (let ((what (pop loop-args)) - (var (cl-loop-handle-accum nil 'nreverse))) - (if (eq var loop-accum-var) - (push (list 'progn (list 'push what var) t) loop-body) - (push (list 'progn - (list 'setq var (list 'nconc var (list 'list what))) - t) loop-body)))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum nil 'nreverse))) + (if (eq var cl--loop-accum-var) + (push `(progn (push ,what ,var) t) cl--loop-body) + (push `(progn + (setq ,var (nconc ,var (list ,what))) + t) cl--loop-body)))) ((memq word '(nconc nconcing append appending)) - (let ((what (pop loop-args)) - (var (cl-loop-handle-accum nil 'nreverse))) - (push (list 'progn - (list 'setq var - (if (eq var loop-accum-var) - (list 'nconc - (list (if (memq word '(nconc nconcing)) - 'nreverse 'reverse) - what) - var) - (list (if (memq word '(nconc nconcing)) - 'nconc 'append) - var what))) t) loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum nil 'nreverse))) + (push `(progn + (setq ,var + ,(if (eq var cl--loop-accum-var) + `(nconc + (,(if (memq word '(nconc nconcing)) + #'nreverse #'reverse) + ,what) + ,var) + `(,(if (memq word '(nconc nconcing)) + #'nconc #'append) + ,var ,what))) t) cl--loop-body))) ((memq word '(concat concating)) - (let ((what (pop loop-args)) - (var (cl-loop-handle-accum ""))) - (push (list 'progn (list 'callf 'concat var what) t) loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum ""))) + (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body))) ((memq word '(vconcat vconcating)) - (let ((what (pop loop-args)) - (var (cl-loop-handle-accum []))) - (push (list 'progn (list 'callf 'vconcat var what) t) loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum []))) + (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body))) ((memq word '(sum summing)) - (let ((what (pop loop-args)) - (var (cl-loop-handle-accum 0))) - (push (list 'progn (list 'incf var what) t) loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum 0))) + (push `(progn (cl-incf ,var ,what) t) cl--loop-body))) ((memq word '(count counting)) - (let ((what (pop loop-args)) - (var (cl-loop-handle-accum 0))) - (push (list 'progn (list 'if what (list 'incf var)) t) loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum 0))) + (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body))) ((memq word '(minimize minimizing maximize maximizing)) - (let* ((what (pop loop-args)) - (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--"))) - (var (cl-loop-handle-accum nil)) + (let* ((what (pop cl--loop-args)) + (temp (if (cl--simple-expr-p what) what (make-symbol "--cl-var--"))) + (var (cl--loop-handle-accum nil)) (func (intern (substring (symbol-name word) 0 3))) - (set (list 'setq var (list 'if var (list func var temp) temp)))) - (push (list 'progn (if (eq temp what) set - (list 'let (list (list temp what)) set)) - t) loop-body))) + (set `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) + (push `(progn ,(if (eq temp what) set + `(let ((,temp ,what)) ,set)) + t) cl--loop-body))) ((eq word 'with) (let ((bindings nil)) - (while (progn (push (list (pop loop-args) - (and (eq (car loop-args) '=) (cl-pop2 loop-args))) + (while (progn (push (list (pop cl--loop-args) + (and (eq (car cl--loop-args) '=) (cl-pop2 cl--loop-args))) bindings) - (eq (car loop-args) 'and)) - (pop loop-args)) - (push (nreverse bindings) loop-bindings))) + (eq (car cl--loop-args) 'and)) + (pop cl--loop-args)) + (push (nreverse bindings) cl--loop-bindings))) ((eq word 'while) - (push (pop loop-args) loop-body)) + (push (pop cl--loop-args) cl--loop-body)) ((eq word 'until) - (push (list 'not (pop loop-args)) loop-body)) + (push `(not ,(pop cl--loop-args)) cl--loop-body)) ((eq word 'always) - (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (push (list 'setq loop-finish-flag (pop loop-args)) loop-body) - (setq loop-result t)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (push `(setq ,cl--loop-finish-flag ,(pop cl--loop-args)) cl--loop-body) + (setq cl--loop-result t)) ((eq word 'never) - (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (push (list 'setq loop-finish-flag (list 'not (pop loop-args))) - loop-body) - (setq loop-result t)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (push `(setq ,cl--loop-finish-flag (not ,(pop cl--loop-args))) + cl--loop-body) + (setq cl--loop-result t)) ((eq word 'thereis) - (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--"))) - (push (list 'setq loop-finish-flag - (list 'not (list 'setq loop-result-var (pop loop-args)))) - loop-body)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--"))) + (push `(setq ,cl--loop-finish-flag + (not (setq ,cl--loop-result-var ,(pop cl--loop-args)))) + cl--loop-body)) ((memq word '(if when unless)) - (let* ((cond (pop loop-args)) - (then (let ((loop-body nil)) + (let* ((cond (pop cl--loop-args)) + (then (let ((cl--loop-body nil)) (cl-parse-loop-clause) - (cl-loop-build-ands (nreverse loop-body)))) - (else (let ((loop-body nil)) - (if (eq (car loop-args) 'else) - (progn (pop loop-args) (cl-parse-loop-clause))) - (cl-loop-build-ands (nreverse loop-body)))) + (cl--loop-build-ands (nreverse cl--loop-body)))) + (else (let ((cl--loop-body nil)) + (if (eq (car cl--loop-args) 'else) + (progn (pop cl--loop-args) (cl-parse-loop-clause))) + (cl--loop-build-ands (nreverse cl--loop-body)))) (simple (and (eq (car then) t) (eq (car else) t)))) - (if (eq (car loop-args) 'end) (pop loop-args)) + (if (eq (car cl--loop-args) 'end) (pop cl--loop-args)) (if (eq word 'unless) (setq then (prog1 else (setq else then)))) (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) (if simple (nth 1 else) (list (nth 2 else)))))) - (if (cl-expr-contains form 'it) + (if (cl--expr-contains form 'it) (let ((temp (make-symbol "--cl-var--"))) - (push (list temp) loop-bindings) - (setq form (list* 'if (list 'setq temp cond) - (subst temp 'it form)))) - (setq form (list* 'if cond form))) - (push (if simple (list 'progn form t) form) loop-body)))) + (push (list temp) cl--loop-bindings) + (setq form `(if (setq ,temp ,cond) + ,@(cl-subst temp 'it form)))) + (setq form `(if ,cond ,@form))) + (push (if simple `(progn ,form t) form) cl--loop-body)))) ((memq word '(do doing)) (let ((body nil)) - (or (consp (car loop-args)) (error "Syntax error on `do' clause")) - (while (consp (car loop-args)) (push (pop loop-args) body)) - (push (cons 'progn (nreverse (cons t body))) loop-body))) + (or (consp (car cl--loop-args)) (error "Syntax error on `do' clause")) + (while (consp (car cl--loop-args)) (push (pop cl--loop-args) body)) + (push (cons 'progn (nreverse (cons t body))) cl--loop-body))) ((eq word 'return) - (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--"))) - (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--"))) - (push (list 'setq loop-result-var (pop loop-args) - loop-finish-flag nil) loop-body)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-var--"))) + (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--"))) + (push `(setq ,cl--loop-result-var ,(pop cl--loop-args) + ,cl--loop-finish-flag nil) cl--loop-body)) (t - (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) - (or handler (error "Expected a loop keyword, found %s" word)) + (let ((handler (and (symbolp word) (get word 'cl--loop-handler)))) + (or handler (error "Expected a cl-loop keyword, found %s" word)) (funcall handler)))) - (if (eq (car loop-args) 'and) - (progn (pop loop-args) (cl-parse-loop-clause))))) + (if (eq (car cl--loop-args) 'and) + (progn (pop cl--loop-args) (cl-parse-loop-clause))))) -(defun cl-loop-let (specs body par) ; uses loop-* +(defun cl--loop-let (specs body par) ; uses loop-* (let ((p specs) (temps nil) (new nil)) - (while (and p (or (symbolp (car-safe (car p))) (null (cadar p)))) + (while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p)))) (setq p (cdr p))) (and par p (progn (setq par nil p specs) (while p - (or (cl-const-expr-p (cadar p)) + (or (macroexp-const-p (cl-cadar p)) (let ((temp (make-symbol "--cl-var--"))) - (push (list temp (cadar p)) temps) + (push (list temp (cl-cadar p)) temps) (setcar (cdar p) temp))) (setq p (cdr p))))) (while specs (if (and (consp (car specs)) (listp (caar specs))) (let* ((spec (caar specs)) (nspecs nil) (expr (cadr (pop specs))) - (temp (cdr (or (assq spec loop-destr-temps) + (temp (cdr (or (assq spec cl--loop-destr-temps) (car (push (cons spec (or (last spec 0) (make-symbol "--cl-var--"))) - loop-destr-temps)))))) + cl--loop-destr-temps)))))) (push (list temp expr) new) (while (consp spec) (push (list (pop spec) @@ -1176,27 +1408,27 @@ Valid clauses are: (setq specs (nconc (nreverse nspecs) specs))) (push (pop specs) new))) (if (eq body 'setq) - (let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new))))) - (if temps (list 'let* (nreverse temps) set) set)) - (list* (if par 'let 'let*) - (nconc (nreverse temps) (nreverse new)) body)))) - -(defun cl-loop-handle-accum (def &optional func) ; uses loop-* - (if (eq (car loop-args) 'into) - (let ((var (cl-pop2 loop-args))) - (or (memq var loop-accum-vars) - (progn (push (list (list var def)) loop-bindings) - (push var loop-accum-vars))) + (let ((set (cons (if par 'cl-psetq 'setq) (apply 'nconc (nreverse new))))) + (if temps `(let* ,(nreverse temps) ,set) set)) + `(,(if par 'let 'let*) + ,(nconc (nreverse temps) (nreverse new)) ,@body)))) + +(defun cl--loop-handle-accum (def &optional func) ; uses loop-* + (if (eq (car cl--loop-args) 'into) + (let ((var (cl-pop2 cl--loop-args))) + (or (memq var cl--loop-accum-vars) + (progn (push (list (list var def)) cl--loop-bindings) + (push var cl--loop-accum-vars))) var) - (or loop-accum-var + (or cl--loop-accum-var (progn - (push (list (list (setq loop-accum-var (make-symbol "--cl-var--")) def)) - loop-bindings) - (setq loop-result (if func (list func loop-accum-var) - loop-accum-var)) - loop-accum-var)))) + (push (list (list (setq cl--loop-accum-var (make-symbol "--cl-var--")) def)) + cl--loop-bindings) + (setq cl--loop-result (if func (list func cl--loop-accum-var) + cl--loop-accum-var)) + cl--loop-accum-var)))) -(defun cl-loop-build-ands (clauses) +(defun cl--loop-build-ands (clauses) (let ((ands nil) (body nil)) (while clauses @@ -1206,7 +1438,7 @@ Valid clauses are: (setq clauses (cons (nconc (butlast (car clauses)) (if (eq (car-safe (cadr clauses)) 'progn) - (cdadr clauses) + (cl-cdadr clauses) (list (cadr clauses)))) (cddr clauses))) (setq body (cdr (butlast (pop clauses))))) @@ -1223,51 +1455,55 @@ Valid clauses are: ;;; Other iteration control structures. ;;;###autoload -(defmacro do (steps endtest &rest body) - "The Common Lisp `do' loop. +(defmacro cl-do (steps endtest &rest body) + "The Common Lisp `cl-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 -(defmacro do* (steps endtest &rest body) - "The Common Lisp `do*' loop. +(defmacro cl-do* (steps endtest &rest body) + "The Common Lisp `cl-do*' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" + (declare (indent 2) (debug cl-do)) (cl-expand-do-loop steps endtest body t)) (defun cl-expand-do-loop (steps endtest body star) - (list 'block nil - (list* (if star 'let* 'let) - (mapcar (function (lambda (c) - (if (consp c) (list (car c) (nth 1 c)) c))) - steps) - (list* 'while (list 'not (car endtest)) - (append body - (let ((sets (mapcar - (function - (lambda (c) - (and (consp c) (cdr (cdr c)) - (list (car c) (nth 2 c))))) - steps))) - (setq sets (delq nil sets)) - (and sets - (list (cons (if (or star (not (cdr sets))) - 'setq 'psetq) - (apply 'append sets))))))) - (or (cdr endtest) '(nil))))) + `(cl-block nil + (,(if star 'let* 'let) + ,(mapcar (lambda (c) (if (consp c) (list (car c) (nth 1 c)) c)) + steps) + (while (not ,(car endtest)) + ,@body + ,@(let ((sets (mapcar (lambda (c) + (and (consp c) (cdr (cdr c)) + (list (car c) (nth 2 c)))) + steps))) + (setq sets (delq nil sets)) + (and sets + (list (cons (if (or star (not (cdr sets))) + 'setq 'cl-psetq) + (apply 'append sets)))))) + ,@(or (cdr endtest) '(nil))))) ;;;###autoload -(defmacro dolist (spec &rest body) +(defmacro cl-dolist (spec &rest body) "Loop over a list. Evaluate BODY with VAR bound to each `car' from LIST, in turn. 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 + `(cl-block nil ;; This is not a reliable test, but it does not matter because both ;; semantics are acceptable, tho one is slightly faster with dynamic ;; scoping and the other is slightly faster (and has cleaner semantics) @@ -1291,17 +1527,18 @@ An implicit nil block is established around the loop. `((setq ,(car spec) nil) ,@(cddr spec)))))))) ;;;###autoload -(defmacro dotimes (spec &rest body) +(defmacro cl-dotimes (spec &rest body) "Loop a certain number of times. Evaluate BODY with VAR bound to successive integers from 0, inclusive, to COUNT, exclusive. Then evaluate RESULT to get return value, default nil. \(fn (VAR COUNT [RESULT]) BODY...)" + (declare (debug cl-dolist)) (let ((temp (make-symbol "--cl-dotimes-temp--")) (end (nth 1 spec))) ;; FIXME: Copy&pasted from subr.el. - `(block nil + `(cl-block nil ;; This is not a reliable test, but it does not matter because both ;; semantics are acceptable, tho one is slightly faster with dynamic ;; scoping and the other has cleaner semantics. @@ -1320,266 +1557,259 @@ nil. (,(car spec) 0)) (while (< ,(car spec) ,temp) ,@body - (incf ,(car spec))) + (cl-incf ,(car spec))) ,@(cdr (cdr spec))))))) ;;;###autoload -(defmacro do-symbols (spec &rest body) +(defmacro cl-do-symbols (spec &rest body) "Loop over all symbols. 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)) - (list* 'mapatoms - (list 'function (list* 'lambda (list (car spec)) body)) - (and (cadr spec) (list (cadr spec)))) - (caddr spec)))) + `(cl-block nil + (let (,(car spec)) + (mapatoms #'(lambda (,(car spec)) ,@body) + ,@(and (cadr spec) (list (cadr spec)))) + ,(cl-caddr spec)))) ;;;###autoload -(defmacro do-all-symbols (spec &rest body) - (list* 'do-symbols (list (car spec) nil (cadr spec)) body)) +(defmacro cl-do-all-symbols (spec &rest body) + (declare (indent 1) (debug ((symbolp &optional form) cl-declarations body))) + `(cl-do-symbols (,(car spec) nil ,(cadr spec)) ,@body)) ;;; Assignments. ;;;###autoload -(defmacro psetq (&rest args) +(defmacro cl-psetq (&rest args) "Set SYMs to the values VALs in parallel. 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 ...)" - (cons 'psetf args)) + (declare (debug setq)) + (cons 'cl-psetf args)) ;;; Binding control structures. ;;;###autoload -(defmacro progv (symbols values &rest body) +(defmacro cl-progv (symbols values &rest body) "Bind SYMBOLS to VALUES dynamically in BODY. The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists. 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." - (list 'let '((cl-progv-save nil)) - (list 'unwind-protect - (list* 'progn (list 'cl-progv-before symbols values) body) - '(cl-progv-after)))) + (declare (indent 2) (debug (form form body))) + `(let ((cl-progv-save nil)) + (unwind-protect + (progn (cl-progv-before ,symbols ,values) ,@body) + (cl-progv-after)))) + +(defvar cl--labels-convert-cache nil) + +(defun cl--labels-convert (f) + "Special macro-expander to rename (function F) references in `cl-labels'." + (cond + ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked + ;; *after* handling `function', but we want to stop macroexpansion from + ;; being applied infinitely, so we use a cache to return the exact `form' + ;; being expanded even though we don't receive it. + ((eq f (car cl--labels-convert-cache)) (cdr cl--labels-convert-cache)) + (t + (let ((found (assq f macroexpand-all-environment))) + (if (and found (ignore-errors + (eq (cadr (cl-caddr found)) 'cl-labels-args))) + (cadr (cl-caddr (cl-cadddr found))) + (let ((res `(function ,f))) + (setq cl--labels-convert-cache (cons f res)) + res)))))) ;;; This should really have some way to shadow 'byte-compile properties, etc. ;;;###autoload -(defmacro flet (bindings &rest body) +(defmacro cl-flet (bindings &rest body) "Make temporary function definitions. -This is an analogue of `let' that operates on the function cell of FUNC -rather than its value cell. The FORMs are evaluated with the specified -function definitions in place, then the definitions are undone (the FUNCs -go back to their previous definitions, or lack thereof). +Like `cl-labels' but the definitions are not recursive. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (list* 'letf* - (mapcar - (function - (lambda (x) - (if (or (and (fboundp (car x)) - (eq (car-safe (symbol-function (car x))) 'macro)) - (cdr (assq (car x) cl-macro-environment))) - (error "Use `labels', not `flet', to rebind macro names")) - (let ((func (list 'function* - (list 'lambda (cadr x) - (list* 'block (car x) (cddr x)))))) - (when (cl-compiling-file) - ;; Bug#411. It would be nice to fix this. - (and (get (car x) 'byte-compile) - (error "Byte-compiling a redefinition of `%s' \ -will not work - use `labels' instead" (symbol-name (car x)))) - ;; FIXME This affects the rest of the file, when it - ;; should be restricted to the flet body. - (and (boundp 'byte-compile-function-environment) - (push (cons (car x) (eval func)) - byte-compile-function-environment))) - (list (list 'symbol-function (list 'quote (car x))) func)))) - bindings) - body)) + (declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body))) + (let ((binds ()) (newenv macroexpand-all-environment)) + (dolist (binding bindings) + (let ((var (make-symbol (format "--cl-%s--" (car binding))))) + (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) + (push (cons (car binding) + `(lambda (&rest cl-labels-args) + (cl-list* 'funcall ',var + cl-labels-args))) + newenv))) + `(let ,(nreverse binds) + ,@(macroexp-unprogn + (macroexpand-all + `(progn ,@body) + ;; Don't override lexical-let's macro-expander. + (if (assq 'function newenv) newenv + (cons (cons 'function #'cl--labels-convert) newenv))))))) ;;;###autoload -(defmacro labels (bindings &rest body) +(defmacro cl-labels (bindings &rest body) "Make temporary function bindings. -This is like `flet', except the bindings are lexical instead of dynamic. -Unlike `flet', this macro is fully compliant with the Common Lisp standard. +The bindings can be recursive. Assumes the use of `lexical-binding'. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) - (while bindings - ;; Use `gensym' rather than `make-symbol'. It's important that - ;; (not (eq (symbol-name var1) (symbol-name var2))) because these - ;; vars get added to the cl-macro-environment. - (let ((var (gensym "--cl-var--"))) - (push var vars) - (push (list 'function* (cons 'lambda (cdar bindings))) sets) - (push var sets) - (push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args) - (list 'list* '(quote funcall) (list 'quote var) - 'cl-labels-args)) - cl-macro-environment))) - (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body)) - cl-macro-environment))) + (declare (indent 1) (debug cl-flet)) + (let ((binds ()) (newenv macroexpand-all-environment)) + (dolist (binding bindings) + (let ((var (make-symbol (format "--cl-%s--" (car binding))))) + (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) + (push (cons (car binding) + `(lambda (&rest cl-labels-args) + (cl-list* 'funcall ',var + cl-labels-args))) + newenv))) + (macroexpand-all `(letrec ,(nreverse binds) ,@body) + ;; Don't override lexical-let's macro-expander. + (if (assq 'function newenv) newenv + (cons (cons 'function #'cl--labels-convert) newenv))))) ;; The following ought to have a better definition for use with newer ;; byte compilers. ;;;###autoload -(defmacro macrolet (bindings &rest body) +(defmacro cl-macrolet (bindings &rest body) "Make temporary macro definitions. -This is like `flet', but for macros instead of functions. +This is like `cl-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)) + `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body)) (if (null bindings) (cons 'progn body) (let* ((name (caar bindings)) - (res (cl-transform-lambda (cdar bindings) name))) + (res (cl--transform-lambda (cdar bindings) name))) (eval (car res)) - (cl-macroexpand-all (cons 'progn body) - (cons (list* name 'lambda (cdr res)) - cl-macro-environment)))))) + (macroexpand-all (cons 'progn body) + (cons (cons name `(lambda ,@(cdr res))) + macroexpand-all-environment)))))) + +(defconst cl--old-macroexpand + (if (and (boundp 'cl--old-macroexpand) + (eq (symbol-function 'macroexpand) + #'cl--sm-macroexpand)) + cl--old-macroexpand + (symbol-function 'macroexpand))) + +(defun cl--sm-macroexpand (cl-macro &optional cl-env) + "Special macro expander used inside `cl-symbol-macrolet'. +This function replaces `macroexpand' during macro expansion +of `cl-symbol-macrolet', and does the same thing as `macroexpand' +except that it additionally expands symbol macros." + (let ((macroexpand-all-environment cl-env)) + (while + (progn + (setq cl-macro (funcall cl--old-macroexpand cl-macro cl-env)) + (cond + ((symbolp cl-macro) + ;; Perform symbol-macro expansion. + (when (cdr (assq (symbol-name cl-macro) cl-env)) + (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env))))) + ((eq 'setq (car-safe cl-macro)) + ;; Convert setq to cl-setf if required by symbol-macro expansion. + (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f cl-env)) + (cdr cl-macro))) + (p args)) + (while (and p (symbolp (car p))) (setq p (cddr p))) + (if p (setq cl-macro (cons 'cl-setf args)) + (setq cl-macro (cons 'setq args)) + ;; Don't loop further. + nil)))))) + cl-macro)) ;;;###autoload -(defmacro symbol-macrolet (bindings &rest body) +(defmacro cl-symbol-macrolet (bindings &rest body) "Make symbol macro definitions. Within the body FORMs, references to the variable NAME will be replaced -by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). +by EXPANSION, and (setq NAME ...) will act like (cl-setf EXPANSION ...). \(fn ((NAME EXPANSION) ...) FORM...)" - (if (cdr bindings) - (list 'symbol-macrolet - (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body)) - (if (null bindings) (cons 'progn body) - (cl-macroexpand-all (cons 'progn body) + (declare (indent 1) (debug ((&rest (symbol sexp)) cl-declarations body))) + (cond + ((cdr bindings) + `(cl-symbol-macrolet (,(car bindings)) + (cl-symbol-macrolet ,(cdr bindings) ,@body))) + ((null bindings) (macroexp-progn body)) + (t + (let ((previous-macroexpand (symbol-function 'macroexpand))) + (unwind-protect + (progn + (fset 'macroexpand #'cl--sm-macroexpand) + ;; FIXME: For N bindings, this will traverse `body' N times! + (macroexpand-all (cons 'progn body) (cons (list (symbol-name (caar bindings)) - (cadar bindings)) - cl-macro-environment))))) - -(defvar cl-closure-vars nil) -;;;###autoload -(defmacro lexical-let (bindings &rest body) - "Like `let', but lexically scoped. -The main visible difference is that lambdas inside BODY will create -lexical closures as in Common Lisp. -\n(fn BINDINGS BODY)" - (let* ((cl-closure-vars cl-closure-vars) - (vars (mapcar (function - (lambda (x) - (or (consp x) (setq x (list x))) - (push (make-symbol (format "--cl-%s--" (car x))) - cl-closure-vars) - (set (car cl-closure-vars) [bad-lexical-ref]) - (list (car x) (cadr x) (car cl-closure-vars)))) - bindings)) - (ebody - (cl-macroexpand-all - (cons 'progn body) - (nconc (mapcar (function (lambda (x) - (list (symbol-name (car 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)) - (list 'let (mapcar (function (lambda (x) - (list (caddr x) - (list 'make-symbol - (format "--%s--" (car x)))))) - vars) - (apply 'append '(setf) - (mapcar (function - (lambda (x) - (list (list 'symbol-value (caddr x)) (cadr x)))) - vars)) - ebody)))) - -;;;###autoload -(defmacro lexical-let* (bindings &rest body) - "Like `let*', but lexically scoped. -The main visible difference is that lambdas inside BODY, and in -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)" - (if (null bindings) (cons 'progn body) - (setq bindings (reverse bindings)) - (while bindings - (setq body (list (list* 'lexical-let (list (pop bindings)) body)))) - (car body))) - -(defun cl-defun-expander (func &rest rest) - (list 'progn - (list 'defalias (list 'quote func) - (list 'function (cons 'lambda rest))) - (list 'quote func))) - + (cl-cadar bindings)) + macroexpand-all-environment))) + (fset 'macroexpand previous-macroexpand)))))) ;;; Multiple values. ;;;###autoload -(defmacro multiple-value-bind (vars form &rest body) +(defmacro cl-multiple-value-bind (vars form &rest body) "Collect multiple return values. FORM must return a list; the BODY is then executed with the first N elements of this list bound (`let'-style) to each of the symbols SYM in turn. This -is analogous to the Common Lisp `multiple-value-bind' macro, using lists to -simulate true multiple return values. For compatibility, (values A B C) is +is analogous to the Common Lisp `cl-multiple-value-bind' macro, using lists to +simulate true multiple return values. For compatibility, (cl-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 - (lambda (v) - (list v (list 'nth (setq n (1+ n)) temp)))) - vars)) - body))) + `(let* ((,temp ,form) + ,@(mapcar (lambda (v) + (list v `(nth ,(setq n (1+ n)) ,temp))) + vars)) + ,@body))) ;;;###autoload -(defmacro multiple-value-setq (vars form) +(defmacro cl-multiple-value-setq (vars form) "Collect multiple return values. FORM must return a list; the first N elements of this list are stored in each of the symbols SYM in turn. This is analogous to the Common Lisp -`multiple-value-setq' macro, using lists to simulate true multiple return -values. For compatibility, (values A B C) is a synonym for (list A B C). +`cl-multiple-value-setq' macro, using lists to simulate true multiple return +values. For compatibility, (cl-values A B C) is a synonym for (list A B C). \(fn (SYM...) FORM)" - (cond ((null vars) (list 'progn form nil)) - ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) + (declare (indent 1) (debug ((&rest symbolp) form))) + (cond ((null vars) `(progn ,form nil)) + ((null (cdr vars)) `(setq ,(car vars) (car ,form))) (t (let* ((temp (make-symbol "--cl-var--")) (n 0)) - (list 'let (list (list temp form)) - (list 'prog1 (list 'setq (pop vars) (list 'car temp)) - (cons 'setq (apply 'nconc - (mapcar (function - (lambda (v) - (list v (list - 'nth - (setq n (1+ n)) - temp)))) - vars))))))))) + `(let ((,temp ,form)) + (prog1 (setq ,(pop vars) (car ,temp)) + (setq ,@(apply #'nconc + (mapcar (lambda (v) + (list v `(nth ,(setq n (1+ n)) + ,temp))) + vars))))))))) ;;; Declarations. ;;;###autoload -(defmacro locally (&rest body) (cons 'progn body)) +(defmacro cl-locally (&rest body) + (declare (debug t)) + (cons 'progn body)) ;;;###autoload -(defmacro the (type form) form) +(defmacro cl-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 @@ -1618,7 +1848,7 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) (while (setq spec (cdr spec)) (if (consp (car spec)) - (if (eq (cadar spec) 0) + (if (eq (cl-cadar spec) 0) (byte-compile-disable-warning (caar spec)) (byte-compile-enable-warning (caar spec))))))) nil) @@ -1630,11 +1860,11 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). (setq cl-proclaims-deferred nil)) ;;;###autoload -(defmacro declare (&rest specs) +(defmacro cl-declare (&rest specs) "Declare SPECS about the current function while compiling. For instance - \(declare (warn 0)) + \(cl-declare (warn 0)) will turn off byte-compile warnings in the function. See Info node `(cl)Declarations' for details." @@ -1649,45 +1879,50 @@ See Info node `(cl)Declarations' for details." ;;; Generalized variables. ;;;###autoload -(defmacro define-setf-method (func args &rest body) - "Define a `setf' method. -This method shows how to handle `setf's to places of the form (NAME ARGS...). +(defmacro cl-define-setf-expander (func args &rest body) + "Define a `cl-setf' method. +This method shows how to handle `cl-setf's to places of the form (NAME ARGS...). The argument forms ARGS are bound according to ARGLIST, as if NAME were going to be expanded as a macro, then the BODY forms are executed and must return a list of five elements: a temporary-variables list, a value-forms 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. +form. See `cl-defsetf' for a simpler way to define most setf-methods. \(fn NAME ARGLIST BODY...)" - (append '(eval-when (compile load eval)) - (if (stringp (car body)) - (list (list 'put (list 'quote func) '(quote setf-documentation) - (pop body)))) - (list (cl-transform-function-property - func 'setf-method (cons args body))))) -(defalias 'define-setf-expander 'define-setf-method) + (declare (debug + (&define name cl-lambda-list cl-declarations-or-string def-body))) + `(cl-eval-when (compile load eval) + ,@(if (stringp (car body)) + (list `(put ',func 'setf-documentation ,(pop body)))) + ,(cl--transform-function-property + func 'setf-method (cons args body)))) ;;;###autoload -(defmacro defsetf (func arg1 &rest args) - "Define a `setf' method. -This macro is an easy-to-use substitute for `define-setf-method' that works -well for simple place forms. In the simple `defsetf' form, `setf's of -the form (setf (NAME ARGS...) VAL) are transformed to function or macro +(defmacro cl-defsetf (func arg1 &rest args) + "Define a `cl-setf' method. +This macro is an easy-to-use substitute for `cl-define-setf-expander' that works +well for simple place forms. In the simple `cl-defsetf' form, `cl-setf's of +the form (cl-setf (NAME ARGS...) VAL) are transformed to function or macro calls of the form (FUNC ARGS... VAL). Example: - (defsetf aref aset) + (cl-defsetf aref aset) -Alternate form: (defsetf NAME ARGLIST (STORE) BODY...). -Here, the above `setf' call is expanded by binding the argument forms ARGS +Alternate form: (cl-defsetf NAME ARGLIST (STORE) BODY...). +Here, the above `cl-setf' call is expanded by binding the argument forms ARGS according to ARGLIST, binding the value form VAL to STORE, then executing -BODY, which must return a Lisp form that does the necessary `setf' operation. +BODY, which must return a Lisp form that does the necessary `cl-setf' operation. Actually, ARGLIST and STORE may be bound to temporary variables which are introduced automatically to preserve proper execution order of the arguments. Example: - (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v)) + (cl-defsetf nth (n x) (v) `(setcar (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) @@ -1721,7 +1956,7 @@ Example: lets2 (cons (list (car p1) (car p2)) lets2) p1 (cdr p1) p2 (cdr p2)))) (if restarg (setq lets2 (cons (list restarg rest-temps) lets2))) - `(define-setf-method ,func ,arg1 + `(cl-define-setf-expander ,func ,arg1 ,@(and docstr (list docstr)) (let* ,(nreverse @@ -1734,17 +1969,17 @@ Example: ,@lets1) lets1))) (list ; 'values - (,(if restarg 'list* 'list) ,@tempsr) - (,(if restarg 'list* 'list) ,@largsr) + (,(if restarg 'cl-list* 'list) ,@tempsr) + (,(if restarg 'cl-list* 'list) ,@largsr) (list ,store-temp) (let* ,(nreverse (cons (list store-var store-temp) lets2)) ,@args) - (,(if restarg 'list* 'list) - ,@(cons (list 'quote func) tempsr)))))) - `(defsetf ,func (&rest args) (store) + (,(if restarg 'cl-list* 'list) + ,@(cons `',func tempsr)))))) + `(cl-defsetf ,func (&rest args) (store) ,(let ((call `(cons ',arg1 (append args (list store))))) (if (car args) @@ -1752,130 +1987,130 @@ Example: call))))) ;;; Some standard place types from Common Lisp. -(defsetf aref aset) -(defsetf car setcar) -(defsetf cdr setcdr) -(defsetf caar (x) (val) (list 'setcar (list 'car x) val)) -(defsetf cadr (x) (val) (list 'setcar (list 'cdr x) val)) -(defsetf cdar (x) (val) (list 'setcdr (list 'car x) val)) -(defsetf cddr (x) (val) (list 'setcdr (list 'cdr x) val)) -(defsetf elt (seq n) (store) - (list 'if (list 'listp seq) (list 'setcar (list 'nthcdr n seq) store) - (list 'aset seq n store))) -(defsetf get put) -(defsetf get* (x y &optional d) (store) (list 'put x y store)) -(defsetf gethash (x h &optional d) (store) (list 'puthash x store h)) -(defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store)) -(defsetf subseq (seq start &optional end) (new) - (list 'progn (list 'replace seq new :start1 start :end1 end) new)) -(defsetf symbol-function fset) -(defsetf symbol-plist setplist) -(defsetf symbol-value set) +(cl-defsetf aref aset) +(cl-defsetf car setcar) +(cl-defsetf cdr setcdr) +(cl-defsetf caar (x) (val) `(setcar (car ,x) ,val)) +(cl-defsetf cadr (x) (val) `(setcar (cdr ,x) ,val)) +(cl-defsetf cdar (x) (val) `(setcdr (car ,x) ,val)) +(cl-defsetf cddr (x) (val) `(setcdr (cdr ,x) ,val)) +(cl-defsetf elt (seq n) (store) + `(if (listp ,seq) (setcar (nthcdr ,n ,seq) ,store) + (aset ,seq ,n ,store))) +(cl-defsetf get put) +(cl-defsetf cl-get (x y &optional d) (store) `(put ,x ,y ,store)) +(cl-defsetf gethash (x h &optional d) (store) `(puthash ,x ,store ,h)) +(cl-defsetf nth (n x) (store) `(setcar (nthcdr ,n ,x) ,store)) +(cl-defsetf cl-subseq (seq start &optional end) (new) + `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) ,new)) +(cl-defsetf symbol-function fset) +(cl-defsetf symbol-plist setplist) +(cl-defsetf symbol-value set) ;;; Various car/cdr aliases. Note that `cadr' is handled specially. -(defsetf first setcar) -(defsetf second (x) (store) (list 'setcar (list 'cdr x) store)) -(defsetf third (x) (store) (list 'setcar (list 'cddr x) store)) -(defsetf fourth (x) (store) (list 'setcar (list 'cdddr x) store)) -(defsetf fifth (x) (store) (list 'setcar (list 'nthcdr 4 x) store)) -(defsetf sixth (x) (store) (list 'setcar (list 'nthcdr 5 x) store)) -(defsetf seventh (x) (store) (list 'setcar (list 'nthcdr 6 x) store)) -(defsetf eighth (x) (store) (list 'setcar (list 'nthcdr 7 x) store)) -(defsetf ninth (x) (store) (list 'setcar (list 'nthcdr 8 x) store)) -(defsetf tenth (x) (store) (list 'setcar (list 'nthcdr 9 x) store)) -(defsetf rest setcdr) +(cl-defsetf cl-first setcar) +(cl-defsetf cl-second (x) (store) `(setcar (cdr ,x) ,store)) +(cl-defsetf cl-third (x) (store) `(setcar (cddr ,x) ,store)) +(cl-defsetf cl-fourth (x) (store) `(setcar (cl-cdddr ,x) ,store)) +(cl-defsetf cl-fifth (x) (store) `(setcar (nthcdr 4 ,x) ,store)) +(cl-defsetf cl-sixth (x) (store) `(setcar (nthcdr 5 ,x) ,store)) +(cl-defsetf cl-seventh (x) (store) `(setcar (nthcdr 6 ,x) ,store)) +(cl-defsetf cl-eighth (x) (store) `(setcar (nthcdr 7 ,x) ,store)) +(cl-defsetf cl-ninth (x) (store) `(setcar (nthcdr 8 ,x) ,store)) +(cl-defsetf cl-tenth (x) (store) `(setcar (nthcdr 9 ,x) ,store)) +(cl-defsetf cl-rest setcdr) ;;; Some more Emacs-related place types. -(defsetf buffer-file-name set-visited-file-name t) -(defsetf buffer-modified-p (&optional buf) (flag) - (list 'with-current-buffer buf - (list 'set-buffer-modified-p flag))) -(defsetf buffer-name rename-buffer t) -(defsetf buffer-string () (store) - (list 'progn '(erase-buffer) (list 'insert store))) -(defsetf buffer-substring cl-set-buffer-substring) -(defsetf current-buffer set-buffer) -(defsetf current-case-table set-case-table) -(defsetf current-column move-to-column t) -(defsetf current-global-map use-global-map t) -(defsetf current-input-mode () (store) - (list 'progn (list 'apply 'set-input-mode store) store)) -(defsetf current-local-map use-local-map t) -(defsetf current-window-configuration set-window-configuration t) -(defsetf default-file-modes set-default-file-modes t) -(defsetf default-value set-default) -(defsetf documentation-property put) -(defsetf face-background (f &optional s) (x) (list 'set-face-background f x s)) -(defsetf face-background-pixmap (f &optional s) (x) - (list 'set-face-background-pixmap f x s)) -(defsetf face-font (f &optional s) (x) (list 'set-face-font f x s)) -(defsetf face-foreground (f &optional s) (x) (list 'set-face-foreground f x s)) -(defsetf face-underline-p (f &optional s) (x) - (list 'set-face-underline-p f x s)) -(defsetf file-modes set-file-modes t) -(defsetf frame-height set-screen-height t) -(defsetf frame-parameters modify-frame-parameters t) -(defsetf frame-visible-p cl-set-frame-visible-p) -(defsetf frame-width set-screen-width t) -(defsetf frame-parameter set-frame-parameter t) -(defsetf terminal-parameter set-terminal-parameter) -(defsetf getenv setenv t) -(defsetf get-register set-register) -(defsetf global-key-binding global-set-key) -(defsetf keymap-parent set-keymap-parent) -(defsetf local-key-binding local-set-key) -(defsetf mark set-mark t) -(defsetf mark-marker set-mark t) -(defsetf marker-position set-marker t) -(defsetf match-data set-match-data t) -(defsetf mouse-position (scr) (store) - (list 'set-mouse-position scr (list 'car store) (list 'cadr store) - (list 'cddr store))) -(defsetf overlay-get overlay-put) -(defsetf overlay-start (ov) (store) - (list 'progn (list 'move-overlay ov store (list 'overlay-end ov)) store)) -(defsetf overlay-end (ov) (store) - (list 'progn (list 'move-overlay ov (list 'overlay-start ov) store) store)) -(defsetf point goto-char) -(defsetf point-marker goto-char t) -(defsetf point-max () (store) - (list 'progn (list 'narrow-to-region '(point-min) store) store)) -(defsetf point-min () (store) - (list 'progn (list 'narrow-to-region store '(point-max)) store)) -(defsetf process-buffer set-process-buffer) -(defsetf process-filter set-process-filter) -(defsetf process-sentinel set-process-sentinel) -(defsetf process-get process-put) -(defsetf read-mouse-position (scr) (store) - (list 'set-mouse-position scr (list 'car store) (list 'cdr store))) -(defsetf screen-height set-screen-height t) -(defsetf screen-width set-screen-width t) -(defsetf selected-window select-window) -(defsetf selected-screen select-screen) -(defsetf selected-frame select-frame) -(defsetf standard-case-table set-standard-case-table) -(defsetf syntax-table set-syntax-table) -(defsetf visited-file-modtime set-visited-file-modtime t) -(defsetf window-buffer set-window-buffer t) -(defsetf window-display-table set-window-display-table t) -(defsetf window-dedicated-p set-window-dedicated-p t) -(defsetf window-height () (store) - (list 'progn (list 'enlarge-window (list '- store '(window-height))) store)) -(defsetf window-hscroll set-window-hscroll) -(defsetf window-parameter set-window-parameter) -(defsetf window-point set-window-point) -(defsetf window-start set-window-start) -(defsetf window-width () (store) - (list 'progn (list 'enlarge-window (list '- store '(window-width)) t) store)) -(defsetf x-get-secondary-selection x-own-secondary-selection t) -(defsetf x-get-selection x-own-selection t) - -;; This is a hack that allows (setf (eq a 7) B) to mean either +(cl-defsetf buffer-file-name set-visited-file-name t) +(cl-defsetf buffer-modified-p (&optional buf) (flag) + `(with-current-buffer ,buf + (set-buffer-modified-p ,flag))) +(cl-defsetf buffer-name rename-buffer t) +(cl-defsetf buffer-string () (store) + `(progn (erase-buffer) (insert ,store))) +(cl-defsetf buffer-substring cl-set-buffer-substring) +(cl-defsetf current-buffer set-buffer) +(cl-defsetf current-case-table set-case-table) +(cl-defsetf current-column move-to-column t) +(cl-defsetf current-global-map use-global-map t) +(cl-defsetf current-input-mode () (store) + `(progn (apply #'set-input-mode ,store) ,store)) +(cl-defsetf current-local-map use-local-map t) +(cl-defsetf current-window-configuration set-window-configuration t) +(cl-defsetf default-file-modes set-default-file-modes t) +(cl-defsetf default-value set-default) +(cl-defsetf documentation-property put) +(cl-defsetf face-background (f &optional s) (x) `(set-face-background ,f ,x ,s)) +(cl-defsetf face-background-pixmap (f &optional s) (x) + `(set-face-background-pixmap ,f ,x ,s)) +(cl-defsetf face-font (f &optional s) (x) `(set-face-font ,f ,x ,s)) +(cl-defsetf face-foreground (f &optional s) (x) `(set-face-foreground ,f ,x ,s)) +(cl-defsetf face-underline-p (f &optional s) (x) + `(set-face-underline-p ,f ,x ,s)) +(cl-defsetf file-modes set-file-modes t) +(cl-defsetf frame-height set-screen-height t) +(cl-defsetf frame-parameters modify-frame-parameters t) +(cl-defsetf frame-visible-p cl-set-frame-visible-p) +(cl-defsetf frame-width set-screen-width t) +(cl-defsetf frame-parameter set-frame-parameter t) +(cl-defsetf terminal-parameter set-terminal-parameter) +(cl-defsetf getenv setenv t) +(cl-defsetf get-register set-register) +(cl-defsetf global-key-binding global-set-key) +(cl-defsetf keymap-parent set-keymap-parent) +(cl-defsetf local-key-binding local-set-key) +(cl-defsetf mark set-mark t) +(cl-defsetf mark-marker set-mark t) +(cl-defsetf marker-position set-marker t) +(cl-defsetf match-data set-match-data t) +(cl-defsetf mouse-position (scr) (store) + `(set-mouse-position ,scr (car ,store) (cadr ,store) + (cddr ,store))) +(cl-defsetf overlay-get overlay-put) +(cl-defsetf overlay-start (ov) (store) + `(progn (move-overlay ,ov ,store (overlay-end ,ov)) ,store)) +(cl-defsetf overlay-end (ov) (store) + `(progn (move-overlay ,ov (overlay-start ,ov) ,store) ,store)) +(cl-defsetf point goto-char) +(cl-defsetf point-marker goto-char t) +(cl-defsetf point-max () (store) + `(progn (narrow-to-region (point-min) ,store) ,store)) +(cl-defsetf point-min () (store) + `(progn (narrow-to-region ,store (point-max)) ,store)) +(cl-defsetf process-buffer set-process-buffer) +(cl-defsetf process-filter set-process-filter) +(cl-defsetf process-sentinel set-process-sentinel) +(cl-defsetf process-get process-put) +(cl-defsetf read-mouse-position (scr) (store) + `(set-mouse-position ,scr (car ,store) (cdr ,store))) +(cl-defsetf screen-height set-screen-height t) +(cl-defsetf screen-width set-screen-width t) +(cl-defsetf selected-window select-window) +(cl-defsetf selected-screen select-screen) +(cl-defsetf selected-frame select-frame) +(cl-defsetf standard-case-table set-standard-case-table) +(cl-defsetf syntax-table set-syntax-table) +(cl-defsetf visited-file-modtime set-visited-file-modtime t) +(cl-defsetf window-buffer set-window-buffer t) +(cl-defsetf window-display-table set-window-display-table t) +(cl-defsetf window-dedicated-p set-window-dedicated-p t) +(cl-defsetf window-height () (store) + `(progn (enlarge-window (- ,store (window-height))) ,store)) +(cl-defsetf window-hscroll set-window-hscroll) +(cl-defsetf window-parameter set-window-parameter) +(cl-defsetf window-point set-window-point) +(cl-defsetf window-start set-window-start) +(cl-defsetf window-width () (store) + `(progn (enlarge-window (- ,store (window-width)) t) ,store)) +(cl-defsetf x-get-secondary-selection x-own-secondary-selection t) +(cl-defsetf x-get-selection x-own-selection t) + +;; This is a hack that allows (cl-setf (eq a 7) B) to mean either ;; (setq a 7) or (setq a nil) depending on whether B is nil or not. ;; This is useful when you have control over the PLACE but not over ;; the VALUE, as is the case in define-minor-mode's :variable. -(define-setf-method eq (place val) - (let ((method (get-setf-method place cl-macro-environment)) +(cl-define-setf-expander eq (place val) + (let ((method (cl-get-setf-method place macroexpand-all-environment)) (val-temp (make-symbol "--eq-val--")) (store-temp (make-symbol "--eq-store--"))) (list (append (nth 0 method) (list val-temp)) @@ -1889,258 +2124,258 @@ Example: ;;; More complex setf-methods. ;; These should take &environment arguments, but since full arglists aren't ;; available while compiling cl-macs, we fake it by referring to the global -;; variable cl-macro-environment directly. +;; variable macroexpand-all-environment directly. -(define-setf-method apply (func arg1 &rest rest) - (or (and (memq (car-safe func) '(quote function function*)) +(cl-define-setf-expander apply (func arg1 &rest rest) + (or (and (memq (car-safe func) '(quote function cl-function)) (symbolp (car-safe (cdr-safe func)))) - (error "First arg to apply in setf is not (function SYM): %s" func)) + (error "First arg to apply in cl-setf is not (function SYM): %s" func)) (let* ((form (cons (nth 1 func) (cons arg1 rest))) - (method (get-setf-method form cl-macro-environment))) + (method (cl-get-setf-method form macroexpand-all-environment))) (list (car method) (nth 1 method) (nth 2 method) (cl-setf-make-apply (nth 3 method) (cadr func) (car method)) (cl-setf-make-apply (nth 4 method) (cadr func) (car method))))) (defun cl-setf-make-apply (form func temps) (if (eq (car form) 'progn) - (list* 'progn (cl-setf-make-apply (cadr form) func temps) (cddr form)) + `(progn ,(cl-setf-make-apply (cadr form) func temps) ,@(cddr form)) (or (equal (last form) (last temps)) (error "%s is not suitable for use with setf-of-apply" func)) - (list* 'apply (list 'quote (car form)) (cdr form)))) + `(apply ',(car form) ,@(cdr form)))) -(define-setf-method nthcdr (n place) - (let ((method (get-setf-method place cl-macro-environment)) +(cl-define-setf-expander nthcdr (n place) + (let ((method (cl-get-setf-method place macroexpand-all-environment)) (n-temp (make-symbol "--cl-nthcdr-n--")) (store-temp (make-symbol "--cl-nthcdr-store--"))) (list (cons n-temp (car method)) (cons n (nth 1 method)) (list store-temp) - (list 'let (list (list (car (nth 2 method)) - (list 'cl-set-nthcdr n-temp (nth 4 method) - store-temp))) - (nth 3 method) store-temp) - (list 'nthcdr n-temp (nth 4 method))))) - -(define-setf-method getf (place tag &optional def) - (let ((method (get-setf-method place cl-macro-environment)) + `(let ((,(car (nth 2 method)) + (cl-set-nthcdr ,n-temp ,(nth 4 method) + ,store-temp))) + ,(nth 3 method) ,store-temp) + `(nthcdr ,n-temp ,(nth 4 method))))) + +(cl-define-setf-expander cl-getf (place tag &optional def) + (let ((method (cl-get-setf-method place macroexpand-all-environment)) (tag-temp (make-symbol "--cl-getf-tag--")) (def-temp (make-symbol "--cl-getf-def--")) (store-temp (make-symbol "--cl-getf-store--"))) (list (append (car method) (list tag-temp def-temp)) (append (nth 1 method) (list tag def)) (list store-temp) - (list 'let (list (list (car (nth 2 method)) - (list 'cl-set-getf (nth 4 method) - tag-temp store-temp))) - (nth 3 method) store-temp) - (list 'getf (nth 4 method) tag-temp def-temp)))) - -(define-setf-method substring (place from &optional to) - (let ((method (get-setf-method place cl-macro-environment)) + `(let ((,(car (nth 2 method)) + (cl-set-getf ,(nth 4 method) ,tag-temp ,store-temp))) + ,(nth 3 method) ,store-temp) + `(cl-getf ,(nth 4 method) ,tag-temp ,def-temp)))) + +(cl-define-setf-expander substring (place from &optional to) + (let ((method (cl-get-setf-method place macroexpand-all-environment)) (from-temp (make-symbol "--cl-substring-from--")) (to-temp (make-symbol "--cl-substring-to--")) (store-temp (make-symbol "--cl-substring-store--"))) (list (append (car method) (list from-temp to-temp)) (append (nth 1 method) (list from to)) (list store-temp) - (list 'let (list (list (car (nth 2 method)) - (list 'cl-set-substring (nth 4 method) - from-temp to-temp store-temp))) - (nth 3 method) store-temp) - (list 'substring (nth 4 method) from-temp to-temp)))) + `(let ((,(car (nth 2 method)) + (cl-set-substring ,(nth 4 method) + ,from-temp ,to-temp ,store-temp))) + ,(nth 3 method) ,store-temp) + `(substring ,(nth 4 method) ,from-temp ,to-temp)))) ;;; Getting and optimizing setf-methods. ;;;###autoload -(defun get-setf-method (place &optional env) +(defun cl-get-setf-method (place &optional env) "Return a list of five values describing the setf-method for PLACE. PLACE may be any Lisp form which can appear as the PLACE argument to -a macro like `setf' or `incf'." +a macro like `cl-setf' or `cl-incf'." (if (symbolp place) (let ((temp (make-symbol "--cl-setf--"))) - (list nil nil (list temp) (list 'setq place temp) place)) + (list nil nil (list temp) `(setq ,place ,temp) place)) (or (and (symbolp (car place)) (let* ((func (car place)) (name (symbol-name func)) (method (get func 'setf-method)) (case-fold-search nil)) (or (and method - (let ((cl-macro-environment env)) + (let ((macroexpand-all-environment env)) (setq method (apply method (cdr place)))) (if (and (consp method) (= (length method) 5)) method (error "Setf-method for %s returns malformed method" func))) (and (string-match-p "\\`c[ad][ad][ad]?[ad]?r\\'" name) - (get-setf-method (compiler-macroexpand place))) + (cl-get-setf-method (cl-compiler-macroexpand place))) (and (eq func 'edebug-after) - (get-setf-method (nth (1- (length place)) place) + (cl-get-setf-method (nth (1- (length place)) place) env))))) (if (eq place (setq place (macroexpand place env))) (if (and (symbolp (car place)) (fboundp (car place)) (symbolp (symbol-function (car place)))) - (get-setf-method (cons (symbol-function (car place)) + (cl-get-setf-method (cons (symbol-function (car place)) (cdr place)) env) (error "No setf-method known for %s" (car place))) - (get-setf-method place env))))) + (cl-get-setf-method place env))))) (defun cl-setf-do-modify (place opt-expr) - (let* ((method (get-setf-method place cl-macro-environment)) + (let* ((method (cl-get-setf-method place macroexpand-all-environment)) (temps (car method)) (values (nth 1 method)) (lets nil) (subs nil) (optimize (and (not (eq opt-expr 'no-opt)) (or (and (not (eq opt-expr 'unsafe)) - (cl-safe-expr-p opt-expr)) + (cl--safe-expr-p opt-expr)) (cl-setf-simple-store-p (car (nth 2 method)) (nth 3 method))))) - (simple (and optimize (consp place) (cl-simple-exprs-p (cdr place))))) + (simple (and optimize (consp place) (cl--simple-exprs-p (cdr place))))) (while values - (if (or simple (cl-const-expr-p (car values))) + (if (or simple (macroexp-const-p (car values))) (push (cons (pop temps) (pop values)) subs) (push (list (pop temps) (pop values)) lets))) (list (nreverse lets) - (cons (car (nth 2 method)) (sublis subs (nth 3 method))) - (sublis subs (nth 4 method))))) + (cons (car (nth 2 method)) (cl-sublis subs (nth 3 method))) + (cl-sublis subs (nth 4 method))))) (defun cl-setf-do-store (spec val) (let ((sym (car spec)) (form (cdr spec))) - (if (or (cl-const-expr-p val) - (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1)) + (if (or (macroexp-const-p val) + (and (cl--simple-expr-p val) (eq (cl--expr-contains form sym) 1)) (cl-setf-simple-store-p sym form)) - (subst val sym form) - (list 'let (list (list sym val)) form)))) + (cl-subst val sym form) + `(let ((,sym ,val)) ,form)))) (defun cl-setf-simple-store-p (sym form) - (and (consp form) (eq (cl-expr-contains form sym) 1) + (and (consp form) (eq (cl--expr-contains form sym) 1) (eq (nth (1- (length form)) form) sym) (symbolp (car form)) (fboundp (car form)) (not (eq (car-safe (symbol-function (car form))) 'macro)))) ;;; The standard modify macros. ;;;###autoload -(defmacro setf (&rest args) +(defmacro cl-setf (&rest args) "Set each PLACE to the value of its VAL. This is a generalized version of `setq'; the PLACEs may be symbolic references such as (car x) or (aref x i), as well as plain symbols. -For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y). +For example, (cl-setf (cl-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)) + (while args (push `(cl-setf ,(pop args) ,(pop args)) sets)) (cons 'progn (nreverse sets))) (if (symbolp (car args)) (and args (cons 'setq args)) (let* ((method (cl-setf-do-modify (car args) (nth 1 args))) (store (cl-setf-do-store (nth 1 method) (nth 1 args)))) - (if (car method) (list 'let* (car method) store) store))))) + (if (car method) `(let* ,(car method) ,store) store))))) ;;;###autoload -(defmacro psetf (&rest args) +(defmacro cl-psetf (&rest args) "Set PLACEs to the values VALs in parallel. -This is like `setf', except that all VAL forms are evaluated (in order) +This is like `cl-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 cl-setf)) (let ((p args) (simple t) (vars nil)) (while p - (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars)) + (if (or (not (symbolp (car p))) (cl--expr-depends-p (nth 1 p) vars)) (setq simple nil)) (if (memq (car p) vars) (error "Destination duplicated in psetf: %s" (car p))) (push (pop p) vars) - (or p (error "Odd number of arguments to psetf")) + (or p (error "Odd number of arguments to cl-psetf")) (pop p)) (if simple - (list 'progn (cons 'setf args) nil) + `(progn (cl-setf ,@args) nil) (setq args (reverse args)) - (let ((expr (list 'setf (cadr args) (car args)))) + (let ((expr `(cl-setf ,(cadr args) ,(car args)))) (while (setq args (cddr args)) - (setq expr (list 'setf (cadr args) (list 'prog1 (car args) expr)))) - (list 'progn expr nil))))) + (setq expr `(cl-setf ,(cadr args) (prog1 ,(car args) ,expr)))) + `(progn ,expr nil))))) ;;;###autoload (defun cl-do-pop (place) - (if (cl-simple-expr-p place) - (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place))) + (if (cl--simple-expr-p place) + `(prog1 (car ,place) (cl-setf ,place (cdr ,place))) (let* ((method (cl-setf-do-modify place t)) (temp (make-symbol "--cl-pop--"))) - (list 'let* - (append (car method) - (list (list temp (nth 2 method)))) - (list 'prog1 - (list 'car temp) - (cl-setf-do-store (nth 1 method) (list 'cdr temp))))))) + `(let* (,@(car method) + (,temp ,(nth 2 method))) + (prog1 (car ,temp) + ,(cl-setf-do-store (nth 1 method) `(cdr ,temp))))))) ;;;###autoload -(defmacro remf (place tag) +(defmacro cl-remf (place tag) "Remove TAG from property list PLACE. -PLACE may be a symbol, or any generalized variable allowed by `setf'. +PLACE may be a symbol, or any generalized variable allowed by `cl-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)) + (tag-temp (and (not (macroexp-const-p tag)) (make-symbol "--cl-remf-tag--"))) + (val-temp (and (not (cl--simple-expr-p place)) (make-symbol "--cl-remf-place--"))) (ttag (or tag-temp tag)) (tval (or val-temp (nth 2 method)))) - (list 'let* - (append (car method) - (and val-temp (list (list val-temp (nth 2 method)))) - (and tag-temp (list (list tag-temp tag)))) - (list 'if (list 'eq ttag (list 'car tval)) - (list 'progn - (cl-setf-do-store (nth 1 method) (list 'cddr tval)) - t) - (list 'cl-do-remf tval ttag))))) + `(let* (,@(car method) + ,@(and val-temp `((,val-temp ,(nth 2 method)))) + ,@(and tag-temp `((,tag-temp ,tag)))) + (if (eq ,ttag (car ,tval)) + (progn ,(cl-setf-do-store (nth 1 method) `(cddr ,tval)) + t) + `(cl-do-remf ,tval ,ttag))))) ;;;###autoload -(defmacro shiftf (place &rest args) +(defmacro cl-shiftf (place &rest args) "Shift left among PLACEs. -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'. +Example: (cl-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 `cl-setf'. \(fn PLACE... VAL)" + (declare (debug (&rest place))) (cond ((null args) place) - ((symbolp place) `(prog1 ,place (setq ,place (shiftf ,@args)))) + ((symbolp place) `(prog1 ,place (setq ,place (cl-shiftf ,@args)))) (t (let ((method (cl-setf-do-modify place 'unsafe))) `(let* ,(car method) (prog1 ,(nth 2 method) - ,(cl-setf-do-store (nth 1 method) `(shiftf ,@args)))))))) + ,(cl-setf-do-store (nth 1 method) `(cl-shiftf ,@args)))))))) ;;;###autoload -(defmacro rotatef (&rest args) +(defmacro cl-rotatef (&rest args) "Rotate left among PLACEs. -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'. +Example: (cl-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 `cl-setf'. \(fn PLACE...)" + (declare (debug (&rest place))) (if (not (memq nil (mapcar 'symbolp args))) (and (cdr args) (let ((sets nil) (first (car args))) (while (cdr args) (setq sets (nconc sets (list (pop args) (car args))))) - (nconc (list 'psetf) sets (list (car args) first)))) + `(cl-psetf ,@sets ,(car args) ,first))) (let* ((places (reverse args)) (temp (make-symbol "--cl-rotatef--")) (form temp)) (while (cdr places) (let ((method (cl-setf-do-modify (pop places) 'unsafe))) - (setq form (list 'let* (car method) - (list 'prog1 (nth 2 method) - (cl-setf-do-store (nth 1 method) form)))))) + (setq form `(let* ,(car method) + (prog1 ,(nth 2 method) + ,(cl-setf-do-store (nth 1 method) form)))))) (let ((method (cl-setf-do-modify (car places) 'unsafe))) - (list 'let* (append (car method) (list (list temp (nth 2 method)))) - (cl-setf-do-store (nth 1 method) form) nil))))) + `(let* (,@(car method) (,temp ,(nth 2 method))) + ,(cl-setf-do-store (nth 1 method) form) nil))))) ;;;###autoload -(defmacro letf (bindings &rest body) +(defmacro cl-letf (bindings &rest body) "Temporarily bind to PLACEs. This is the analogue of `let', but with generalized variables (in the -sense of `setf') for the PLACEs. Each PLACE is set to the corresponding +sense of `cl-setf') for the PLACEs. Each PLACE is set to the corresponding VALUE, then the BODY forms are executed. On exit, either normally or because of a `throw' or error, the PLACEs are set back to their original values. Note that this macro is *not* available in Common Lisp. @@ -2148,20 +2383,21 @@ 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) - (unsets nil) (rev (reverse bindings))) + `(let ,bindings ,@body) + (let ((lets nil) + (rev (reverse bindings))) (while rev (let* ((place (if (symbolp (caar rev)) - (list 'symbol-value (list 'quote (caar rev))) + `(symbol-value ',(caar rev)) (caar rev))) - (value (cadar rev)) + (value (cl-cadar rev)) (method (cl-setf-do-modify place 'no-opt)) (save (make-symbol "--cl-letf-save--")) (bound (and (memq (car place) '(symbol-value symbol-function)) (make-symbol "--cl-letf-bound--"))) - (temp (and (not (cl-const-expr-p value)) (cdr bindings) + (temp (and (not (macroexp-const-p value)) (cdr bindings) (make-symbol "--cl-letf-val--")))) (setq lets (nconc (car method) (if bound @@ -2170,34 +2406,35 @@ the PLACE is not modified before executing BODY. 'symbol-value) 'boundp 'fboundp) (nth 1 (nth 2 method)))) - (list save (list 'and bound - (nth 2 method)))) + (list save `(and ,bound + ,(nth 2 method)))) (list (list save (nth 2 method)))) (and temp (list (list temp value))) lets) body (list - (list 'unwind-protect - (cons 'progn - (if (cdr (car rev)) - (cons (cl-setf-do-store (nth 1 method) - (or temp value)) - body) - body)) - (if bound - (list 'if bound - (cl-setf-do-store (nth 1 method) save) - (list (if (eq (car place) 'symbol-value) - 'makunbound 'fmakunbound) - (nth 1 (nth 2 method)))) - (cl-setf-do-store (nth 1 method) save)))) + `(unwind-protect + (progn + ,@(if (cdr (car rev)) + (cons (cl-setf-do-store (nth 1 method) + (or temp value)) + body) + body)) + ,(if bound + `(if ,bound + ,(cl-setf-do-store (nth 1 method) save) + (,(if (eq (car place) 'symbol-value) + #'makunbound #'fmakunbound) + ,(nth 1 (nth 2 method)))) + (cl-setf-do-store (nth 1 method) save)))) rev (cdr rev)))) - (list* 'let* lets body)))) + `(let* ,lets ,@body)))) + ;;;###autoload -(defmacro letf* (bindings &rest body) +(defmacro cl-letf* (bindings &rest body) "Temporarily bind to PLACEs. This is the analogue of `let*', but with generalized variables (in the -sense of `setf') for the PLACEs. Each PLACE is set to the corresponding +sense of `cl-setf') for the PLACEs. Each PLACE is set to the corresponding VALUE, then the BODY forms are executed. On exit, either normally or because of a `throw' or error, the PLACEs are set back to their original values. Note that this macro is *not* available in Common Lisp. @@ -2205,67 +2442,72 @@ 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 cl-letf)) (if (null bindings) (cons 'progn body) (setq bindings (reverse bindings)) (while bindings - (setq body (list (list* 'letf (list (pop bindings)) body)))) + (setq body (list `(cl-letf (,(pop bindings)) ,@body)))) (car body))) ;;;###autoload -(defmacro callf (func place &rest args) +(defmacro cl-callf (func place &rest args) "Set PLACE to (FUNC PLACE ARGS...). FUNC should be an unquoted function name. PLACE may be a symbol, -or any generalized variable allowed by `setf'. +or any generalized variable allowed by `cl-setf'. \(fn FUNC PLACE ARGS...)" + (declare (indent 2) (debug (cl-function place &rest form))) (let* ((method (cl-setf-do-modify place (cons 'list args))) (rargs (cons (nth 2 method) args))) - (list 'let* (car method) - (cl-setf-do-store (nth 1 method) - (if (symbolp func) (cons func rargs) - (list* 'funcall (list 'function func) - rargs)))))) + `(let* ,(car method) + ,(cl-setf-do-store (nth 1 method) + (if (symbolp func) (cons func rargs) + `(funcall #',func ,@rargs)))))) ;;;###autoload -(defmacro callf2 (func arg1 place &rest args) +(defmacro cl-callf2 (func arg1 place &rest args) "Set PLACE to (FUNC ARG1 PLACE ARGS...). -Like `callf', but PLACE is the second argument of FUNC, not the first. +Like `cl-callf', but PLACE is the second argument of FUNC, not the first. \(fn FUNC ARG1 PLACE ARGS...)" - (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func)) - (list 'setf place (list* func arg1 place args)) + (declare (indent 3) (debug (cl-function form place &rest form))) + (if (and (cl--safe-expr-p arg1) (cl--simple-expr-p place) (symbolp func)) + `(cl-setf ,place (,func ,arg1 ,place ,@args)) (let* ((method (cl-setf-do-modify place (cons 'list args))) - (temp (and (not (cl-const-expr-p arg1)) (make-symbol "--cl-arg1--"))) - (rargs (list* (or temp arg1) (nth 2 method) args))) - (list 'let* (append (and temp (list (list temp arg1))) (car method)) - (cl-setf-do-store (nth 1 method) - (if (symbolp func) (cons func rargs) - (list* 'funcall (list 'function func) - rargs))))))) + (temp (and (not (macroexp-const-p arg1)) (make-symbol "--cl-arg1--"))) + (rargs (cl-list* (or temp arg1) (nth 2 method) args))) + `(let* (,@(and temp (list (list temp arg1))) ,@(car method)) + ,(cl-setf-do-store (nth 1 method) + (if (symbolp func) (cons func rargs) + `(funcall #',func ,@rargs))))))) ;;;###autoload -(defmacro define-modify-macro (name arglist func &optional doc) - "Define a `setf'-like modify macro. +(defmacro cl-define-modify-macro (name arglist func &optional doc) + "Define a `cl-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)) +)" - (if (memq '&key arglist) (error "&key not allowed in define-modify-macro")) +from ARGLIST using FUNC: (cl-define-modify-macro cl-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 cl-define-modify-macro")) (let ((place (make-symbol "--cl-place--"))) - (list 'defmacro* name (cons place arglist) doc - (list* (if (memq '&rest arglist) 'list* 'list) - '(quote callf) (list 'quote func) place - (cl-arglist-args arglist))))) + `(cl-defmacro ,name (,place ,@arglist) + ,doc + (,(if (memq '&rest arglist) #'cl-list* #'list) + #'cl-callf ',func ,place + ,@(cl--arglist-args arglist))))) ;;; Structures. ;;;###autoload -(defmacro defstruct (struct &rest descs) +(defmacro cl-defstruct (struct &rest descs) "Define a struct type. This macro defines a new data type called NAME that stores data in SLOTs. It defines a `make-NAME' constructor, a `copy-NAME' copier, a `NAME-p' predicate, and slot accessors named `NAME-SLOT'. -You can use the accessors to set the corresponding slots, via `setf'. +You can use the accessors to set the corresponding slots, via `cl-setf'. NAME may instead take the form (NAME OPTIONS...), where each OPTION is either a single keyword or (KEYWORD VALUE). @@ -2274,9 +2516,29 @@ See Info node `(cl)Structures' for a list of valid keywords. Each SLOT may instead take the form (SLOT SLOT-OPTS...), where SLOT-OPTS are keyword-value pairs for that slot. Currently, only one keyword is supported, `:read-only'. If this has a non-nil -value, that slot cannot be set via `setf'. +value, that slot cannot be set via `cl-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) @@ -2298,8 +2560,8 @@ value, that slot cannot be set via `setf'. (forms nil) pred-form pred-check) (if (stringp (car descs)) - (push (list 'put (list 'quote name) '(quote structure-documentation) - (pop descs)) forms)) + (push `(put ',name 'structure-documentation + ,(pop descs)) forms)) (setq descs (cons '(cl-tag-slot) (mapcar (function (lambda (x) (if (consp x) x (list x)))) descs))) @@ -2341,15 +2603,13 @@ value, that slot cannot be set via `setf'. (t (error "Slot option %s unrecognized" opt))))) (if print-func - (setq print-func (list 'progn - (list 'funcall (list 'function print-func) - 'cl-x 'cl-s 'cl-n) t)) + (setq print-func + `(progn (funcall #',print-func cl-x cl-s cl-n) t)) (or type (and include (not (get include 'cl-struct-print))) (setq print-auto t print-func (and (or (not (or include type)) (null print-func)) - (list 'progn - (list 'princ (format "#S(%s" name) - 'cl-s)))))) + `(progn + (princ ,(format "#S(%s" name) cl-s)))))) (if include (let ((inc-type (get include 'cl-struct-type)) (old-descs (get include 'cl-struct-slots))) @@ -2368,9 +2628,9 @@ value, that slot cannot be set via `setf'. (if (cadr inc-type) (setq tag name named t)) (let ((incl include)) (while incl - (push (list 'pushnew (list 'quote tag) - (intern (format "cl-struct-%s-tags" incl))) - forms) + (push `(cl-pushnew ',tag + ,(intern (format "cl-struct-%s-tags" incl))) + forms) (setq incl (get incl 'cl-struct-include))))) (if type (progn @@ -2379,25 +2639,23 @@ value, that slot cannot be set via `setf'. (if named (setq tag name))) (setq type 'vector named 'true))) (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) - (push (list 'defvar tag-symbol) forms) + (push `(defvar ,tag-symbol) forms) (setq pred-form (and named (let ((pos (- (length descs) (length (memq (assq 'cl-tag-slot descs) descs))))) (if (eq type 'vector) - (list 'and '(vectorp cl-x) - (list '>= '(length cl-x) (length descs)) - (list 'memq (list 'aref 'cl-x pos) - tag-symbol)) + `(and (vectorp cl-x) + (>= (length cl-x) ,(length descs)) + (memq (aref cl-x ,pos) ,tag-symbol)) (if (= pos 0) - (list 'memq '(car-safe cl-x) tag-symbol) - (list 'and '(consp cl-x) - (list 'memq (list 'nth pos 'cl-x) - tag-symbol)))))) + `(memq (car-safe cl-x) ,tag-symbol) + `(and (consp cl-x) + (memq (nth ,pos cl-x) ,tag-symbol)))))) pred-check (and pred-form (> safety 0) - (if (and (eq (caadr pred-form) 'vectorp) + (if (and (eq (cl-caadr pred-form) 'vectorp) (= safety 1)) - (cons 'and (cdddr pred-form)) pred-form))) + (cons 'and (cl-cdddr pred-form)) pred-form))) (let ((pos 0) (descp descs)) (while descp (let* ((desc (pop descp)) @@ -2405,54 +2663,57 @@ value, that slot cannot be set via `setf'. (if (memq slot '(cl-tag-slot cl-skip-slot)) (progn (push nil slots) - (push (and (eq slot 'cl-tag-slot) (list 'quote tag)) + (push (and (eq slot 'cl-tag-slot) `',tag) defaults)) (if (assq slot descp) (error "Duplicate slots named %s in %s" slot name)) (let ((accessor (intern (format "%s%s" conc-name slot)))) (push slot slots) (push (nth 1 desc) defaults) - (push (list* - 'defsubst* accessor '(cl-x) + (push (cl-list* + 'cl-defsubst accessor '(cl-x) (append (and pred-check - (list (list 'or pred-check - `(error "%s accessing a non-%s" - ',accessor ',name)))) - (list (if (eq type 'vector) (list 'aref 'cl-x pos) + (list `(or ,pred-check + (error "%s accessing a non-%s" + ',accessor ',name)))) + (list (if (eq type 'vector) `(aref cl-x ,pos) (if (= pos 0) '(car cl-x) - (list 'nth pos 'cl-x)))))) forms) + `(nth ,pos cl-x)))))) forms) (push (cons accessor t) side-eff) - (push (list 'define-setf-method accessor '(cl-x) - (if (cadr (memq :read-only (cddr desc))) - (list 'progn '(ignore cl-x) - `(error "%s is a read-only slot" - ',accessor)) - ;; If cl is loaded only for compilation, - ;; the call to cl-struct-setf-expander would - ;; cause a warning because it may not be - ;; defined at run time. Suppress that warning. - (list 'with-no-warnings - (list 'cl-struct-setf-expander 'cl-x - (list 'quote name) (list 'quote accessor) - (and pred-check (list 'quote pred-check)) - pos)))) - forms) + (push `(cl-define-setf-expander ,accessor (cl-x) + ,(if (cadr (memq :read-only (cddr desc))) + `(progn (ignore cl-x) + (error "%s is a read-only slot" + ',accessor)) + ;; If cl is loaded only for compilation, + ;; the call to cl-struct-setf-expander would + ;; cause a warning because it may not be + ;; defined at run time. Suppress that warning. + `(progn + (declare-function + cl-struct-setf-expander "cl-macs" + (x name accessor pred-form pos)) + (cl-struct-setf-expander + cl-x ',name ',accessor + ,(and pred-check `',pred-check) + ,pos)))) + forms) (if print-auto (nconc print-func - (list (list 'princ (format " %s" slot) 'cl-s) - (list 'prin1 (list accessor 'cl-x) 'cl-s))))))) + (list `(princ ,(format " %s" slot) cl-s) + `(prin1 (,accessor cl-x) cl-s))))))) (setq pos (1+ pos)))) (setq slots (nreverse slots) defaults (nreverse defaults)) (and predicate pred-form - (progn (push (list 'defsubst* predicate '(cl-x) - (if (eq (car pred-form) 'and) - (append pred-form '(t)) - (list 'and pred-form t))) forms) + (progn (push `(cl-defsubst ,predicate (cl-x) + ,(if (eq (car pred-form) 'and) + (append pred-form '(t)) + `(and ,pred-form t))) forms) (push (cons predicate 'error-free) side-eff))) (and copier - (progn (push (list 'defun copier '(x) '(copy-sequence x)) forms) + (progn (push `(defun ,copier (x) (copy-sequence x)) forms) (push (cons copier t) side-eff))) (if constructor (push (list constructor @@ -2461,13 +2722,13 @@ value, that slot cannot be set via `setf'. (while constrs (let* ((name (caar constrs)) (args (cadr (pop constrs))) - (anames (cl-arglist-args args)) - (make (mapcar* (function (lambda (s d) (if (memq s anames) s d))) + (anames (cl--arglist-args args)) + (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) slots defaults))) - (push (list 'defsubst* name - (list* '&cl-defs (list 'quote (cons nil descs)) args) - (cons type make)) forms) - (if (cl-safe-expr-p (cons 'progn (mapcar 'second descs))) + (push `(cl-defsubst ,name + (&cl-defs '(nil ,@descs) ,@args) + (,type ,@make)) forms) + (if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) (push (cons name t) side-eff)))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) (if print-func @@ -2476,70 +2737,65 @@ value, that slot cannot be set via `setf'. ;; the depth argument cl-n. (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n)) (and ,pred-form ,print-func)) - custom-print-functions) + cl-custom-print-functions) forms)) - (push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms) - (push (list* 'eval-when '(compile load eval) - (list 'put (list 'quote name) '(quote cl-struct-slots) - (list 'quote descs)) - (list 'put (list 'quote name) '(quote cl-struct-type) - (list 'quote (list type (eq named t)))) - (list 'put (list 'quote name) '(quote cl-struct-include) - (list 'quote include)) - (list 'put (list 'quote name) '(quote cl-struct-print) - print-auto) - (mapcar (function (lambda (x) - (list 'put (list 'quote (car x)) - '(quote side-effect-free) - (list 'quote (cdr x))))) - side-eff)) - forms) - (cons 'progn (nreverse (cons (list 'quote name) forms))))) + (push `(setq ,tag-symbol (list ',tag)) forms) + (push `(cl-eval-when (compile load eval) + (put ',name 'cl-struct-slots ',descs) + (put ',name 'cl-struct-type ',(list type (eq named t))) + (put ',name 'cl-struct-include ',include) + (put ',name 'cl-struct-print ,print-auto) + ,@(mapcar (lambda (x) + `(put ',(car x) 'side-effect-free ',(cdr x))) + side-eff)) + forms) + `(progn ,@(nreverse (cons `',name forms))))) ;;;###autoload (defun cl-struct-setf-expander (x name accessor pred-form pos) (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--"))) (list (list temp) (list x) (list store) - (append '(progn) - (and pred-form - (list (list 'or (subst temp 'cl-x pred-form) - (list 'error - (format - "%s storing a non-%s" accessor name))))) - (list (if (eq (car (get name 'cl-struct-type)) 'vector) - (list 'aset temp pos store) - (list 'setcar - (if (<= pos 5) - (let ((xx temp)) - (while (>= (setq pos (1- pos)) 0) - (setq xx (list 'cdr xx))) - xx) - (list 'nthcdr pos temp)) - store)))) + `(progn + ,@(and pred-form + (list `(or ,(cl-subst temp 'cl-x pred-form) + (error ,(format + "%s storing a non-%s" + accessor name))))) + ,(if (eq (car (get name 'cl-struct-type)) 'vector) + `(aset ,temp ,pos ,store) + `(setcar + ,(if (<= pos 5) + (let ((xx temp)) + (while (>= (setq pos (1- pos)) 0) + (setq xx `(cdr ,xx))) + xx) + `(nthcdr ,pos ,temp)) + ,store))) (list accessor temp)))) ;;; Types and assertions. ;;;###autoload -(defmacro deftype (name arglist &rest body) +(defmacro cl-deftype (name arglist &rest body) "Define NAME as a new data type. -The type name can then be used in `typecase', `check-type', etc." - (list 'eval-when '(compile load eval) - (cl-transform-function-property - name 'cl-deftype-handler (cons (list* '&cl-defs ''('*) arglist) body)))) +The type name can then be used in `cl-typecase', `cl-check-type', etc." + (declare (debug cl-defmacro) (doc-string 3)) + `(cl-eval-when (compile load eval) + ,(cl--transform-function-property + name 'cl-deftype-handler (cons `(&cl-defs '('*) ,@arglist) body)))) -(defun cl-make-type-test (val type) +(defun cl--make-type-test (val type) (if (symbolp type) (cond ((get type 'cl-deftype-handler) - (cl-make-type-test val (funcall (get type 'cl-deftype-handler)))) + (cl--make-type-test val (funcall (get type 'cl-deftype-handler)))) ((memq type '(nil t)) type) ((eq type 'null) `(null ,val)) ((eq type 'atom) `(atom ,val)) - ((eq type 'float) `(floatp-safe ,val)) + ((eq type 'float) `(cl-floatp-safe ,val)) ((eq type 'real) `(numberp ,val)) ((eq type 'fixnum) `(integerp ,val)) - ;; FIXME: Should `character' accept things like ?\C-\M-a ? -stef + ;; FIXME: Should `character' accept things like ?\C-\M-a ? --Stef ((memq type '(character string-char)) `(characterp ,val)) (t (let* ((name (symbol-name type)) @@ -2547,73 +2803,76 @@ The type name can then be used in `typecase', `check-type', etc." (if (fboundp namep) (list namep val) (list (intern (concat name "-p")) val))))) (cond ((get (car type) 'cl-deftype-handler) - (cl-make-type-test val (apply (get (car type) 'cl-deftype-handler) + (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler) (cdr type)))) ((memq (car type) '(integer float real number)) - (delq t (list 'and (cl-make-type-test val (car type)) - (if (memq (cadr type) '(* nil)) t - (if (consp (cadr type)) (list '> val (caadr type)) - (list '>= val (cadr type)))) - (if (memq (caddr type) '(* nil)) t - (if (consp (caddr type)) (list '< val (caaddr type)) - (list '<= val (caddr type))))))) + (delq t `(and ,(cl--make-type-test val (car type)) + ,(if (memq (cadr type) '(* nil)) t + (if (consp (cadr type)) `(> ,val ,(cl-caadr type)) + `(>= ,val ,(cadr type)))) + ,(if (memq (cl-caddr type) '(* nil)) t + (if (consp (cl-caddr type)) `(< ,val ,(cl-caaddr type)) + `(<= ,val ,(cl-caddr type))))))) ((memq (car type) '(and or not)) (cons (car type) - (mapcar (function (lambda (x) (cl-make-type-test val x))) + (mapcar (function (lambda (x) (cl--make-type-test val x))) (cdr type)))) - ((memq (car type) '(member member*)) - (list 'and (list 'member* val (list 'quote (cdr type))) t)) + ((memq (car type) '(member cl-member)) + `(and (cl-member ,val ',(cdr type)) t)) ((eq (car type) 'satisfies) (list (cadr type) val)) (t (error "Bad type spec: %s" type))))) +(defvar cl--object) ;;;###autoload -(defun typep (object type) ; See compiler macro below. +(defun cl-typep (object type) ; See compiler macro below. "Check that OBJECT is of type TYPE. TYPE is a Common Lisp-style type specifier." - (eval (cl-make-type-test 'object type))) + (let ((cl--object object)) ;; Yuck!! + (eval (cl--make-type-test 'cl--object type)))) ;;;###autoload -(defmacro check-type (form type &optional string) +(defmacro cl-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) + (let* ((temp (if (cl--simple-expr-p form 3) form (make-symbol "--cl-var--"))) - (body (list 'or (cl-make-type-test temp type) - (list 'signal '(quote wrong-type-argument) - (list 'list (or string (list 'quote type)) - temp (list 'quote form)))))) - (if (eq temp form) (list 'progn body nil) - (list 'let (list (list temp form)) body nil))))) + (body `(or ,(cl--make-type-test temp type) + (signal 'wrong-type-argument + (list ,(or string `',type) + ,temp ',form))))) + (if (eq temp form) `(progn ,body nil) + `(let ((,temp ,form)) ,body nil))))) ;;;###autoload -(defmacro assert (form &optional show-args string &rest args) +(defmacro cl-assert (form &optional show-args string &rest args) "Verify that FORM returns non-nil; signal an error if not. 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 - (delq nil (mapcar - (lambda (x) - (unless (cl-const-expr-p x) - x)) - (cdr form)))))) - (list 'progn - (list 'or form - (if string - (list* 'error string (append sargs args)) - (list 'signal '(quote cl-assertion-failed) - (list* 'list (list 'quote form) sargs)))) - nil)))) + (delq nil (mapcar (lambda (x) + (unless (macroexp-const-p x) + x)) + (cdr form)))))) + `(progn + (or ,form + ,(if string + `(error ,string ,@sargs ,@args) + `(signal 'cl-assertion-failed + (list ',form ,@sargs)))) + nil)))) ;;; Compiler macros. ;;;###autoload -(defmacro define-compiler-macro (func args &rest body) +(defmacro cl-define-compiler-macro (func args &rest body) "Define a compiler-only macro. This is like `defmacro', but macro expansion occurs only if the call to FUNC is compiled (i.e., not interpreted). Compiler macros should be used @@ -2624,38 +2883,30 @@ 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 cl-defmacro)) (let ((p args) (res nil)) (while (consp p) (push (pop p) res)) (setq args (nconc (nreverse res) (and p (list '&rest p))))) - (list 'eval-when '(compile load eval) - (cl-transform-function-property - func 'cl-compiler-macro - (cons (if (memq '&whole args) (delq '&whole args) - (cons '_cl-whole-arg args)) body)) - (list 'or (list 'get (list 'quote func) '(quote byte-compile)) - (list 'progn - (list 'put (list 'quote func) '(quote byte-compile) - '(quote cl-byte-compile-compiler-macro)) - ;; This is so that describe-function can locate - ;; the macro definition. - (list 'let - (list (list - 'file - (or buffer-file-name - (and (boundp 'byte-compile-current-file) - (stringp byte-compile-current-file) - byte-compile-current-file)))) - (list 'if 'file - (list 'put (list 'quote func) - '(quote compiler-macro-file) - '(purecopy (file-name-nondirectory file))))))))) + `(cl-eval-when (compile load eval) + ,(cl--transform-function-property + func 'compiler-macro + (cons (if (memq '&whole args) (delq '&whole args) + (cons '_cl-whole-arg args)) body)) + ;; This is so that describe-function can locate + ;; the macro definition. + (let ((file ,(or buffer-file-name + (and (boundp 'byte-compile-current-file) + (stringp byte-compile-current-file) + byte-compile-current-file)))) + (if file (put ',func 'compiler-macro-file + (purecopy (file-name-nondirectory file))))))) ;;;###autoload -(defun compiler-macroexpand (form) +(defun cl-compiler-macroexpand (form) (while (let ((func (car-safe form)) (handler nil)) (while (and (symbolp func) - (not (setq handler (get func 'cl-compiler-macro))) + (not (setq handler (get func 'compiler-macro))) (fboundp func) (or (not (eq (car-safe (symbol-function func)) 'autoload)) (load (nth 1 (symbol-function func))))) @@ -2664,18 +2915,13 @@ and then returning foo." (not (eq form (setq form (apply handler form (cdr form)))))))) form) -(defun cl-byte-compile-compiler-macro (form) - (if (eq form (setq form (compiler-macroexpand form))) - (byte-compile-normal-call form) - (byte-compile-form form))) - ;; Optimize away unused block-wrappers. -(defvar cl-active-block-names nil) +(defvar cl--active-block-names nil) -(define-compiler-macro cl-block-wrapper (cl-form) +(cl-define-compiler-macro cl-block-wrapper (cl-form) (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil)) - (cl-active-block-names (cons cl-entry cl-active-block-names)) + (cl--active-block-names (cons cl-entry cl--active-block-names)) (cl-body (macroexpand-all ;Performs compiler-macro expansions. (cons 'progn (cddr cl-form)) macroexpand-all-environment))) @@ -2685,52 +2931,52 @@ and then returning foo." `(catch ,(nth 1 cl-form) ,@(cdr cl-body)) cl-body))) -(define-compiler-macro cl-block-throw (cl-tag cl-value) - (let ((cl-found (assq (nth 1 cl-tag) cl-active-block-names))) +(cl-define-compiler-macro cl-block-throw (cl-tag cl-value) + (let ((cl-found (assq (nth 1 cl-tag) cl--active-block-names))) (if cl-found (setcdr cl-found t))) `(throw ,cl-tag ,cl-value)) ;;;###autoload -(defmacro defsubst* (name args &rest body) +(defmacro cl-defsubst (name args &rest body) "Define NAME as a function. Like `defun', except the function is automatically declared `inline', ARGLIST allows full Common Lisp conventions, and BODY is implicitly -surrounded by (block NAME ...). +surrounded by (cl-block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" - (let* ((argns (cl-arglist-args args)) (p argns) + (declare (debug cl-defun)) + (let* ((argns (cl--arglist-args args)) (p argns) (pbody (cons 'progn body)) - (unsafe (not (cl-safe-expr-p pbody)))) - (while (and p (eq (cl-expr-contains args (car p)) 1)) (pop p)) - (list 'progn - (if p nil ; give up if defaults refer to earlier args - (list 'define-compiler-macro name - (if (memq '&key args) - (list* '&whole 'cl-whole '&cl-quote args) - (cons '&cl-quote args)) - (list* 'cl-defsubst-expand (list 'quote argns) - (list 'quote (list* 'block name body)) - ;; We used to pass `simple' as - ;; (not (or unsafe (cl-expr-access-order pbody argns))) - ;; But this is much too simplistic since it - ;; does not pay attention to the argvs (and - ;; cl-expr-access-order itself is also too naive). - nil - (and (memq '&key args) 'cl-whole) unsafe argns))) - (list* 'defun* name args body)))) + (unsafe (not (cl--safe-expr-p pbody)))) + (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p)) + `(progn + ,(if p nil ; give up if defaults refer to earlier args + `(cl-define-compiler-macro ,name + ,(if (memq '&key args) + `(&whole cl-whole &cl-quote ,@args) + (cons '&cl-quote args)) + (cl-defsubst-expand + ',argns '(cl-block ,name ,@body) + ;; We used to pass `simple' as + ;; (not (or unsafe (cl-expr-access-order pbody argns))) + ;; But this is much too simplistic since it + ;; does not pay attention to the argvs (and + ;; cl-expr-access-order itself is also too naive). + nil + ,(and (memq '&key args) 'cl-whole) ,unsafe ,@argns))) + (cl-defun ,name ,args ,@body)))) (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) - (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole - (if (cl-simple-exprs-p argvs) (setq simple t)) + (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole + (if (cl--simple-exprs-p argvs) (setq simple t)) (let* ((substs ()) (lets (delq nil - (mapcar* (function - (lambda (argn argv) - (if (or simple (cl-const-expr-p argv)) - (progn (push (cons argn argv) substs) - (and unsafe (list argn argv))) - (list argn argv)))) - argns argvs)))) + (cl-mapcar (lambda (argn argv) + (if (or simple (macroexp-const-p argv)) + (progn (push (cons argn argv) substs) + (and unsafe (list argn argv))) + (list argn argv))) + argns argvs)))) ;; FIXME: `sublis/subst' will happily substitute the symbol ;; `argn' in places where it's not used as a reference ;; to a variable. @@ -2738,120 +2984,93 @@ surrounded by (block NAME ...). ;; scope, leading to name capture. (setq body (cond ((null substs) body) ((null (cdr substs)) - (subst (cdar substs) (caar substs) body)) - (t (sublis substs body)))) - (if lets (list 'let lets body) body)))) + (cl-subst (cdar substs) (caar substs) body)) + (t (cl-sublis substs body)))) + (if lets `(let ,lets ,body) body)))) ;; Compile-time optimizations for some functions defined in this package. ;; Note that cl.el arranges to force cl-macs to be loaded at compile-time, ;; mainly to make sure these macros will be present. -(put 'eql 'byte-compile nil) -(define-compiler-macro eql (&whole form a b) - (cond ((eq (cl-const-expr-p a) t) - (let ((val (cl-const-expr-val a))) - (if (and (numberp val) (not (integerp val))) - (list 'equal a b) - (list 'eq a b)))) - ((eq (cl-const-expr-p b) t) - (let ((val (cl-const-expr-val b))) - (if (and (numberp val) (not (integerp val))) - (list 'equal a b) - (list 'eq a b)))) - ((cl-simple-expr-p a 5) - (list 'if (list 'numberp a) - (list 'equal a b) - (list 'eq a b))) - ((and (cl-safe-expr-p a) - (cl-simple-expr-p b 5)) - (list 'if (list 'numberp b) - (list 'equal a b) - (list 'eq a b))) - (t form))) - -(define-compiler-macro member* (&whole form a list &rest keys) +(defun cl--compiler-macro-member (form a list &rest keys) (let ((test (and (= (length keys) 2) (eq (car keys) :test) - (cl-const-expr-val (nth 1 keys))))) - (cond ((eq test 'eq) (list 'memq a list)) - ((eq test 'equal) (list 'member a list)) - ((or (null keys) (eq test 'eql)) (list 'memql a list)) + (cl--const-expr-val (nth 1 keys))))) + (cond ((eq test 'eq) `(memq ,a ,list)) + ((eq test 'equal) `(member ,a ,list)) + ((or (null keys) (eq test 'eql)) `(memql ,a ,list)) (t form)))) -(define-compiler-macro assoc* (&whole form a list &rest keys) +(defun cl--compiler-macro-assoc (form a list &rest keys) (let ((test (and (= (length keys) 2) (eq (car keys) :test) - (cl-const-expr-val (nth 1 keys))))) - (cond ((eq test 'eq) (list 'assq a list)) - ((eq test 'equal) (list 'assoc a list)) - ((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql))) - (if (floatp-safe (cl-const-expr-val a)) - (list 'assoc a list) (list 'assq a list))) + (cl--const-expr-val (nth 1 keys))))) + (cond ((eq test 'eq) `(assq ,a ,list)) + ((eq test 'equal) `(assoc ,a ,list)) + ((and (macroexp-const-p a) (or (null keys) (eq test 'eql))) + (if (cl-floatp-safe (cl--const-expr-val a)) + `(assoc ,a ,list) `(assq ,a ,list))) (t form)))) -(define-compiler-macro adjoin (&whole form a list &rest keys) - (if (and (cl-simple-expr-p a) (cl-simple-expr-p list) +(defun cl--compiler-macro-adjoin (form a list &rest keys) + (if (and (cl--simple-expr-p a) (cl--simple-expr-p list) (not (memq :key keys))) - (list 'if (list* 'member* a list keys) list (list 'cons a list)) + `(if (cl-member ,a ,list ,@keys) ,list (cons ,a ,list)) form)) -(define-compiler-macro list* (arg &rest others) +(defun cl--compiler-macro-list* (_form arg &rest others) (let* ((args (reverse (cons arg others))) (form (car args))) (while (setq args (cdr args)) - (setq form (list 'cons (car args) form))) + (setq form `(cons ,(car args) ,form))) form)) -(define-compiler-macro get* (sym prop &optional def) +(defun cl--compiler-macro-get (_form sym prop &optional def) (if def - (list 'getf (list 'symbol-plist sym) prop def) - (list 'get sym prop))) - -(define-compiler-macro typep (&whole form val type) - (if (cl-const-expr-p type) - (let ((res (cl-make-type-test val (cl-const-expr-val type)))) - (if (or (memq (cl-expr-contains res val) '(nil 1)) - (cl-simple-expr-p val)) res - (let ((temp (make-symbol "--cl-var--"))) - (list 'let (list (list temp val)) (subst temp val res))))) + `(cl-getf (symbol-plist ,sym) ,prop ,def) + `(get ,sym ,prop))) + +(cl-define-compiler-macro cl-typep (&whole form val type) + (if (macroexp-const-p type) + (macroexp-let² macroexp-copyable-p temp val + (cl--make-type-test temp (cl--const-expr-val type))) form)) (mapc (lambda (y) (put (car y) 'side-effect-free t) - (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) - (put (car y) 'cl-compiler-macro - `(lambda (w x) + (put (car y) 'compiler-macro + `(lambda (_w x) ,(if (symbolp (cadr y)) `(list ',(cadr y) - (list ',(caddr y) x)) + (list ',(cl-caddr y) x)) (cons 'list (cdr y)))))) - '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) - (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) - (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) - (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0) - (caaar car caar) (caadr car cadr) (cadar car cdar) - (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) - (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) - (caaadr car caadr) (caadar car cadar) (caaddr car caddr) - (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar) - (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr) - (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar) - (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) )) + '((cl-first 'car x) (cl-second 'cadr x) (cl-third 'cl-caddr x) (cl-fourth 'cl-cadddr x) + (cl-fifth 'nth 4 x) (cl-sixth 'nth 5 x) (cl-seventh 'nth 6 x) + (cl-eighth 'nth 7 x) (cl-ninth 'nth 8 x) (cl-tenth 'nth 9 x) + (cl-rest 'cdr x) (cl-endp 'null x) (cl-plusp '> x 0) (cl-minusp '< x 0) + (cl-caaar car caar) (cl-caadr car cadr) (cl-cadar car cdar) + (cl-caddr car cddr) (cl-cdaar cdr caar) (cl-cdadr cdr cadr) + (cl-cddar cdr cdar) (cl-cdddr cdr cddr) (cl-caaaar car cl-caaar) + (cl-caaadr car cl-caadr) (cl-caadar car cl-cadar) (cl-caaddr car cl-caddr) + (cl-cadaar car cl-cdaar) (cl-cadadr car cl-cdadr) (cl-caddar car cl-cddar) + (cl-cadddr car cl-cdddr) (cl-cdaaar cdr cl-caaar) (cl-cdaadr cdr cl-caadr) + (cl-cdadar cdr cl-cadar) (cl-cdaddr cdr cl-caddr) (cl-cddaar cdr cl-cdaar) + (cl-cddadr cdr cl-cdadr) (cl-cdddar cdr cl-cddar) (cl-cddddr cdr cl-cdddr) )) ;;; Things that are inline. -(proclaim '(inline floatp-safe acons map concatenate notany notevery - cl-set-elt revappend nreconc gethash)) +(cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany cl-notevery + cl-set-elt cl-revappend cl-nreconc gethash)) ;;; Things that are side-effect-free. (mapc (lambda (x) (put x 'side-effect-free t)) - '(oddp evenp signum last butlast ldiff pairlis gcd lcm - isqrt floor* ceiling* truncate* round* mod* rem* subseq - list-length get* getf)) + '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd cl-lcm + cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem cl-subseq + cl-list-length cl-get cl-getf)) ;;; Things that are side-effect-and-error-free. (mapc (lambda (x) (put x 'side-effect-free 'error-free)) - '(eql floatp-safe list* subst acons equalp random-state-p - copy-tree sublis)) + '(eql cl-floatp-safe cl-list* cl-subst cl-acons cl-equalp cl-random-state-p + copy-tree cl-sublis)) (run-hooks 'cl-macs-load-hook) @@ -2862,4 +3081,6 @@ surrounded by (block NAME ...). ;; generated-autoload-file: "cl-loaddefs.el" ;; End: +(provide 'cl-macs) + ;;; cl-macs.el ends here diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index f1890fbccf6..cb167ad2881 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -41,7 +41,7 @@ ;;; Code: -(require 'cl) +(require 'cl-lib) ;;; Keyword parsing. This is special-cased here so that we can compile ;;; this file independent from cl-macs. @@ -118,13 +118,13 @@ ;;;###autoload -(defun reduce (cl-func cl-seq &rest cl-keys) +(defun cl-reduce (cl-func cl-seq &rest cl-keys) "Reduce two-argument FUNCTION across SEQ. \nKeywords supported: :start :end :from-end :initial-value :key \n(fn FUNCTION SEQ [KEYWORD VALUE]...)" (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) () (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) - (setq cl-seq (subseq cl-seq cl-start cl-end)) + (setq cl-seq (cl-subseq cl-seq cl-start cl-end)) (if cl-from-end (setq cl-seq (nreverse cl-seq))) (let ((cl-accum (cond ((memq :initial-value cl-keys) cl-initial-value) (cl-seq (cl-check-key (pop cl-seq))) @@ -139,7 +139,7 @@ cl-accum))) ;;;###autoload -(defun fill (seq item &rest cl-keys) +(defun cl-fill (seq item &rest cl-keys) "Fill the elements of SEQ with ITEM. \nKeywords supported: :start :end \n(fn SEQ ITEM [KEYWORD VALUE]...)" @@ -159,7 +159,7 @@ seq)) ;;;###autoload -(defun replace (cl-seq1 cl-seq2 &rest cl-keys) +(defun cl-replace (cl-seq1 cl-seq2 &rest cl-keys) "Replace the elements of SEQ1 with the elements of SEQ2. SEQ1 is destructively modified, then returned. \nKeywords supported: :start1 :end1 :start2 :end2 @@ -202,7 +202,7 @@ SEQ1 is destructively modified, then returned. cl-seq1)) ;;;###autoload -(defun remove* (cl-item cl-seq &rest cl-keys) +(defun cl-remove (cl-item cl-seq &rest cl-keys) "Remove all occurrences of ITEM in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -213,10 +213,10 @@ 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) + (let ((cl-res (apply 'cl-delete cl-item (append cl-seq nil) (append (if cl-from-end (list :end (1+ cl-i)) (list :start cl-i)) @@ -237,10 +237,10 @@ to avoid corrupting the original SEQ. (not (cl-check-test cl-item (car cl-p)))) (setq cl-p (cdr cl-p) cl-end (1- cl-end))) (if (and cl-p (> cl-end 0)) - (nconc (ldiff cl-seq cl-p) + (nconc (cl-ldiff cl-seq cl-p) (if (= cl-count 1) (cdr cl-p) (and (cdr cl-p) - (apply 'delete* cl-item + (apply 'cl-delete cl-item (copy-sequence (cdr cl-p)) :start 0 :end (1- cl-end) :count (1- cl-count) cl-keys)))) @@ -248,25 +248,25 @@ to avoid corrupting the original SEQ. cl-seq))))) ;;;###autoload -(defun remove-if (cl-pred cl-list &rest cl-keys) +(defun cl-remove-if (cl-pred cl-list &rest cl-keys) "Remove all items satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. \nKeywords supported: :key :count :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'remove* nil cl-list :if cl-pred cl-keys)) + (apply 'cl-remove nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun remove-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-remove-if-not (cl-pred cl-list &rest cl-keys) "Remove all items not satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. \nKeywords supported: :key :count :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'remove* nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-remove nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun delete* (cl-item cl-seq &rest cl-keys) +(defun cl-delete (cl-item cl-seq &rest cl-keys) "Remove all occurrences of ITEM in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :test :test-not :key :count :start :end :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))))) @@ -307,39 +307,39 @@ 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-seq) - (apply 'remove* cl-item cl-seq cl-keys))))) + (apply 'cl-remove cl-item cl-seq cl-keys))))) ;;;###autoload -(defun delete-if (cl-pred cl-list &rest cl-keys) +(defun cl-delete-if (cl-pred cl-list &rest cl-keys) "Remove all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :key :count :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'delete* nil cl-list :if cl-pred cl-keys)) + (apply 'cl-delete nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun delete-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-delete-if-not (cl-pred cl-list &rest cl-keys) "Remove all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :key :count :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'delete* nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-delete nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun remove-duplicates (cl-seq &rest cl-keys) +(defun cl-remove-duplicates (cl-seq &rest cl-keys) "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) +(defun cl-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,11 +376,11 @@ 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 -(defun substitute (cl-new cl-old cl-seq &rest cl-keys) +(defun cl-substitute (cl-new cl-old cl-seq &rest cl-keys) "Substitute NEW for OLD in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -391,36 +391,36 @@ 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)) (or cl-from-end (progn (cl-set-elt cl-seq cl-i cl-new) (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) - (apply 'nsubstitute cl-new cl-old cl-seq :count cl-count + (apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count :start cl-i cl-keys)))))) ;;;###autoload -(defun substitute-if (cl-new cl-pred cl-list &rest cl-keys) +(defun cl-substitute-if (cl-new cl-pred cl-list &rest cl-keys) "Substitute NEW for all items satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. \nKeywords supported: :key :count :start :end :from-end \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'substitute cl-new nil cl-list :if cl-pred cl-keys)) + (apply 'cl-substitute cl-new nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) +(defun cl-substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) "Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. \nKeywords supported: :key :count :start :end :from-end \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-substitute cl-new nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys) +(defun cl-nsubstitute (cl-new cl-old cl-seq &rest cl-keys) "Substitute NEW for OLD in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :test :test-not :key :count :start :end :from-end @@ -454,57 +454,57 @@ This is a destructive function; it reuses the storage of SEQ whenever possible. cl-seq)) ;;;###autoload -(defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys) +(defun cl-nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys) "Substitute NEW for all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :key :count :start :end :from-end \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys)) + (apply 'cl-nsubstitute cl-new nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys) +(defun cl-nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys) "Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. \nKeywords supported: :key :count :start :end :from-end \n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun find (cl-item cl-seq &rest cl-keys) +(defun cl-find (cl-item cl-seq &rest cl-keys) "Find the first occurrence of ITEM in SEQ. Return the matching ITEM, or nil if not found. \nKeywords supported: :test :test-not :key :start :end :from-end \n(fn ITEM SEQ [KEYWORD VALUE]...)" - (let ((cl-pos (apply 'position cl-item cl-seq cl-keys))) + (let ((cl-pos (apply 'cl-position cl-item cl-seq cl-keys))) (and cl-pos (elt cl-seq cl-pos)))) ;;;###autoload -(defun find-if (cl-pred cl-list &rest cl-keys) +(defun cl-find-if (cl-pred cl-list &rest cl-keys) "Find the first item satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. \nKeywords supported: :key :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'find nil cl-list :if cl-pred cl-keys)) + (apply 'cl-find nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun find-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-find-if-not (cl-pred cl-list &rest cl-keys) "Find the first item not satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. \nKeywords supported: :key :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'find nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-find nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun position (cl-item cl-seq &rest cl-keys) +(defun cl-position (cl-item cl-seq &rest cl-keys) "Find the first occurrence of ITEM in SEQ. Return the index of the matching item, or nil if not found. \nKeywords supported: :test :test-not :key :start :end :from-end \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)) @@ -526,23 +526,23 @@ Return the index of the matching item, or nil if not found. (and (< cl-start cl-end) cl-start)))) ;;;###autoload -(defun position-if (cl-pred cl-list &rest cl-keys) +(defun cl-position-if (cl-pred cl-list &rest cl-keys) "Find the first item satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. \nKeywords supported: :key :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'position nil cl-list :if cl-pred cl-keys)) + (apply 'cl-position nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun position-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-position-if-not (cl-pred cl-list &rest cl-keys) "Find the first item not satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. \nKeywords supported: :key :start :end :from-end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'position nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-position nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun count (cl-item cl-seq &rest cl-keys) +(defun cl-count (cl-item cl-seq &rest cl-keys) "Count the number of occurrences of ITEM in SEQ. \nKeywords supported: :test :test-not :key :start :end \n(fn ITEM SEQ [KEYWORD VALUE]...)" @@ -557,21 +557,21 @@ Return the index of the matching item, or nil if not found. cl-count))) ;;;###autoload -(defun count-if (cl-pred cl-list &rest cl-keys) +(defun cl-count-if (cl-pred cl-list &rest cl-keys) "Count the number of items satisfying PREDICATE in SEQ. \nKeywords supported: :key :start :end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'count nil cl-list :if cl-pred cl-keys)) + (apply 'cl-count nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun count-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-count-if-not (cl-pred cl-list &rest cl-keys) "Count the number of items not satisfying PREDICATE in SEQ. \nKeywords supported: :key :start :end \n(fn PREDICATE SEQ [KEYWORD VALUE]...)" - (apply 'count nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-count nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun mismatch (cl-seq1 cl-seq2 &rest cl-keys) +(defun cl-mismatch (cl-seq1 cl-seq2 &rest cl-keys) "Compare SEQ1 with SEQ2, return index of first mismatching element. Return nil if the sequences match. If one sequence is a prefix of the other, the return value indicates the end of the shorter sequence. @@ -602,7 +602,7 @@ other, the return value indicates the end of the shorter sequence. cl-start1))))) ;;;###autoload -(defun search (cl-seq1 cl-seq2 &rest cl-keys) +(defun cl-search (cl-seq1 cl-seq2 &rest cl-keys) "Search for SEQ1 as a subsequence of SEQ2. Return the index of the leftmost element of the first match found; return nil if there are no matches. @@ -619,9 +619,9 @@ 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)) - (apply 'mismatch cl-seq1 cl-seq2 + (setq cl-pos (cl--position cl-first cl-seq2 + cl-start2 cl-end2 cl-from-end)) + (apply 'cl-mismatch cl-seq1 cl-seq2 :start1 (1+ cl-start1) :end1 cl-end1 :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len) :from-end nil cl-keys)) @@ -629,13 +629,13 @@ return nil if there are no matches. (and (< cl-start2 cl-end2) cl-pos))))) ;;;###autoload -(defun sort* (cl-seq cl-pred &rest cl-keys) +(defun cl-sort (cl-seq cl-pred &rest cl-keys) "Sort the argument SEQ according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. \nKeywords supported: :key \n(fn SEQ PREDICATE [KEYWORD VALUE]...)" (if (nlistp cl-seq) - (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys)) + (cl-replace cl-seq (apply 'cl-sort (append cl-seq nil) cl-pred cl-keys)) (cl-parsing-keywords (:key) () (if (memq cl-key '(nil identity)) (sort cl-seq cl-pred) @@ -644,15 +644,15 @@ This is a destructive function; it reuses the storage of SEQ if possible. (funcall cl-key cl-y))))))))) ;;;###autoload -(defun stable-sort (cl-seq cl-pred &rest cl-keys) +(defun cl-stable-sort (cl-seq cl-pred &rest cl-keys) "Sort the argument SEQ stably according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. \nKeywords supported: :key \n(fn SEQ PREDICATE [KEYWORD VALUE]...)" - (apply 'sort* cl-seq cl-pred cl-keys)) + (apply 'cl-sort cl-seq cl-pred cl-keys)) ;;;###autoload -(defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys) +(defun cl-merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys) "Destructively merge the two sequences to produce a new sequence. TYPE is the sequence type to return, SEQ1 and SEQ2 are the two argument sequences, and PREDICATE is a `less-than' predicate on the elements. @@ -667,15 +667,16 @@ sequences, and PREDICATE is a `less-than' predicate on the elements. (cl-check-key (car cl-seq1))) (push (pop cl-seq2) cl-res) (push (pop cl-seq1) cl-res))) - (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) + (cl-coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) ;;; See compiler macro in cl-macs.el ;;;###autoload -(defun member* (cl-item cl-list &rest cl-keys) +(defun cl-member (cl-item cl-list &rest cl-keys) "Find the first occurrence of ITEM in LIST. Return the sublist of LIST whose car is ITEM. \nKeywords supported: :test :test-not :key \n(fn ITEM LIST [KEYWORD VALUE]...)" + (declare (compiler-macro cl--compiler-macro-member)) (if cl-keys (cl-parsing-keywords (:test :test-not :key :if :if-not) () (while (and cl-list (not (cl-check-test cl-item (car cl-list)))) @@ -684,36 +685,38 @@ Return the sublist of LIST whose car is ITEM. (if (and (numberp cl-item) (not (integerp cl-item))) (member cl-item cl-list) (memq cl-item cl-list)))) +(autoload 'cl--compiler-macro-member "cl-macs") ;;;###autoload -(defun member-if (cl-pred cl-list &rest cl-keys) +(defun cl-member-if (cl-pred cl-list &rest cl-keys) "Find the first item satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'member* nil cl-list :if cl-pred cl-keys)) + (apply 'cl-member nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun member-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-member-if-not (cl-pred cl-list &rest cl-keys) "Find the first item not satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'member* nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-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)) + (apply 'cl-member (cl-check-key cl-item) cl-list cl-keys)) cl-list (cons cl-item cl-list))) ;;; See compiler macro in cl-macs.el ;;;###autoload -(defun assoc* (cl-item cl-alist &rest cl-keys) +(defun cl-assoc (cl-item cl-alist &rest cl-keys) "Find the first item whose car matches ITEM in LIST. \nKeywords supported: :test :test-not :key \n(fn ITEM LIST [KEYWORD VALUE]...)" + (declare (compiler-macro cl--compiler-macro-assoc)) (if cl-keys (cl-parsing-keywords (:test :test-not :key :if :if-not) () (while (and cl-alist @@ -724,23 +727,24 @@ Return the sublist of LIST whose car matches. (if (and (numberp cl-item) (not (integerp cl-item))) (assoc cl-item cl-alist) (assq cl-item cl-alist)))) +(autoload 'cl--compiler-macro-assoc "cl-macs") ;;;###autoload -(defun assoc-if (cl-pred cl-list &rest cl-keys) +(defun cl-assoc-if (cl-pred cl-list &rest cl-keys) "Find the first item whose car satisfies PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'assoc* nil cl-list :if cl-pred cl-keys)) + (apply 'cl-assoc nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun assoc-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-assoc-if-not (cl-pred cl-list &rest cl-keys) "Find the first item whose car does not satisfy PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'assoc* nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-assoc nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun rassoc* (cl-item cl-alist &rest cl-keys) +(defun cl-rassoc (cl-item cl-alist &rest cl-keys) "Find the first item whose cdr matches ITEM in LIST. \nKeywords supported: :test :test-not :key \n(fn ITEM LIST [KEYWORD VALUE]...)" @@ -754,21 +758,21 @@ Return the sublist of LIST whose car matches. (rassq cl-item cl-alist))) ;;;###autoload -(defun rassoc-if (cl-pred cl-list &rest cl-keys) +(defun cl-rassoc-if (cl-pred cl-list &rest cl-keys) "Find the first item whose cdr satisfies PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'rassoc* nil cl-list :if cl-pred cl-keys)) + (apply 'cl-rassoc nil cl-list :if cl-pred cl-keys)) ;;;###autoload -(defun rassoc-if-not (cl-pred cl-list &rest cl-keys) +(defun cl-rassoc-if-not (cl-pred cl-list &rest cl-keys) "Find the first item whose cdr does not satisfy PREDICATE in LIST. \nKeywords supported: :key \n(fn PREDICATE LIST [KEYWORD VALUE]...)" - (apply 'rassoc* nil cl-list :if-not cl-pred cl-keys)) + (apply 'cl-rassoc nil cl-list :if-not cl-pred cl-keys)) ;;;###autoload -(defun union (cl-list1 cl-list2 &rest cl-keys) +(defun cl-union (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-union operation. The resulting list contains all items that appear in either LIST1 or LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -782,14 +786,14 @@ to avoid corrupting the original LIST1 and LIST2. (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) (while cl-list2 (if (or cl-keys (numberp (car cl-list2))) - (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys)) + (setq cl-list1 (apply 'cl-adjoin (car cl-list2) cl-list1 cl-keys)) (or (memq (car cl-list2) cl-list1) (push (car cl-list2) cl-list1))) (pop cl-list2)) cl-list1))) ;;;###autoload -(defun nunion (cl-list1 cl-list2 &rest cl-keys) +(defun cl-nunion (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-union operation. The resulting list contains all items that appear in either LIST1 or LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -797,10 +801,10 @@ whenever possible. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) - (t (apply 'union cl-list1 cl-list2 cl-keys)))) + (t (apply 'cl-union cl-list1 cl-list2 cl-keys)))) ;;;###autoload -(defun intersection (cl-list1 cl-list2 &rest cl-keys) +(defun cl-intersection (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-intersection operation. The resulting list contains all items that appear in both LIST1 and LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -815,7 +819,7 @@ to avoid corrupting the original LIST1 and LIST2. (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) (while cl-list2 (if (if (or cl-keys (numberp (car cl-list2))) - (apply 'member* (cl-check-key (car cl-list2)) + (apply 'cl-member (cl-check-key (car cl-list2)) cl-list1 cl-keys) (memq (car cl-list2) cl-list1)) (push (car cl-list2) cl-res)) @@ -823,17 +827,17 @@ to avoid corrupting the original LIST1 and LIST2. cl-res))))) ;;;###autoload -(defun nintersection (cl-list1 cl-list2 &rest cl-keys) +(defun cl-nintersection (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-intersection operation. The resulting list contains all items that appear in both LIST1 and LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 whenever possible. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" - (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys))) + (and cl-list1 cl-list2 (apply 'cl-intersection cl-list1 cl-list2 cl-keys))) ;;;###autoload -(defun set-difference (cl-list1 cl-list2 &rest cl-keys) +(defun cl-set-difference (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-difference operation. The resulting list contains all items that appear in LIST1 but not LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -845,7 +849,7 @@ to avoid corrupting the original LIST1 and LIST2. (let ((cl-res nil)) (while cl-list1 (or (if (or cl-keys (numberp (car cl-list1))) - (apply 'member* (cl-check-key (car cl-list1)) + (apply 'cl-member (cl-check-key (car cl-list1)) cl-list2 cl-keys) (memq (car cl-list1) cl-list2)) (push (car cl-list1) cl-res)) @@ -853,7 +857,7 @@ to avoid corrupting the original LIST1 and LIST2. cl-res)))) ;;;###autoload -(defun nset-difference (cl-list1 cl-list2 &rest cl-keys) +(defun cl-nset-difference (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-difference operation. The resulting list contains all items that appear in LIST1 but not LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -861,10 +865,10 @@ whenever possible. \nKeywords supported: :test :test-not :key \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (if (or (null cl-list1) (null cl-list2)) cl-list1 - (apply 'set-difference cl-list1 cl-list2 cl-keys))) + (apply 'cl-set-difference cl-list1 cl-list2 cl-keys))) ;;;###autoload -(defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys) +(defun cl-set-exclusive-or (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-exclusive-or operation. The resulting list contains all items appearing in exactly one of LIST1, LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -873,11 +877,11 @@ to avoid corrupting the original LIST1 and LIST2. \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) ((equal cl-list1 cl-list2) nil) - (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys) - (apply 'set-difference cl-list2 cl-list1 cl-keys))))) + (t (append (apply 'cl-set-difference cl-list1 cl-list2 cl-keys) + (apply 'cl-set-difference cl-list2 cl-list1 cl-keys))))) ;;;###autoload -(defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys) +(defun cl-nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-exclusive-or operation. The resulting list contains all items appearing in exactly one of LIST1, LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -886,11 +890,11 @@ whenever possible. \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) ((equal cl-list1 cl-list2) nil) - (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys) - (apply 'nset-difference cl-list2 cl-list1 cl-keys))))) + (t (nconc (apply 'cl-nset-difference cl-list1 cl-list2 cl-keys) + (apply 'cl-nset-difference cl-list2 cl-list1 cl-keys))))) ;;;###autoload -(defun subsetp (cl-list1 cl-list2 &rest cl-keys) +(defun cl-subsetp (cl-list1 cl-list2 &rest cl-keys) "Return true if LIST1 is a subset of LIST2. I.e., if every element of LIST1 also appears in LIST2. \nKeywords supported: :test :test-not :key @@ -899,54 +903,54 @@ I.e., if every element of LIST1 also appears in LIST2. ((equal cl-list1 cl-list2) t) (t (cl-parsing-keywords (:key) (:test :test-not) (while (and cl-list1 - (apply 'member* (cl-check-key (car cl-list1)) + (apply 'cl-member (cl-check-key (car cl-list1)) cl-list2 cl-keys)) (pop cl-list1)) (null cl-list1))))) ;;;###autoload -(defun subst-if (cl-new cl-pred cl-tree &rest cl-keys) +(defun cl-subst-if (cl-new cl-pred cl-tree &rest cl-keys) "Substitute NEW for elements matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all matching elements replaced by NEW. \nKeywords supported: :key \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" - (apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) + (apply 'cl-sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) ;;;###autoload -(defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) +(defun cl-subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all non-matching elements replaced by NEW. \nKeywords supported: :key \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" - (apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) + (apply 'cl-sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) ;;;###autoload -(defun nsubst (cl-new cl-old cl-tree &rest cl-keys) +(defun cl-nsubst (cl-new cl-old cl-tree &rest cl-keys) "Substitute NEW for OLD everywhere in TREE (destructively). Any element of TREE which is `eql' to OLD is changed to NEW (via a call to `setcar'). \nKeywords supported: :test :test-not :key \n(fn NEW OLD TREE [KEYWORD VALUE]...)" - (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) + (apply 'cl-nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) ;;;###autoload -(defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys) +(defun cl-nsubst-if (cl-new cl-pred cl-tree &rest cl-keys) "Substitute NEW for elements matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). \nKeywords supported: :key \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" - (apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) + (apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) ;;;###autoload -(defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) +(defun cl-nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) "Substitute NEW for elements not matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). \nKeywords supported: :key \n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" - (apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) + (apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) ;;;###autoload -(defun sublis (cl-alist cl-tree &rest cl-keys) +(defun cl-sublis (cl-alist cl-tree &rest cl-keys) "Perform substitutions indicated by ALIST in TREE (non-destructively). Return a copy of TREE with all matching elements replaced. \nKeywords supported: :test :test-not :key @@ -969,7 +973,7 @@ Return a copy of TREE with all matching elements replaced. cl-tree)))) ;;;###autoload -(defun nsublis (cl-alist cl-tree &rest cl-keys) +(defun cl-nsublis (cl-alist cl-tree &rest cl-keys) "Perform substitutions indicated by ALIST in TREE (destructively). Any matching element of TREE is changed via a call to `setcar'. \nKeywords supported: :test :test-not :key @@ -994,7 +998,7 @@ Any matching element of TREE is changed via a call to `setcar'. (setq cl-tree (cdr cl-tree)))))) ;;;###autoload -(defun tree-equal (cl-x cl-y &rest cl-keys) +(defun cl-tree-equal (cl-x cl-y &rest cl-keys) "Return t if trees TREE1 and TREE2 have `eql' leaves. Atoms are compared by `eql'; cons cells are compared recursively. \nKeywords supported: :test :test-not :key 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..d162a377f9b 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -1,9 +1,8 @@ -;;; cl.el --- Common Lisp extensions for Emacs +;;; cl.el --- Compatibility aliases for the old CL library. -;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 2012 Free Software Foundation, Inc. -;; Author: Dave Gillespie <daveg@synaptics.com> -;; Version: 2.02 +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: extensions ;; This file is part of GNU Emacs. @@ -23,699 +22,517 @@ ;;; Commentary: -;; These are extensions to Emacs Lisp that provide a degree of -;; Common Lisp compatibility, beyond what is already built-in -;; in Emacs Lisp. -;; -;; This package was written by Dave Gillespie; it is a complete -;; rewrite of Cesar Quiroz's original cl.el package of December 1986. -;; -;; Bug reports, comments, and suggestions are welcome! - -;; This file contains the portions of the Common Lisp extensions -;; package which should always be present. - - -;;; Future notes: - -;; Once Emacs 19 becomes standard, many things in this package which are -;; messy for reasons of compatibility can be greatly simplified. For now, -;; I prefer to maintain one unified version. - - -;;; Change Log: - -;; Version 2.02 (30 Jul 93): -;; * Added "cl-compat.el" file, extra compatibility with old package. -;; * Added `lexical-let' and `lexical-let*'. -;; * Added `define-modify-macro', `callf', and `callf2'. -;; * Added `ignore-errors'. -;; * Changed `(setf (nthcdr N PLACE) X)' to work when N is zero. -;; * Merged `*gentemp-counter*' into `*gensym-counter*'. -;; * Extended `subseq' to allow negative START and END like `substring'. -;; * Added `in-ref', `across-ref', `elements of-ref' loop clauses. -;; * Added `concat', `vconcat' loop clauses. -;; * Cleaned up a number of compiler warnings. - -;; Version 2.01 (7 Jul 93): -;; * Added support for FSF version of Emacs 19. -;; * Added `add-hook' for Emacs 18 users. -;; * Added `defsubst*' and `symbol-macrolet'. -;; * Added `maplist', `mapc', `mapl', `mapcan', `mapcon'. -;; * Added `map', `concatenate', `reduce', `merge'. -;; * Added `revappend', `nreconc', `tailp', `tree-equal'. -;; * Added `assert', `check-type', `typecase', `typep', and `deftype'. -;; * Added destructuring and `&environment' support to `defmacro*'. -;; * Added destructuring to `loop', and added the following clauses: -;; `elements', `frames', `overlays', `intervals', `buffers', `key-seqs'. -;; * Renamed `delete' to `delete*' and `remove' to `remove*'. -;; * Completed support for all keywords in `remove*', `substitute', etc. -;; * Added `most-positive-float' and company. -;; * Fixed hash tables to work with latest Lucid Emacs. -;; * `proclaim' forms are no longer compile-time-evaluating; use `declaim'. -;; * Syntax for `warn' declarations has changed. -;; * Improved implementation of `random*'. -;; * Moved most sequence functions to a new file, cl-seq.el. -;; * Moved `eval-when' into cl-macs.el. -;; * Moved `pushnew' and `adjoin' to cl.el for most common cases. -;; * Moved `provide' forms down to ends of files. -;; * Changed expansion of `pop' to something that compiles to better code. -;; * Changed so that no patch is required for Emacs 19 byte compiler. -;; * Made more things dependent on `optimize' declarations. -;; * Added a partial implementation of struct print functions. -;; * Miscellaneous minor changes. - -;; Version 2.00: -;; * First public release of this package. - +;; This is a compatibility file which provides the old names provided by CL +;; before we cleaned up its namespace usage. ;;; Code: -(defvar cl-optimize-speed 1) -(defvar cl-optimize-safety 1) - - +(require 'cl-lib) +(require 'macroexp) + +;; (defun cl--rename () +;; (let ((vdefs ()) +;; (fdefs ()) +;; (case-fold-search nil) +;; (files '("cl.el" "cl-macs.el" "cl-seq.el" "cl-extra.el"))) +;; (dolist (file files) +;; (with-current-buffer (find-file-noselect file) +;; (goto-char (point-min)) +;; (while (re-search-forward +;; "^(\\(def[^ \t\n]*\\) +'?\\(\\(\\sw\\|\\s_\\)+\\)" nil t) +;; (let ((name (match-string-no-properties 2)) +;; (type (match-string-no-properties 1))) +;; (unless (string-match-p "\\`cl-" name) +;; (cond +;; ((member type '("defvar" "defconst")) +;; (unless (member name vdefs) (push name vdefs))) +;; ((member type '("defun" "defsubst" "defalias" "defmacro")) +;; (unless (member name fdefs) (push name fdefs))) +;; ((member type '("def-edebug-spec" "defsetf" "define-setf-method" +;; "define-compiler-macro")) +;; nil) +;; (t (error "Unknown type %S" type)))))))) +;; (let ((re (concat "\\_<" (regexp-opt (append vdefs fdefs)) "\\_>")) +;; (conflicts ())) +;; (dolist (file files) +;; (with-current-buffer (find-file-noselect file) +;; (goto-char (point-min)) +;; (while (re-search-forward re nil t) +;; (replace-match "cl-\\&")) +;; (save-buffer)))) +;; (with-current-buffer (find-file-noselect "cl-rename.el") +;; (dolist (def vdefs) +;; (insert (format "(defvaralias '%s 'cl-%s)\n" def def))) +;; (dolist (def fdefs) +;; (insert (format "(defalias '%s 'cl-%s)\n" def def))) +;; (save-buffer)))) + +;; (defun cl--unrename () +;; ;; Taken from "Naming Conventions" node of the doc. +;; (let* ((names '(defun* defsubst* defmacro* function* member* +;; assoc* rassoc* get* remove* delete* +;; mapcar* sort* floor* ceiling* truncate* +;; round* mod* rem* random*)) +;; (files '("cl.el" "cl-lib.el" "cl-macs.el" "cl-seq.el" "cl-extra.el")) +;; (re (concat "\\_<cl-" (regexp-opt (mapcar #'symbol-name names)) +;; "\\_>"))) +;; (dolist (file files) +;; (with-current-buffer (find-file-noselect file) +;; (goto-char (point-min)) +;; (while (re-search-forward re nil t) +;; (delete-region (1- (point)) (point))) +;; (save-buffer))))) +(dolist (var '( + ;; loop-result-var + ;; loop-result + ;; loop-initially + ;; loop-finally + ;; loop-bindings + ;; loop-args + ;; bind-inits + ;; bind-block + ;; lambda-list-keywords + float-negative-epsilon + float-epsilon + least-negative-normalized-float + least-positive-normalized-float + least-negative-float + least-positive-float + most-negative-float + most-positive-float + ;; custom-print-functions + )) + (defvaralias var (intern (format "cl-%s" var)))) + +(dolist (fun '( + (get* . cl-get) + (random* . cl-random) + (rem* . cl-rem) + (mod* . cl-mod) + (round* . cl-round) + (truncate* . cl-truncate) + (ceiling* . cl-ceiling) + (floor* . cl-floor) + (rassoc* . cl-rassoc) + (assoc* . cl-assoc) + (member* . cl-member) + (delete* . cl-delete) + (remove* . cl-remove) + (defsubst* . cl-defsubst) + (sort* . cl-sort) + (function* . cl-function) + (defmacro* . cl-defmacro) + (defun* . cl-defun) + (mapcar* . cl-mapcar) + + remprop + getf + tailp + list-length + nreconc + revappend + concatenate + subseq + random-state-p + make-random-state + signum + isqrt + lcm + gcd + notevery + notany + every + some + mapcon + mapcan + mapl + maplist + map + equalp + coerce + tree-equal + nsublis + sublis + nsubst-if-not + nsubst-if + 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 + assoc-if-not + assoc-if + member-if-not + member-if + merge + stable-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 + remove-if-not + remove-if + replace + fill + reduce + compiler-macroexpand + define-compiler-macro + assert + check-type + typep + deftype + defstruct + define-modify-macro + callf2 + callf + letf* + letf + rotatef + shiftf + remf + psetf + setf + get-setf-method + defsetf + (define-setf-method . cl-define-setf-expander) + define-setf-expander + declare + the + locally + multiple-value-setq + multiple-value-bind + symbol-macrolet + macrolet + 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 + gentemp + gensym + pairlis + acons + subst + adjoin + copy-list + ldiff + list* + cddddr + cdddar + cddadr + cddaar + cdaddr + cdadar + cdaadr + cdaaar + cadddr + caddar + cadadr + cadaar + caaddr + caadar + caaadr + caaaar + cdddr + cddar + cdadr + cdaar + caddr + cadar + caadr + caaar + tenth + ninth + eighth + seventh + sixth + fifth + fourth + third + endp + rest + second + first + svref + copy-seq + evenp + oddp + minusp + plusp + floatp-safe + declaim + proclaim + nth-value + multiple-value-call + multiple-value-apply + multiple-value-list + values-list + values + pushnew + push + pop + decf + incf + )) + (let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun))) + (intern (format "cl-%s" fun))))) + (defalias fun new) + ;; If `cl-foo' is declare inline, then make `foo' inline as well, and + ;; similarly. Same for edebug specifications, indent rules and + ;; doc-string position. + ;; FIXME: For most of them, we should instead follow aliases + ;; where applicable. + (dolist (prop '(byte-optimizer doc-string-elt edebug-form-spec + lisp-indent-function)) + (if (get new prop) + (put fun prop (get new prop)))))) + +(defvar cl-closure-vars nil) +(defvar cl--function-convert-cache nil) + +(defun cl--function-convert (f) + "Special macro-expander for special cases of (function F). +The two cases that are handled are: +- closure-conversion of lambda expressions for `lexical-let'. +- renaming of F when it's a function defined via `cl-labels' or `labels'." + (require 'cl-macs) + (cond + ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked + ;; *after* handling `function', but we want to stop macroexpansion from + ;; being applied infinitely, so we use a cache to return the exact `form' + ;; being expanded even though we don't receive it. + ((eq f (car cl--function-convert-cache)) (cdr cl--function-convert-cache)) + ((eq (car-safe f) 'lambda) + (let ((body (mapcar (lambda (f) + (macroexpand-all f macroexpand-all-environment)) + (cddr f)))) + (if (and cl-closure-vars + (cl--expr-contains-any body cl-closure-vars)) + (let* ((new (mapcar 'cl-gensym cl-closure-vars)) + (sub (cl-pairlis cl-closure-vars new)) (decls nil)) + (while (or (stringp (car body)) + (eq (car-safe (car body)) 'interactive)) + (push (list 'quote (pop body)) decls)) + (put (car (last cl-closure-vars)) 'used t) + `(list 'lambda '(&rest --cl-rest--) + ,@(cl-sublis sub (nreverse decls)) + (list 'apply + (list 'quote + #'(lambda ,(append new (cadr f)) + ,@(cl-sublis sub body))) + ,@(nconc (mapcar (lambda (x) `(list 'quote ,x)) + cl-closure-vars) + '((quote --cl-rest--)))))) + (let* ((newf `(lambda ,(cadr f) ,@body)) + (res `(function ,newf))) + (setq cl--function-convert-cache (cons newf res)) + res)))) + (t + (let ((found (assq f macroexpand-all-environment))) + (if (and found (ignore-errors + (eq (cadr (cl-caddr found)) 'cl-labels-args))) + (cadr (cl-caddr (cl-cadddr found))) + (let ((res `(function ,f))) + (setq cl--function-convert-cache (cons f res)) + res)))))) + +(defmacro lexical-let (bindings &rest body) + "Like `let', but lexically scoped. +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) + (or (consp x) (setq x (list x))) + (push (make-symbol (format "--cl-%s--" (car x))) + cl-closure-vars) + (set (car cl-closure-vars) [bad-lexical-ref]) + (list (car x) (cadr x) (car cl-closure-vars)))) + bindings)) + (ebody + (macroexpand-all + `(cl-symbol-macrolet + ,(mapcar (lambda (x) + `(,(car x) (symbol-value ,(cl-caddr x)))) + vars) + ,@body) + (cons (cons 'function #'cl--function-convert) + macroexpand-all-environment)))) + (if (not (get (car (last cl-closure-vars)) 'used)) + ;; Turn (let ((foo (cl-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 ,(cl-caddr x))) vars) + (let ,(mapcar (lambda (x) (list (cl-caddr x) (cadr x))) vars) + ,(cl-sublis (mapcar (lambda (x) + (cons (cl-caddr x) + `',(cl-caddr x))) + vars) + ebody))) + `(let ,(mapcar (lambda (x) + (list (cl-caddr x) + `(make-symbol ,(format "--%s--" (car x))))) + vars) + (cl-setf ,@(apply #'append + (mapcar (lambda (x) + (list `(symbol-value ,(cl-caddr x)) (cadr x))) + vars))) + ,ebody)))) + +(defmacro lexical-let* (bindings &rest body) + "Like `let*', but lexically scoped. +The main visible difference is that lambdas inside BODY, and in +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 + (setq body (list `(lexical-let (,(pop bindings)) ,@body)))) + (car body))) + +;; This should really have some way to shadow 'byte-compile properties, etc. ;;;###autoload -(defvar custom-print-functions nil - "This is a list of functions that format user objects for printing. -Each function is called in turn with three arguments: the object, the -stream, and the print level (currently ignored). If it is able to -print the object it returns true; otherwise it returns nil and the -printer proceeds to the next function on the list. - -This variable is not used at present, but it is defined in hopes that -a future Emacs interpreter will be able to use it.") - -(defun cl-unload-function () - "Stop unloading of the Common Lisp extensions." - (message "Cannot unload the feature `cl'") - ;; stop standard unloading! - t) - -;;; Generalized variables. -;; These macros are defined here so that they -;; can safely be used in .emacs files. - -(defmacro incf (place &optional x) - "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." - (if (symbolp place) - (list 'setq place (if x (list '+ place x) (list '1+ place))) - (list 'callf '+ place (or x 1)))) - -(defmacro decf (place &optional x) - "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." - (if (symbolp place) - (list 'setq place (if x (list '- place x) (list '1- place))) - (list 'callf '- place (or x 1)))) - -;; Autoloaded, but we haven't loaded cl-loaddefs yet. -(declare-function cl-do-pop "cl-macs" (place)) - -(defmacro pop (place) - "Remove and return the head of the list stored in 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'." - (if (symbolp place) - (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))) - (cl-do-pop place))) - -(defmacro push (x place) - "Insert X at the head of the list stored in PLACE. -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'." - (if (symbolp place) (list 'setq place (list 'cons x place)) - (list 'callf2 'cons x place))) - -(defmacro pushnew (x place &rest keys) - "(pushnew X PLACE): insert X at the head of the list if not already there. -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]...)" - (if (symbolp place) - (if (null keys) - `(let ((x ,x)) - (if (memql x ,place) - ;; This symbol may later on expand to actual code which then - ;; trigger warnings like "value unused" since pushnew's return - ;; value is rarely used. It should not matter that other - ;; warnings may be silenced, since `place' is used earlier and - ;; should have triggered them already. - (with-no-warnings ,place) - (setq ,place (cons x ,place)))) - (list 'setq place (list* 'adjoin x place keys))) - (list* 'callf2 'adjoin x place keys))) - -(defun cl-set-elt (seq n val) - (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) - -(defsubst cl-set-nthcdr (n list x) - (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list)) - -(defun cl-set-buffer-substring (start end val) - (save-excursion (delete-region start end) - (goto-char start) - (insert val) - val)) - -(defun cl-set-substring (str start end val) - (if end (if (< end 0) (incf end (length str))) - (setq end (length str))) - (if (< start 0) (incf start (length str))) - (concat (and (> start 0) (substring str 0 start)) - val - (and (< end (length str)) (substring str end)))) - - -;;; Control structures. - -;; These macros are so simple and so often-used that it's better to have -;; them all the time than to load them from cl-macs.el. - -(defun cl-map-extents (&rest cl-args) - (apply 'cl-map-overlays cl-args)) - - -;;; Blocks and exits. - -(defalias 'cl-block-wrapper 'identity) -(defalias 'cl-block-throw 'throw) - - -;;; Multiple values. -;; True multiple values are not supported, or even -;; simulated. Instead, multiple-value-bind and friends simply expect -;; the target form to return the values as a list. - -(defsubst values (&rest values) - "Return multiple values, Common Lisp style. -The arguments of `values' are the values -that the containing function should return." - values) - -(defsubst values-list (list) - "Return multiple values, Common Lisp style, taken from a list. -LIST specifies the list of values -that the containing function should return." - list) - -(defsubst multiple-value-list (expression) - "Return a list of the multiple values produced by EXPRESSION. -This handles multiple values in Common Lisp style, but it does not -work right when EXPRESSION calls an ordinary Emacs Lisp function -that returns just one value." - expression) - -(defsubst multiple-value-apply (function expression) - "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them. -This handles multiple values in Common Lisp style, but it does not work -right when EXPRESSION calls an ordinary Emacs Lisp function that returns just -one value." - (apply function expression)) - -(defalias 'multiple-value-call 'apply - "Apply FUNCTION to ARGUMENTS, taking multiple values into account. -This implementation only handles the case where there is only one argument.") - -(defsubst nth-value (n expression) - "Evaluate EXPRESSION to get multiple values and return the Nth one. -This handles multiple values in Common Lisp style, but it does not work -right when EXPRESSION calls an ordinary Emacs Lisp function that returns just -one value." - (nth n expression)) - -;;; Macros. - -(defvar cl-macro-environment) -(defvar cl-old-macroexpand (prog1 (symbol-function 'macroexpand) - (defalias 'macroexpand 'cl-macroexpand))) - -(defun cl-macroexpand (cl-macro &optional cl-env) - "Return result of expanding macros at top level of FORM. -If FORM is not a macro call, it is returned unchanged. -Otherwise, the macro is expanded and the expansion is considered -in place of FORM. When a non-macro-call results, it is returned. - -The second optional arg ENVIRONMENT specifies an environment of macro -definitions to shadow the loaded ones for use in file byte-compilation. -\n(fn FORM &optional ENVIRONMENT)" - (let ((cl-macro-environment cl-env)) - (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env)) - (and (symbolp cl-macro) - (cdr (assq (symbol-name cl-macro) cl-env)))) - (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))) - cl-macro)) - - -;;; Declarations. - -(defvar cl-compiling-file nil) -(defun cl-compiling-file () - (or cl-compiling-file - (and (boundp 'byte-compile--outbuffer) - (bufferp (symbol-value 'byte-compile--outbuffer)) - (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) - " *Compiler Output*")))) - -(defvar cl-proclaims-deferred nil) - -(defun proclaim (spec) - (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t) - (push spec cl-proclaims-deferred)) - nil) - -(defmacro declaim (&rest specs) - (let ((body (mapcar (function (lambda (x) (list 'proclaim (list 'quote x)))) - specs))) - (if (cl-compiling-file) (list* 'eval-when '(compile load eval) body) - (cons 'progn body)))) ; avoid loading cl-macs.el for eval-when - - -;;; Symbols. - -(defun cl-random-time () - (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) - (while (>= (decf i) 0) (setq v (+ (* v 3) (aref time i)))) - v)) - -(defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100)) - - -;;; Numbers. - -(defun floatp-safe (object) - "Return t if OBJECT is a floating point number. -On Emacs versions that lack floating-point support, this function -always returns nil." - (and (numberp object) (not (integerp object)))) - -(defun plusp (number) - "Return t if NUMBER is positive." - (> number 0)) - -(defun minusp (number) - "Return t if NUMBER is negative." - (< number 0)) - -(defun oddp (integer) - "Return t if INTEGER is odd." - (eq (logand integer 1) 1)) - -(defun evenp (integer) - "Return t if INTEGER is even." - (eq (logand integer 1) 0)) - -(defvar *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. -If your system supports infinities, this is the largest finite value. -For IEEE machines, this is approximately 1.79e+308. -Call `cl-float-limits' to set this.") - -(defconst most-negative-float nil - "The largest negative value that a Lisp float can hold. -This is simply -`most-positive-float'. -Call `cl-float-limits' to set this.") - -(defconst least-positive-float nil - "The smallest value greater than zero that a Lisp float can hold. -For IEEE machines, it is about 4.94e-324 if denormals are supported, -or 2.22e-308 if they are not. -Call `cl-float-limits' to set this.") - -(defconst least-negative-float nil - "The smallest value less than zero that a Lisp float can hold. -This is simply -`least-positive-float'. -Call `cl-float-limits' to set this.") - -(defconst least-positive-normalized-float nil - "The smallest normalized Lisp float greater than zero. -This is the smallest value for which IEEE denormalization does not lose -precision. For IEEE machines, this value is about 2.22e-308. -For machines that do not support the concept of denormalization -and gradual underflow, this constant equals `least-positive-float'. -Call `cl-float-limits' to set this.") - -(defconst least-negative-normalized-float nil - "The smallest normalized Lisp float less than zero. -This is simply -`least-positive-normalized-float'. -Call `cl-float-limits' to set this.") - -(defconst float-epsilon nil - "The smallest positive float that adds to 1.0 to give a distinct value. -Adding a number less than this to 1.0 returns 1.0 due to roundoff. -For IEEE machines, epsilon is about 2.22e-16. -Call `cl-float-limits' to set this.") +(defmacro flet (bindings &rest body) + "Make temporary function definitions. +This is an analogue of `let' that operates on the function cell of FUNC +rather than its value cell. The FORMs are evaluated with the specified +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 cl-flet)) + `(cl-letf* ,(mapcar + (lambda (x) + (if (or (and (fboundp (car x)) + (eq (car-safe (symbol-function (car x))) 'macro)) + (cdr (assq (car x) macroexpand-all-environment))) + (error "Use `labels', not `flet', to rebind macro names")) + (let ((func `(cl-function + (lambda ,(cadr x) + (cl-block ,(car x) ,@(cddr x)))))) + (when (cl-compiling-file) + ;; Bug#411. It would be nice to fix this. + (and (get (car x) 'byte-compile) + (error "Byte-compiling a redefinition of `%s' \ +will not work - use `labels' instead" (symbol-name (car x)))) + ;; FIXME This affects the rest of the file, when it + ;; should be restricted to the flet body. + (and (boundp 'byte-compile-function-environment) + (push (cons (car x) (eval func)) + byte-compile-function-environment))) + (list `(symbol-function ',(car x)) func))) + bindings) + ,@body)) + +(defmacro labels (bindings &rest body) + "Make temporary function bindings. +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 cl-flet)) + (let ((vars nil) (sets nil) (newenv macroexpand-all-environment)) + (dolist (binding bindings) + ;; It's important that (not (eq (symbol-name var1) (symbol-name var2))) + ;; because these var's *names* get added to the macro-environment. + (let ((var (make-symbol (format "--cl-%s--" (car binding))))) + (push var vars) + (push `(cl-function (lambda . ,(cdr binding))) sets) + (push var sets) + (push (cons (car binding) + `(lambda (&rest cl-labels-args) + (cl-list* 'funcall ',var + cl-labels-args))) + newenv))) + (macroexpand-all `(lexical-let ,vars (setq ,@sets) ,@body) newenv))) + +;;; Additional compatibility code +;; For names that were clean but really aren't needed any more. + +(define-obsolete-function-alias 'cl-macroexpand 'macroexpand "24.2") +(define-obsolete-variable-alias 'cl-macro-environment + 'macroexpand-all-environment "24.2") +(define-obsolete-function-alias 'cl-macroexpand-all 'macroexpand-all "24.2") + +;;; Hash tables. +;; This is just kept for compatibility with code byte-compiled by Emacs-20. + +;; No idea if this might still be needed. +(defun cl-not-hash-table (x &optional y &rest z) + (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x)))) +(make-obsolete 'cl-not-hash-table nil "24.2") + +(defvar cl-builtin-gethash (symbol-function 'gethash)) +(make-obsolete-variable 'cl-builtin-gethash nil "24.2") +(defvar cl-builtin-remhash (symbol-function 'remhash)) +(make-obsolete-variable 'cl-builtin-remhash nil "24.2") +(defvar cl-builtin-clrhash (symbol-function 'clrhash)) +(make-obsolete-variable 'cl-builtin-clrhash nil "24.2") +(defvar cl-builtin-maphash (symbol-function 'maphash)) + +(make-obsolete-variable 'cl-builtin-maphash nil "24.2") +(define-obsolete-function-alias 'cl-map-keymap 'map-keymap "24.2") +(define-obsolete-function-alias 'cl-copy-tree 'copy-tree "24.2") +(define-obsolete-function-alias 'cl-gethash 'gethash "24.2") +(define-obsolete-function-alias 'cl-puthash 'puthash "24.2") +(define-obsolete-function-alias 'cl-remhash 'remhash "24.2") +(define-obsolete-function-alias 'cl-clrhash 'clrhash "24.2") +(define-obsolete-function-alias 'cl-maphash 'maphash "24.2") +(define-obsolete-function-alias 'cl-make-hash-table 'make-hash-table "24.2") +(define-obsolete-function-alias 'cl-hash-table-p 'hash-table-p "24.2") +(define-obsolete-function-alias 'cl-hash-table-count 'hash-table-count "24.2") + +;; FIXME: More candidates: define-modify-macro, define-setf-expander. -(defconst float-negative-epsilon nil - "The smallest positive float that subtracts from 1.0 to give a distinct value. -For IEEE machines, it is about 1.11e-16. -Call `cl-float-limits' to set this.") - - -;;; Sequence functions. - -(defalias 'copy-seq 'copy-sequence) - -(declare-function cl-mapcar-many "cl-extra" (cl-func cl-seqs)) - -(defun mapcar* (cl-func cl-x &rest cl-rest) - "Apply FUNCTION to each element of SEQ, and make a list of the results. -If there are several SEQs, FUNCTION is called with that many arguments, -and mapping stops as soon as the shortest list runs out. With just one -SEQ, this is like `mapcar'. With several, it is like the Common Lisp -`mapcar' function extended to arbitrary sequence types. -\n(fn FUNCTION SEQ...)" - (if cl-rest - (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) - (cl-mapcar-many cl-func (cons cl-x cl-rest)) - (let ((cl-res nil) (cl-y (car cl-rest))) - (while (and cl-x cl-y) - (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) - (nreverse cl-res))) - (mapcar cl-func cl-x))) - -(defalias 'svref 'aref) - -;;; List functions. - -(defalias 'first 'car) -(defalias 'second 'cadr) -(defalias 'rest 'cdr) -(defalias 'endp 'null) - -(defun third (x) - "Return the third element of the list X." - (car (cdr (cdr x)))) - -(defun fourth (x) - "Return the fourth element of the list X." - (nth 3 x)) - -(defun fifth (x) - "Return the fifth element of the list X." - (nth 4 x)) - -(defun sixth (x) - "Return the sixth element of the list X." - (nth 5 x)) - -(defun seventh (x) - "Return the seventh element of the list X." - (nth 6 x)) - -(defun eighth (x) - "Return the eighth element of the list X." - (nth 7 x)) - -(defun ninth (x) - "Return the ninth element of the list X." - (nth 8 x)) - -(defun tenth (x) - "Return the tenth element of the list X." - (nth 9 x)) - -(defun caaar (x) - "Return the `car' of the `car' of the `car' of X." - (car (car (car x)))) - -(defun caadr (x) - "Return the `car' of the `car' of the `cdr' of X." - (car (car (cdr x)))) - -(defun cadar (x) - "Return the `car' of the `cdr' of the `car' of X." - (car (cdr (car x)))) - -(defun caddr (x) - "Return the `car' of the `cdr' of the `cdr' of X." - (car (cdr (cdr x)))) - -(defun cdaar (x) - "Return the `cdr' of the `car' of the `car' of X." - (cdr (car (car x)))) - -(defun cdadr (x) - "Return the `cdr' of the `car' of the `cdr' of X." - (cdr (car (cdr x)))) - -(defun cddar (x) - "Return the `cdr' of the `cdr' of the `car' of X." - (cdr (cdr (car x)))) - -(defun cdddr (x) - "Return the `cdr' of the `cdr' of the `cdr' of X." - (cdr (cdr (cdr x)))) - -(defun caaaar (x) - "Return the `car' of the `car' of the `car' of the `car' of X." - (car (car (car (car x))))) - -(defun caaadr (x) - "Return the `car' of the `car' of the `car' of the `cdr' of X." - (car (car (car (cdr x))))) - -(defun caadar (x) - "Return the `car' of the `car' of the `cdr' of the `car' of X." - (car (car (cdr (car x))))) - -(defun caaddr (x) - "Return the `car' of the `car' of the `cdr' of the `cdr' of X." - (car (car (cdr (cdr x))))) - -(defun cadaar (x) - "Return the `car' of the `cdr' of the `car' of the `car' of X." - (car (cdr (car (car x))))) - -(defun cadadr (x) - "Return the `car' of the `cdr' of the `car' of the `cdr' of X." - (car (cdr (car (cdr x))))) - -(defun caddar (x) - "Return the `car' of the `cdr' of the `cdr' of the `car' of X." - (car (cdr (cdr (car x))))) - -(defun cadddr (x) - "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." - (car (cdr (cdr (cdr x))))) - -(defun cdaaar (x) - "Return the `cdr' of the `car' of the `car' of the `car' of X." - (cdr (car (car (car x))))) - -(defun cdaadr (x) - "Return the `cdr' of the `car' of the `car' of the `cdr' of X." - (cdr (car (car (cdr x))))) - -(defun cdadar (x) - "Return the `cdr' of the `car' of the `cdr' of the `car' of X." - (cdr (car (cdr (car x))))) - -(defun cdaddr (x) - "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." - (cdr (car (cdr (cdr x))))) - -(defun cddaar (x) - "Return the `cdr' of the `cdr' of the `car' of the `car' of X." - (cdr (cdr (car (car x))))) - -(defun cddadr (x) - "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." - (cdr (cdr (car (cdr x))))) - -(defun cdddar (x) - "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." - (cdr (cdr (cdr (car x))))) - -(defun cddddr (x) - "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." - (cdr (cdr (cdr (cdr x))))) - -;;(defun last* (x &optional n) -;; "Returns the last link in the list LIST. -;;With optional argument N, returns Nth-to-last link (default 1)." -;; (if n -;; (let ((m 0) (p x)) -;; (while (consp p) (incf m) (pop p)) -;; (if (<= n 0) p -;; (if (< n m) (nthcdr (- m n) x) x))) -;; (while (consp (cdr x)) (pop x)) -;; x)) - -(defun list* (arg &rest rest) ; See compiler macro in cl-macs.el - "Return a new list with specified ARGs as elements, consed to last ARG. -Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to -`(cons A (cons B (cons C D)))'. -\n(fn ARG...)" - (cond ((not rest) arg) - ((not (cdr rest)) (cons arg (car rest))) - (t (let* ((n (length rest)) - (copy (copy-sequence rest)) - (last (nthcdr (- n 2) copy))) - (setcdr last (car (cdr last))) - (cons arg copy))))) - -(defun ldiff (list sublist) - "Return a copy of LIST with the tail SUBLIST removed." - (let ((res nil)) - (while (and (consp list) (not (eq list sublist))) - (push (pop list) res)) - (nreverse res))) - -(defun copy-list (list) - "Return a copy of LIST, which may be a dotted list. -The elements of LIST are not copied, just the list structure itself." - (if (consp list) - (let ((res nil)) - (while (consp list) (push (pop list) res)) - (prog1 (nreverse res) (setcdr res list))) - (car list))) - -(defun cl-maclisp-member (item list) - (while (and list (not (equal item (car list)))) (setq list (cdr list))) - list) - -(defalias 'cl-member 'memq) ; for compatibility with old CL package - -;; Autoloaded, but we have not loaded cl-loaddefs yet. -(declare-function floor* "cl-extra" (x &optional y)) -(declare-function ceiling* "cl-extra" (x &optional y)) -(declare-function truncate* "cl-extra" (x &optional y)) -(declare-function round* "cl-extra" (x &optional y)) -(declare-function mod* "cl-extra" (x y)) - -(defalias 'cl-floor 'floor*) -(defalias 'cl-ceiling 'ceiling*) -(defalias 'cl-truncate 'truncate*) -(defalias 'cl-round 'round*) -(defalias 'cl-mod 'mod*) - -(defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs - "Return ITEM consed onto the front of LIST only if it's not already there. -Otherwise, return LIST unmodified. -\nKeywords supported: :test :test-not :key -\n(fn ITEM LIST [KEYWORD VALUE]...)" - (cond ((or (equal cl-keys '(:test eq)) - (and (null cl-keys) (not (numberp cl-item)))) - (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)))) - -(defun subst (cl-new cl-old cl-tree &rest cl-keys) - "Substitute NEW for OLD everywhere in TREE (non-destructively). -Return a copy of TREE with all elements `eql' to OLD replaced by NEW. -\nKeywords supported: :test :test-not :key -\n(fn NEW OLD TREE [KEYWORD VALUE]...)" - (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) - (apply 'sublis (list (cons cl-old cl-new)) cl-tree cl-keys) - (cl-do-subst cl-new cl-old cl-tree))) - -(defun cl-do-subst (cl-new cl-old cl-tree) - (cond ((eq cl-tree cl-old) cl-new) - ((consp cl-tree) - (let ((a (cl-do-subst cl-new cl-old (car cl-tree))) - (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) - (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) - cl-tree (cons a d)))) - (t cl-tree))) - -(defun acons (key value alist) - "Add KEY and VALUE to ALIST. -Return a new list with (cons KEY VALUE) as car and ALIST as cdr." - (cons (cons key value) alist)) - -(defun pairlis (keys values &optional alist) - "Make an alist from KEYS and VALUES. -Return a new alist composed by associating KEYS to corresponding VALUES; -the process stops as soon as KEYS or VALUES run out. -If ALIST is non-nil, the new pairs are prepended to it." - (nconc (mapcar* 'cons keys values) alist)) - - -;;; 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) -(load "cl-loaddefs" nil 'quiet) - -;; This goes here so that cl-macs can find it if it loads right now. (provide 'cl) - -;; Things to do after byte-compiler is loaded. - -(defvar cl-hacked-flag nil) -(defun cl-hack-byte-compiler () - (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form) - (progn - (setq cl-hacked-flag t) ; Do it first, to prevent recursion. - (load "cl-macs" nil t) - (run-hooks 'cl-hack-bytecomp-hook)))) - -;; Try it now in case the compiler has already been loaded. -(cl-hack-byte-compiler) - -;; Also make a hook in case compiler is loaded after this file. -(add-hook 'bytecomp-load-hook 'cl-hack-byte-compiler) - - -;; The following ensures that packages which expect the old-style cl.el -;; will be happy with this one. - -(provide 'cl) - -(run-hooks 'cl-load-hook) - -;; Local variables: -;; byte-compile-dynamic: t -;; byte-compile-warnings: (not cl-functions) -;; End: - ;;; cl.el ends here 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/cust-print.el b/lisp/emacs-lisp/cust-print.el deleted file mode 100644 index b456d59e8da..00000000000 --- a/lisp/emacs-lisp/cust-print.el +++ /dev/null @@ -1,683 +0,0 @@ -;;; cust-print.el --- handles print-level and print-circle - -;; Copyright (C) 1992, 2001-2012 Free Software Foundation, Inc. - -;; Author: Daniel LaLiberte <liberte@holonexus.org> -;; Adapted-By: ESR -;; Keywords: extensions - -;; LCD Archive Entry: -;; cust-print|Daniel LaLiberte|liberte@holonexus.org -;; |Handle print-level, print-circle and more. - -;; 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: - -;; This package provides a general print handler for prin1 and princ -;; that supports print-level and print-circle, and by the way, -;; print-length since the standard routines are being replaced. Also, -;; to print custom types constructed from lists and vectors, use -;; custom-print-list and custom-print-vector. See the documentation -;; strings of these variables for more details. - -;; If the results of your expressions contain circular references to -;; other parts of the same structure, the standard Emacs print -;; subroutines may fail to print with an untrappable error, -;; "Apparently circular structure being printed". If you only use cdr -;; circular lists (where cdrs of lists point back; what is the right -;; term here?), you can limit the length of printing with -;; print-length. But car circular lists and circular vectors generate -;; the above mentioned error in Emacs version 18. Version -;; 19 supports print-level, but it is often useful to get a better -;; print representation of circular and shared structures; the print-circle -;; option may be used to print more concise representations. - -;; There are three main ways to use this package. First, you may -;; replace prin1, princ, and some subroutines that use them by calling -;; install-custom-print so that any use of these functions in -;; Lisp code will be affected; you can later reset with -;; uninstall-custom-print. Second, you may temporarily install -;; these functions with the macro with-custom-print. Third, you -;; could call the custom routines directly, thus only affecting the -;; printing that requires them. - -;; Note that subroutines which call print subroutines directly will -;; not use the custom print functions. In particular, the evaluation -;; functions like eval-region call the print subroutines directly. -;; Therefore, if you evaluate (aref circ-list 0), where circ-list is a -;; circular list rather than an array, aref calls error directly which -;; will jump to the top level instead of printing the circular list. - -;; Uninterned symbols are recognized when print-circle is non-nil, -;; but they are not printed specially here. Use the cl-packages package -;; to print according to print-gensym. - -;; Obviously the right way to implement this custom-print facility is -;; in C or with hooks into the standard printer. Please volunteer -;; since I don't have the time or need. More CL-like printing -;; capabilities could be added in the future. - -;; Implementation design: we want to use the same list and vector -;; processing algorithm for all versions of prin1 and princ, since how -;; the processing is done depends on print-length, print-level, and -;; print-circle. For circle printing, a preprocessing step is -;; required before the final printing. Thanks to Jamie Zawinski -;; for motivation and algorithms. - - -;;; Code: - -(defgroup cust-print nil - "Handles print-level and print-circle." - :prefix "print-" - :group 'lisp - :group 'extensions) - -;; If using cl-packages: - -'(defpackage "cust-print" - (:nicknames "CP" "custom-print") - (:use "el") - (:export - print-level - print-circle - - custom-print-install - custom-print-uninstall - custom-print-installed-p - with-custom-print - - custom-prin1 - custom-princ - custom-prin1-to-string - custom-print - custom-format - custom-message - custom-error - - custom-printers - add-custom-printer - )) - -'(in-package cust-print) - -;; Emacs 18 doesn't have defalias. -;; Provide def for byte compiler. -(eval-and-compile - (or (fboundp 'defalias) (fset 'defalias 'fset))) - - -;; Variables: -;;========================================================= - -;;(defvar print-length nil -;; "*Controls how many elements of a list, at each level, are printed. -;;This is defined by emacs.") - -(defcustom print-level nil - "Controls how many levels deep a nested data object will print. - -If nil, printing proceeds recursively and may lead to -max-lisp-eval-depth being exceeded or an error may occur: -`Apparently circular structure being printed.' -Also see `print-length' and `print-circle'. - -If non-nil, components at levels equal to or greater than `print-level' -are printed simply as `#'. The object to be printed is at level 0, -and if the object is a list or vector, its top-level components are at -level 1." - :type '(choice (const nil) integer) - :group 'cust-print) - - -(defcustom print-circle nil - "Controls the printing of recursive structures. - -If nil, printing proceeds recursively and may lead to -`max-lisp-eval-depth' being exceeded or an error may occur: -\"Apparently circular structure being printed.\" Also see -`print-length' and `print-level'. - -If non-nil, shared substructures anywhere in the structure are printed -with `#N=' before the first occurrence (in the order of the print -representation) and `#N#' in place of each subsequent occurrence, -where N is a positive decimal integer. - -There is no way to read this representation in standard Emacs, -but if you need to do so, try the cl-read.el package." - :type 'boolean - :group 'cust-print) - - -(defcustom custom-print-vectors nil - "Non-nil if printing of vectors should obey `print-level' and `print-length'." - :type 'boolean - :group 'cust-print) - - -;; Custom printers -;;========================================================== - -(defvar custom-printers nil - ;; e.g. '((symbolp . pkg::print-symbol)) - "An alist for custom printing of any type. -Pairs are of the form (PREDICATE . PRINTER). If PREDICATE is true -for an object, then PRINTER is called with the object. -PRINTER should print to `standard-output' using cust-print-original-princ -if the standard printer is sufficient, or cust-print-prin for complex things. -The PRINTER should return the object being printed. - -Don't modify this variable directly. Use `add-custom-printer' and -`delete-custom-printer'") -;; Should cust-print-original-princ and cust-print-prin be exported symbols? -;; Or should the standard printers functions be replaced by -;; CP ones in Emacs Lisp so that CP internal functions need not be called? - -(defun add-custom-printer (pred printer) - "Add a pair of PREDICATE and PRINTER to `custom-printers'. -Any pair that has the same PREDICATE is first removed." - (setq custom-printers (cons (cons pred printer) - (delq (assq pred custom-printers) - custom-printers))) - ;; Rather than updating here, we could wait until cust-print-top-level is called. - (cust-print-update-custom-printers)) - -(defun delete-custom-printer (pred) - "Delete the custom printer associated with PREDICATE." - (setq custom-printers (delq (assq pred custom-printers) - custom-printers)) - (cust-print-update-custom-printers)) - - -(defun cust-print-use-custom-printer (object) - ;; Default function returns nil. - nil) - -(defun cust-print-update-custom-printers () - ;; Modify the definition of cust-print-use-custom-printer - (defalias 'cust-print-use-custom-printer - ;; We don't really want to require the byte-compiler. - ;; (byte-compile - `(lambda (object) - (cond - ,@(mapcar (function - (lambda (pair) - `((,(car pair) object) - (,(cdr pair) object)))) - custom-printers) - ;; Otherwise return nil. - (t nil) - )) - ;; ) - )) - - -;; Saving and restoring emacs printing routines. -;;==================================================== - -(defun cust-print-set-function-cell (symbol-pair) - (defalias (car symbol-pair) - (symbol-function (car (cdr symbol-pair))))) - -(defun cust-print-original-princ (object &optional stream)) ; dummy def - -;; Save emacs routines. -(if (not (fboundp 'cust-print-original-prin1)) - (mapc 'cust-print-set-function-cell - '((cust-print-original-prin1 prin1) - (cust-print-original-princ princ) - (cust-print-original-print print) - (cust-print-original-prin1-to-string prin1-to-string) - (cust-print-original-format format) - (cust-print-original-message message) - (cust-print-original-error error)))) - - -(defun custom-print-install () - "Replace print functions with general, customizable, Lisp versions. -The Emacs subroutines are saved away, and you can reinstall them -by running `custom-print-uninstall'." - (interactive) - (mapc 'cust-print-set-function-cell - '((prin1 custom-prin1) - (princ custom-princ) - (print custom-print) - (prin1-to-string custom-prin1-to-string) - (format custom-format) - (message custom-message) - (error custom-error) - )) - t) - -(defun custom-print-uninstall () - "Reset print functions to their Emacs subroutines." - (interactive) - (mapc 'cust-print-set-function-cell - '((prin1 cust-print-original-prin1) - (princ cust-print-original-princ) - (print cust-print-original-print) - (prin1-to-string cust-print-original-prin1-to-string) - (format cust-print-original-format) - (message cust-print-original-message) - (error cust-print-original-error) - )) - t) - -(defalias 'custom-print-funcs-installed-p 'custom-print-installed-p) -(defun custom-print-installed-p () - "Return t if custom-print is currently installed, nil otherwise." - (eq (symbol-function 'custom-prin1) (symbol-function 'prin1))) - -(put 'with-custom-print-funcs 'edebug-form-spec '(body)) -(put 'with-custom-print 'edebug-form-spec '(body)) - -(defalias 'with-custom-print-funcs 'with-custom-print) -(defmacro with-custom-print (&rest body) - "Temporarily install the custom print package while executing BODY." - `(unwind-protect - (progn - (custom-print-install) - ,@body) - (custom-print-uninstall))) - - -;; Lisp replacements for prin1 and princ, and for some subrs that use them -;;=============================================================== -;; - so far only the printing and formatting subrs. - -(defun custom-prin1 (object &optional stream) - "Output the printed representation of OBJECT, any Lisp object. -Quoting characters are printed when needed to make output that `read' -can handle, whenever this is possible. -Output stream is STREAM, or value of `standard-output' (which see). - -This is the custom-print replacement for the standard `prin1'. It -uses the appropriate printer depending on the values of `print-level' -and `print-circle' (which see)." - (cust-print-top-level object stream 'cust-print-original-prin1)) - - -(defun custom-princ (object &optional stream) - "Output the printed representation of OBJECT, any Lisp object. -No quoting characters are used; no delimiters are printed around -the contents of strings. -Output stream is STREAM, or value of `standard-output' (which see). - -This is the custom-print replacement for the standard `princ'." - (cust-print-top-level object stream 'cust-print-original-princ)) - - -(defun custom-prin1-to-string (object &optional noescape) - "Return a string containing the printed representation of OBJECT, -any Lisp object. Quoting characters are used when needed to make output -that `read' can handle, whenever this is possible, unless the optional -second argument NOESCAPE is non-nil. - -This is the custom-print replacement for the standard `prin1-to-string'." - (let ((buf (get-buffer-create " *custom-print-temp*"))) - ;; We must erase the buffer before printing in case an error - ;; occurred during the last prin1-to-string and we are in debugger. - (with-current-buffer buf - (erase-buffer)) - ;; We must be in the current-buffer when the print occurs. - (if noescape - (custom-princ object buf) - (custom-prin1 object buf)) - (with-current-buffer buf - (buffer-string) - ;; We could erase the buffer again, but why bother? - ))) - - -(defun custom-print (object &optional stream) - "Output the printed representation of OBJECT, with newlines around it. -Quoting characters are printed when needed to make output that `read' -can handle, whenever this is possible. -Output stream is STREAM, or value of `standard-output' (which see). - -This is the custom-print replacement for the standard `print'." - (cust-print-original-princ "\n" stream) - (custom-prin1 object stream) - (cust-print-original-princ "\n" stream)) - - -(defun custom-format (fmt &rest args) - "Format a string out of a control-string and arguments. -The first argument is a control string. It, and subsequent arguments -substituted into it, become the value, which is a string. -It may contain %s or %d or %c to substitute successive following arguments. -%s means print an argument as a string, %d means print as number in decimal, -%c means print a number as a single character. -The argument used by %s must be a string or a symbol; -the argument used by %d, %b, %o, %x or %c must be a number. - -This is the custom-print replacement for the standard `format'. It -calls the Emacs `format' after first making strings for list, -vector, or symbol args. The format specification for such args should -be `%s' in any case, so a string argument will also work. The string -is generated with `custom-prin1-to-string', which quotes quotable -characters." - (apply 'cust-print-original-format fmt - (mapcar (function (lambda (arg) - (if (or (listp arg) (vectorp arg) (symbolp arg)) - (custom-prin1-to-string arg) - arg))) - args))) - - -(defun custom-message (fmt &rest args) - "Print a one-line message at the bottom of the screen. -The first argument is a control string. -It may contain %s or %d or %c to print successive following arguments. -%s means print an argument as a string, %d means print as number in decimal, -%c means print a number as a single character. -The argument used by %s must be a string or a symbol; -the argument used by %d or %c must be a number. - -This is the custom-print replacement for the standard `message'. -See `custom-format' for the details." - ;; It doesn't work to princ the result of custom-format as in: - ;; (cust-print-original-princ (apply 'custom-format fmt args)) - ;; because the echo area requires special handling - ;; to avoid duplicating the output. - ;; cust-print-original-message does it right. - (apply 'cust-print-original-message fmt - (mapcar (function (lambda (arg) - (if (or (listp arg) (vectorp arg) (symbolp arg)) - (custom-prin1-to-string arg) - arg))) - args))) - - -(defun custom-error (fmt &rest args) - "Signal an error, making error message by passing all args to `format'. - -This is the custom-print replacement for the standard `error'. -See `custom-format' for the details." - (signal 'error (list (apply 'custom-format fmt args)))) - - - -;; Support for custom prin1 and princ -;;========================================= - -;; Defs to quiet byte-compiler. -(defvar circle-table) -(defvar cust-print-current-level) - -(defun cust-print-original-printer (object)) ; One of the standard printers. -(defun cust-print-low-level-prin (object)) ; Used internally. -(defun cust-print-prin (object)) ; Call this to print recursively. - -(defun cust-print-top-level (object stream emacs-printer) - ;; Set up for printing. - (let ((standard-output (or stream standard-output)) - ;; circle-table will be non-nil if anything is circular. - (circle-table (and print-circle - (cust-print-preprocess-circle-tree object))) - (cust-print-current-level (or print-level -1))) - - (defalias 'cust-print-original-printer emacs-printer) - (defalias 'cust-print-low-level-prin - (cond - ((or custom-printers - circle-table - print-level ; comment out for version 19 - ;; Emacs doesn't use print-level or print-length - ;; for vectors, but custom-print can. - (if custom-print-vectors - (or print-level print-length))) - 'cust-print-print-object) - (t 'cust-print-original-printer))) - (defalias 'cust-print-prin - (if circle-table 'cust-print-print-circular 'cust-print-low-level-prin)) - - (cust-print-prin object) - object)) - - -(defun cust-print-print-object (object) - ;; Test object type and print accordingly. - ;; Could be called as either cust-print-low-level-prin or cust-print-prin. - (cond - ((null object) (cust-print-original-printer object)) - ((cust-print-use-custom-printer object) object) - ((consp object) (cust-print-list object)) - ((vectorp object) (cust-print-vector object)) - ;; All other types, just print. - (t (cust-print-original-printer object)))) - - -(defun cust-print-print-circular (object) - ;; Printer for `prin1' and `princ' that handles circular structures. - ;; If OBJECT appears multiply, and has not yet been printed, - ;; prefix with label; if it has been printed, use `#N#' instead. - ;; Otherwise, print normally. - (let ((tag (assq object circle-table))) - (if tag - (let ((id (cdr tag))) - (if (> id 0) - (progn - ;; Already printed, so just print id. - (cust-print-original-princ "#") - (cust-print-original-princ id) - (cust-print-original-princ "#")) - ;; Not printed yet, so label with id and print object. - (setcdr tag (- id)) ; mark it as printed - (cust-print-original-princ "#") - (cust-print-original-princ (- id)) - (cust-print-original-princ "=") - (cust-print-low-level-prin object) - )) - ;; Not repeated in structure. - (cust-print-low-level-prin object)))) - - -;;================================================ -;; List and vector processing for print functions. - -(defun cust-print-list (list) - ;; Print a list using print-length, print-level, and print-circle. - (if (= cust-print-current-level 0) - (cust-print-original-princ "#") - (let ((cust-print-current-level (1- cust-print-current-level))) - (cust-print-original-princ "(") - (let ((length (or print-length 0))) - - ;; Print the first element always (even if length = 0). - (cust-print-prin (car list)) - (setq list (cdr list)) - (if list (cust-print-original-princ " ")) - (setq length (1- length)) - - ;; Print the rest of the elements. - (while (and list (/= 0 length)) - (if (and (listp list) - (not (assq list circle-table))) - (progn - (cust-print-prin (car list)) - (setq list (cdr list))) - - ;; cdr is not a list, or it is in circle-table. - (cust-print-original-princ ". ") - (cust-print-prin list) - (setq list nil)) - - (setq length (1- length)) - (if list (cust-print-original-princ " "))) - - (if (and list (= length 0)) (cust-print-original-princ "...")) - (cust-print-original-princ ")")))) - list) - - -(defun cust-print-vector (vector) - ;; Print a vector according to print-length, print-level, and print-circle. - (if (= cust-print-current-level 0) - (cust-print-original-princ "#") - (let ((cust-print-current-level (1- cust-print-current-level)) - (i 0) - (len (length vector))) - (cust-print-original-princ "[") - - (if print-length - (setq len (min print-length len))) - ;; Print the elements - (while (< i len) - (cust-print-prin (aref vector i)) - (setq i (1+ i)) - (if (< i (length vector)) (cust-print-original-princ " "))) - - (if (< i (length vector)) (cust-print-original-princ "...")) - (cust-print-original-princ "]") - )) - vector) - - - -;; Circular structure preprocessing -;;================================== - -(defun cust-print-preprocess-circle-tree (object) - ;; Fill up the table. - (let (;; Table of tags for each object in an object to be printed. - ;; A tag is of the form: - ;; ( <object> <nil-t-or-id-number> ) - ;; The id-number is generated after the entire table has been computed. - ;; During walk through, the real circle-table lives in the cdr so we - ;; can use setcdr to add new elements instead of having to setq the - ;; variable sometimes (poor man's locf). - (circle-table (list nil))) - (cust-print-walk-circle-tree object) - - ;; Reverse table so it is in the order that the objects will be printed. - ;; This pass could be avoided if we always added to the end of the - ;; table with setcdr in walk-circle-tree. - (setcdr circle-table (nreverse (cdr circle-table))) - - ;; Walk through the table, assigning id-numbers to those - ;; objects which will be printed using #N= syntax. Delete those - ;; objects which will be printed only once (to speed up assq later). - (let ((rest circle-table) - (id -1)) - (while (cdr rest) - (let ((tag (car (cdr rest)))) - (cond ((cdr tag) - (setcdr tag id) - (setq id (1- id)) - (setq rest (cdr rest))) - ;; Else delete this object. - (t (setcdr rest (cdr (cdr rest)))))) - )) - ;; Drop the car. - (cdr circle-table) - )) - - - -(defun cust-print-walk-circle-tree (object) - (let (read-equivalent-p tag) - (while object - (setq read-equivalent-p - (or (numberp object) - (and (symbolp object) - ;; Check if it is uninterned. - (eq object (intern-soft (symbol-name object))))) - tag (and (not read-equivalent-p) - (assq object (cdr circle-table)))) - (cond (tag - ;; Seen this object already, so note that. - (setcdr tag t)) - - ((not read-equivalent-p) - ;; Add a tag for this object. - (setcdr circle-table - (cons (list object) - (cdr circle-table))))) - (setq object - (cond - (tag ;; No need to descend since we have already. - nil) - - ((consp object) - ;; Walk the car of the list recursively. - (cust-print-walk-circle-tree (car object)) - ;; But walk the cdr with the above while loop - ;; to avoid problems with max-lisp-eval-depth. - ;; And it should be faster than recursion. - (cdr object)) - - ((vectorp object) - ;; Walk the vector. - (let ((i (length object)) - (j 0)) - (while (< j i) - (cust-print-walk-circle-tree (aref object j)) - (setq j (1+ j)))))))))) - - -;; Example. -;;======================================= - -'(progn - (progn - ;; Create some circular structures. - (setq circ-sym (let ((x (make-symbol "FOO"))) (list x x))) - (setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f)) - (setcar (nthcdr 3 circ-list) circ-list) - (aset (nth 2 circ-list) 2 circ-list) - (setq dotted-circ-list (list 'a 'b 'c)) - (setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list) - (setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7)) - (aset circ-vector 5 (make-symbol "-gensym-")) - (setcar (cdr (aref circ-vector 4)) (aref circ-vector 5)) - nil) - - (install-custom-print) - ;; (setq print-circle t) - - (let ((print-circle t)) - (or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)") - (error "circular object with array printing"))) - - (let ((print-circle t)) - (or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)") - (error "circular object with array printing"))) - - (let* ((print-circle t) - (x (list 'p 'q)) - (y (list (list 'a 'b) x 'foo x))) - (setcdr (cdr (cdr (cdr y))) (cdr y)) - (or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))" - ) - (error "circular list example from CL manual"))) - - (let ((print-circle nil)) - ;; cl-packages.el is required to print uninterned symbols like #:FOO. - ;; (require 'cl-packages) - (or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)") - (error "uninterned symbols in list"))) - (let ((print-circle t)) - (or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)") - (error "circular uninterned symbols in list"))) - - (uninstall-custom-print) - ) - -(provide 'cust-print) - -;;; cust-print.el ends here diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 506a737d36d..ba720b42868 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -35,6 +35,8 @@ ;;; Code: +(require 'macroexp) + ;;; The variable byte-code-vector is defined by the new bytecomp.el. ;;; The function byte-decompile-lapcode is defined in byte-opt.el. ;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt. @@ -155,7 +157,7 @@ redefine OBJECT if it is a symbol." (t (insert "Uncompiled body: ") (let ((print-escape-newlines t)) - (prin1 (if (cdr obj) (cons 'progn obj) (car obj)) + (prin1 (macroexp-progn obj) (current-buffer)))))) (if interactive-p (message ""))) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 0d6716a2e63..abb1edca4ee 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -99,7 +99,7 @@ the mode if the argument is `toggle'. If DOC is nil this function adds a basic doc-string stating these facts. Optional INIT-VALUE is the initial value of the mode's variable. -Optional LIGHTER is displayed in the modeline when the mode is on. +Optional LIGHTER is displayed in the mode line when the mode is on. Optional KEYMAP is the default keymap bound to the mode keymap. If non-nil, it should be a variable name (whose value is a keymap), or an expression that returns either a keymap or a list of @@ -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..8c6738ca6a9 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -51,6 +51,8 @@ ;;; Code: +(require 'macroexp) + ;;; Bug reporting (defalias 'edebug-submit-bug-report 'report-emacs-bug) @@ -527,6 +529,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 @@ -1250,10 +1253,7 @@ expressions; a `progn' form will be returned enclosing these forms." ((eq 'edebug-after (car sexp)) (nth 3 sexp)) ((eq 'edebug-enter (car sexp)) - (let ((forms (nthcdr 2 (nth 1 (nth 3 sexp))))) - (if (> (length forms) 1) - (cons 'progn forms) ;; could return (values forms) instead. - (car forms)))) + (macroexp-progn (nthcdr 2 (nth 1 (nth 3 sexp))))) (t sexp);; otherwise it is not wrapped, so just return it. ) sexp)) @@ -1938,7 +1938,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 +2010,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 +3737,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 +4430,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/float-sup.el b/lisp/emacs-lisp/float-sup.el index 375704ab6df..f7d6cdc3b75 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -28,13 +28,9 @@ ;; Provide an easy hook to tell if we are running with floats or not. ;; Define pi and e via math-lib calls (much less prone to killer typos). (defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).") -(progn - ;; Simulate a defconst that doesn't declare the variable dynamically bound. - (setq-default pi float-pi) - (put 'pi 'variable-documentation - "Obsolete since Emacs-23.3. Use `float-pi' instead.") - (put 'pi 'risky-local-variable t) - (push 'pi current-load-list)) +(defconst pi float-pi + "Obsolete since Emacs-23.3. Use `float-pi' instead.") +(internal-make-var-non-special 'pi) (defconst float-e (exp 1) "The value of e (2.7182818...).") 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..8effb3c8e31 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -1,4 +1,4 @@ -;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t -*- +;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t; coding: utf-8 -*- ;; ;; Copyright (C) 2004-2012 Free Software Foundation, Inc. ;; @@ -29,13 +29,11 @@ ;;; Code: -(eval-when-compile (require 'cl)) - ;; Bound by the top-level `macroexpand-all', and modified to include any ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) -(defun maybe-cons (car cdr original-cons) +(defun macroexp--cons (car cdr original-cons) "Return (CAR . CDR), using ORIGINAL-CONS if possible." (if (and (eq car (car original-cons)) (eq cdr (cdr original-cons))) original-cons @@ -43,9 +41,9 @@ ;; We use this special macro to iteratively process forms and share list ;; structure of the result with the input. Doing so recursively using -;; `maybe-cons' results in excessively deep recursion for very long +;; `macroexp--cons' results in excessively deep recursion for very long ;; input forms. -(defmacro macroexp-accumulate (var+list &rest body) +(defmacro macroexp--accumulate (var+list &rest body) "Return a list of the results of evaluating BODY for each element of LIST. Evaluate BODY with VAR bound to each `car' from LIST, in turn. Return a list of the values of the final form in BODY. @@ -65,7 +63,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) @@ -76,27 +74,27 @@ result will be eq to LIST). (setq ,tail (cdr ,tail))) (nconc (nreverse ,unshared) ,shared)))) -(defun macroexpand-all-forms (forms &optional skip) +(defun macroexp--all-forms (forms &optional skip) "Return FORMS with macros expanded. FORMS is a list of forms. If SKIP is non-nil, then don't expand that many elements at the start of FORMS." - (macroexp-accumulate (form forms) + (macroexp--accumulate (form forms) (if (or (null skip) (zerop skip)) - (macroexpand-all-1 form) + (macroexp--expand-all form) (setq skip (1- skip)) form))) -(defun macroexpand-all-clauses (clauses &optional skip) +(defun macroexp--all-clauses (clauses &optional skip) "Return CLAUSES with macros expanded. CLAUSES is a list of lists of forms; any clause that's not a list is ignored. If SKIP is non-nil, then don't expand that many elements at the start of each clause." - (macroexp-accumulate (clause clauses) + (macroexp--accumulate (clause clauses) (if (listp clause) - (macroexpand-all-forms clause skip) + (macroexp--all-forms clause skip) clause))) -(defun macroexpand-all-1 (form) +(defun macroexp--expand-all (form) "Expand all macros in FORM. This is an internal version of `macroexpand-all'. Assumes the caller has bound `macroexpand-all-environment'." @@ -105,7 +103,7 @@ Assumes the caller has bound `macroexpand-all-environment'." ;; generates exceedingly deep expansions from relatively shallow input ;; forms. We just process it `in reverse' -- first we expand all the ;; arguments, _then_ we expand the top-level definition. - (macroexpand (macroexpand-all-forms form 1) + (macroexpand (macroexp--all-forms form 1) macroexpand-all-environment) ;; Normal form; get its expansion, and then expand arguments. (let ((new-form (macroexpand form macroexpand-all-environment))) @@ -118,48 +116,34 @@ Assumes the caller has bound `macroexpand-all-environment'." (setq form new-form)) (pcase form (`(cond . ,clauses) - (maybe-cons 'cond (macroexpand-all-clauses clauses) form)) + (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) (`(condition-case . ,(or `(,err ,body . ,handlers) dontcare)) - (maybe-cons + (macroexp--cons 'condition-case - (maybe-cons err - (maybe-cons (macroexpand-all-1 body) - (macroexpand-all-clauses handlers 1) + (macroexp--cons err + (macroexp--cons (macroexp--expand-all body) + (macroexp--all-clauses handlers 1) (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)) + (`(,(or `defvar `defconst) . ,_) (macroexp--all-forms form 2)) (`(function ,(and f `(lambda . ,_))) - (maybe-cons 'function - (maybe-cons (macroexpand-all-forms f 2) + (macroexp--cons 'function + (macroexp--cons (macroexp--all-forms f 2) nil (cdr form)) form)) (`(,(or `function `quote) . ,_) form) (`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare)) - (maybe-cons fun - (maybe-cons (macroexpand-all-clauses bindings 1) - (macroexpand-all-forms body) + (macroexp--cons fun + (macroexp--cons (macroexp--all-clauses bindings 1) + (macroexp--all-forms body) (cdr form)) form)) (`(,(and fun `(lambda . ,_)) . ,args) ;; Embedded lambda in function position. - (maybe-cons (macroexpand-all-forms fun 2) - (macroexpand-all-forms args) + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) form)) ;; The following few cases are for normal function calls that ;; are known to funcall one of their arguments. The byte @@ -175,41 +159,64 @@ Assumes the caller has bound `macroexpand-all-environment'." (format "%s quoted with ' rather than with #'" (list 'lambda (nth 1 f) '...)) t) - ;; We don't use `maybe-cons' since there's clearly a change. + ;; We don't use `macroexp--cons' since there's clearly a change. (cons fun - (cons (macroexpand-all-1 (list 'function f)) - (macroexpand-all-forms args)))) + (cons (macroexp--expand-all (list 'function f)) + (macroexp--all-forms args)))) ;; Second arg is a function: (`(,(and fun (or `sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args) (byte-compile-log-warning (format "%s quoted with ' rather than with #'" (list 'lambda (nth 1 f) '...)) t) - ;; We don't use `maybe-cons' since there's clearly a change. + ;; We don't use `macroexp--cons' since there's clearly a change. (cons fun - (cons (macroexpand-all-1 arg1) - (cons (macroexpand-all-1 + (cons (macroexp--expand-all arg1) + (cons (macroexp--expand-all (list 'function f)) - (macroexpand-all-forms args))))) - ;; Macro expand compiler macros. This cannot be delayed to - ;; byte-optimize-form because the output of the compiler-macro can - ;; use macros. - ;; FIXME: Don't depend on CL. - (`(,(pred (lambda (fun) - (and (symbolp fun) - (eq (get fun 'byte-compile) - 'cl-byte-compile-compiler-macro) - (functionp 'compiler-macroexpand)))) - . ,_) - (let ((newform (with-no-warnings (compiler-macroexpand form)))) - (if (eq form newform) - (macroexpand-all-forms form 1) - (macroexpand-all-1 newform)))) - (`(,_ . ,_) - ;; For every other list, we just expand each argument (for - ;; setq/setq-default this works alright because the variable names - ;; are symbols). - (macroexpand-all-forms form 1)) + (macroexp--all-forms args))))) + (`(,func . ,_) + ;; Macro expand compiler macros. This cannot be delayed to + ;; byte-optimize-form because the output of the compiler-macro can + ;; use macros. + (let ((handler nil)) + (while (and (symbolp func) + (not (setq handler (get func 'compiler-macro))) + (fboundp func)) + ;; Follow the sequence of aliases. + (setq func (symbol-function func))) + (if (null handler) + ;; No compiler macro. We just expand each argument (for + ;; setq/setq-default this works alright because the variable names + ;; are symbols). + (macroexp--all-forms form 1) + ;; If the handler is not loaded yet, try (auto)loading the + ;; function itself, which may in turn load the handler. + (when (and (not (functionp handler)) + (fboundp func) (eq (car-safe (symbol-function func)) + 'autoload)) + (ignore-errors + (load (nth 1 (symbol-function func)) + 'noerror 'nomsg))) + (let ((newform (condition-case err + (apply handler form (cdr form)) + (error (message "Compiler-macro error: %S" err) + form)))) + (if (eq form newform) + ;; The compiler macro did not find anything to do. + (if (equal form (setq newform (macroexp--all-forms form 1))) + form + ;; Maybe after processing the args, some new opportunities + ;; appeared, so let's try the compiler macro again. + (setq form (condition-case err + (apply handler newform (cdr newform)) + (error (message "Compiler-macro error: %S" err) + newform))) + (if (eq newform form) + newform + (macroexp--expand-all newform))) + (macroexp--expand-all newform)))))) + (t form)))) ;;;###autoload @@ -219,7 +226,89 @@ If no macros are expanded, FORM is returned unchanged. The second optional arg ENVIRONMENT specifies an environment of macro definitions to shadow the loaded ones for use in file byte-compilation." (let ((macroexpand-all-environment environment)) - (macroexpand-all-1 form))) + (macroexp--expand-all form))) + +;;; Handy functions to use in macros. + +(defun macroexp-progn (exps) + "Return an expression equivalent to `(progn ,@EXPS)." + (if (cdr exps) `(progn ,@exps) (car exps))) + +(defun macroexp-unprogn (exp) + "Turn EXP into a list of expressions to execute in sequence." + (if (eq (car-safe exp) 'progn) (cdr exp) (list exp))) + +(defun macroexp-let* (bindings exp) + "Return an expression equivalent to `(let* ,bindings ,exp)." + (cond + ((null bindings) exp) + ((eq 'let* (car-safe exp)) `(let* (,@bindings ,@(cadr exp)) ,@(cddr exp))) + (t `(let* ,bindings ,exp)))) + +(defun macroexp-if (test then else) + "Return an expression equivalent to `(if ,test ,then ,else)." + (cond + ((eq (car-safe else) 'if) + (if (equal test (nth 1 else)) + ;; Doing a test a second time: get rid of the redundancy. + `(if ,test ,then ,@(nthcdr 3 else)) + `(cond (,test ,then) + (,(nth 1 else) ,(nth 2 else)) + (t ,@(nthcdr 3 else))))) + ((eq (car-safe else) 'cond) + `(cond (,test ,then) + ;; Doing a test a second time: get rid of the redundancy, as above. + ,@(remove (assoc test else) (cdr else)))) + ;; Invert the test if that lets us reduce the depth of the tree. + ((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then)) + (t `(if ,test ,then ,else)))) + +(defmacro macroexp-let² (test var exp &rest exps) + "Bind VAR to a copyable expression that returns the value of EXP. +This is like `(let ((v ,EXP)) ,EXPS) except that `v' is a new generated +symbol which EXPS can find in VAR. +TEST should be the name of a predicate on EXP checking whether the `let' can +be skipped; if nil, as is usual, `macroexp-const-p' is used." + (declare (indent 3) (debug (sexp form sexp body))) + (let ((bodysym (make-symbol "body")) + (expsym (make-symbol "exp"))) + `(let* ((,expsym ,exp) + (,var (if (,(or test #'macroexp-const-p) ,expsym) + ,expsym (make-symbol "x"))) + (,bodysym ,(macroexp-progn exps))) + (if (eq ,var ,expsym) ,bodysym + (macroexp-let* (list (list ,var ,expsym)) + ,bodysym))))) + +(defsubst macroexp--const-symbol-p (symbol &optional any-value) + "Non-nil if SYMBOL is constant. +If ANY-VALUE is nil, only return non-nil if the value of the symbol is the +symbol itself." + (or (memq symbol '(nil t)) + (keywordp symbol) + (if any-value + (or (memq symbol byte-compile-const-variables) + ;; FIXME: We should provide a less intrusive way to find out + ;; if a variable is "constant". + (and (boundp symbol) + (condition-case nil + (progn (set symbol (symbol-value symbol)) nil) + (setting-constant t))))))) + +(defun macroexp-const-p (exp) + "Return non-nil if EXP will always evaluate to the same value." + (cond ((consp exp) (or (eq (car exp) 'quote) + (and (eq (car exp) 'function) + (symbolp (cadr exp))))) + ;; It would sometimes make sense to pass `any-value', but it's not + ;; always safe since a "constant" variable may not actually always have + ;; the same value. + ((symbolp exp) (macroexp--const-symbol-p exp)) + (t t))) + +(defun macroexp-copyable-p (exp) + "Return non-nil if EXP can be copied without extra cost." + (or (symbolp exp) (macroexp-const-p exp))) (provide 'macroexp) 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..3c9e82a823e 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -1,4 +1,4 @@ -;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*- +;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*- ;; Copyright (C) 2010-2012 Free Software Foundation, Inc. @@ -39,17 +39,22 @@ ;; - 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. ;;; Code: +(require 'macroexp) + ;; Macro-expansion of pcase is reasonably fast, so it's not a problem ;; when byte-compiling a file, but when interpreting the code, if the pcase ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we @@ -91,7 +96,7 @@ PRED patterns can refer to variables bound earlier in the pattern. E.g. you can match pairs where the cdr is larger than the car with a pattern like `(,a . ,(pred (< a))) or, with more checks: `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" - (declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars. + (declare (indent 1) (debug cl-case)) ;FIXME: edebug `guard' and vars. ;; We want to use a weak hash table as a cache, but the key will unavoidably ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time ;; we're called so it'll be immediately GC'd. So we use (car cases) as key @@ -113,7 +118,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 +138,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 +154,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 +208,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 +227,12 @@ of the form (UPAT EXP)." (cdr case)))) cases)))) (if (null defs) main - `(let ,defs ,main)))) + (macroexp-let* defs main)))) (defun pcase-codegen (code vars) + ;; Don't use let*, otherwise macroexp-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)) @@ -237,23 +250,7 @@ of the form (UPAT EXP)." (cond ((eq else :pcase--dontcare) then) ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen? - ((eq (car-safe else) 'if) - (if (equal test (nth 1 else)) - ;; Doing a test a second time: get rid of the redundancy. - ;; FIXME: ideally, this should never happen because the pcase--split-* - ;; funs should have eliminated such things, but pcase--split-member - ;; is imprecise, so in practice it can happen occasionally. - `(if ,test ,then ,@(nthcdr 3 else)) - `(cond (,test ,then) - (,(nth 1 else) ,(nth 2 else)) - (t ,@(nthcdr 3 else))))) - ((eq (car-safe else) 'cond) - `(cond (,test ,then) - ;; Doing a test a second time: get rid of the redundancy, as above. - ,@(remove (assoc test else) (cdr else)))) - ;; Invert the test if that lets us reduce the depth of the tree. - ((memq (car-safe then) '(if cond)) (pcase--if `(not ,test) else then)) - (t `(if ,test ,then ,else)))) + (t (macroexp-if test then else)))) (defun pcase--upat (qpattern) (cond @@ -433,26 +430,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 +545,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 @@ -570,21 +568,17 @@ Otherwise, it defers to REST which is a list of branches of the form ;; A upat of the form (let VAR EXP). ;; (pcase--u1 matches code ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest) - (let* ((exp - (let* ((exp (nth 2 upat)) - (found (assq exp vars))) - (if found (cdr found) - (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) - (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) - vs))) - (if env `(let* ,env ,exp) exp))))) - (sym (if (symbolp exp) exp (make-symbol "x"))) - (body - (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) - code vars rest))) - (if (eq sym exp) - body - `(let* ((,sym ,exp)) ,body)))) + (macroexp-let² + macroexp-copyable-p sym + (let* ((exp (nth 2 upat)) + (found (assq exp vars))) + (if found (cdr found) + (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) + (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) + vs))) + (if env (macroexp-let* env exp) exp)))) + (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) + code vars rest))) ((eq (car-safe upat) '\`) (put sym 'pcase-used t) (pcase--q1 sym (cadr upat) matches code vars rest)) @@ -606,6 +600,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 +668,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). + (macroexp-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/re-builder.el b/lisp/emacs-lisp/re-builder.el index c8733202f31..05bb7577d22 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -38,7 +38,7 @@ ;; the target buffer are marked automatically with colored overlays ;; (for non-color displays see below) giving you feedback over the ;; extents of the matched (sub) expressions. The (non-)validity is -;; shown only in the modeline without throwing the errors at you. If +;; shown only in the mode line without throwing the errors at you. If ;; you want to know the reason why RE Builder considers it as invalid ;; call `reb-force-update' ("\C-c\C-u") which should reveal the error. 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. |