diff options
| author | Jan D <jan.h.d@swipnet.se> | 2015-04-03 12:32:13 +0200 |
|---|---|---|
| committer | Jan D <jan.h.d@swipnet.se> | 2015-04-03 12:32:13 +0200 |
| commit | 75c8741afba2321add3ad52c5143b4fdb1d63e18 (patch) | |
| tree | 3a125791aba92eb58bee81163a93c3246f275a54 /lisp/emacs-lisp | |
| parent | 734900695acbe17bc7c52c85133918b8949fd2d3 (diff) | |
| parent | 0b914bada39e4577cd9e9209a15c44cc1f83294d (diff) | |
| download | emacs-75c8741afba2321add3ad52c5143b4fdb1d63e18.tar.gz emacs-75c8741afba2321add3ad52c5143b4fdb1d63e18.tar.bz2 emacs-75c8741afba2321add3ad52c5143b4fdb1d63e18.zip | |
Merge branch 'master' into cairo
Diffstat (limited to 'lisp/emacs-lisp')
31 files changed, 3914 insertions, 2256 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 149c4723199..06a11063025 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -302,65 +302,65 @@ ;; doesn't matter here, because function's behavior is underspecified so it ;; can safely be turned into a `let', even though the reverse is not true. (or name (setq name "anonymous lambda")) - (let ((lambda (car form)) - (values (cdr form))) - (let ((arglist (nth 1 lambda)) - (body (cdr (cdr lambda))) - optionalp restp - bindings) - (if (and (stringp (car body)) (cdr body)) - (setq body (cdr body))) - (if (and (consp (car body)) (eq 'interactive (car (car body)))) - (setq body (cdr body))) - ;; FIXME: The checks below do not belong in an optimization phase. - (while arglist - (cond ((eq (car arglist) '&optional) - ;; ok, I'll let this slide because funcall_lambda() does... - ;; (if optionalp (error "multiple &optional keywords in %s" name)) - (if restp (error "&optional found after &rest in %s" name)) - (if (null (cdr arglist)) - (error "nothing after &optional in %s" name)) - (setq optionalp t)) - ((eq (car arglist) '&rest) - ;; ...but it is by no stretch of the imagination a reasonable - ;; thing that funcall_lambda() allows (&rest x y) and - ;; (&rest x &optional y) in arglists. - (if (null (cdr arglist)) - (error "nothing after &rest in %s" name)) - (if (cdr (cdr arglist)) - (error "multiple vars after &rest in %s" name)) - (setq restp t)) - (restp - (setq bindings (cons (list (car arglist) - (and values (cons 'list values))) - bindings) - values nil)) - ((and (not optionalp) (null values)) - (byte-compile-warn "attempt to open-code `%s' with too few arguments" name) - (setq arglist nil values 'too-few)) - (t - (setq bindings (cons (list (car arglist) (car values)) - bindings) - values (cdr values)))) - (setq arglist (cdr arglist))) - (if values - (progn - (or (eq values 'too-few) - (byte-compile-warn - "attempt to open-code `%s' with too many arguments" name)) - form) - - ;; The following leads to infinite recursion when loading a - ;; file containing `(defsubst f () (f))', and then trying to - ;; byte-compile that file. - ;(setq body (mapcar 'byte-optimize-form body))) - - (let ((newform - (if bindings - (cons 'let (cons (nreverse bindings) body)) - (cons 'progn body)))) - (byte-compile-log " %s\t==>\t%s" form newform) - newform))))) + (let* ((lambda (car form)) + (values (cdr form)) + (arglist (nth 1 lambda)) + (body (cdr (cdr lambda))) + optionalp restp + bindings) + (if (and (stringp (car body)) (cdr body)) + (setq body (cdr body))) + (if (and (consp (car body)) (eq 'interactive (car (car body)))) + (setq body (cdr body))) + ;; FIXME: The checks below do not belong in an optimization phase. + (while arglist + (cond ((eq (car arglist) '&optional) + ;; ok, I'll let this slide because funcall_lambda() does... + ;; (if optionalp (error "multiple &optional keywords in %s" name)) + (if restp (error "&optional found after &rest in %s" name)) + (if (null (cdr arglist)) + (error "nothing after &optional in %s" name)) + (setq optionalp t)) + ((eq (car arglist) '&rest) + ;; ...but it is by no stretch of the imagination a reasonable + ;; thing that funcall_lambda() allows (&rest x y) and + ;; (&rest x &optional y) in arglists. + (if (null (cdr arglist)) + (error "nothing after &rest in %s" name)) + (if (cdr (cdr arglist)) + (error "multiple vars after &rest in %s" name)) + (setq restp t)) + (restp + (setq bindings (cons (list (car arglist) + (and values (cons 'list values))) + bindings) + values nil)) + ((and (not optionalp) (null values)) + (byte-compile-warn "attempt to open-code `%s' with too few arguments" name) + (setq arglist nil values 'too-few)) + (t + (setq bindings (cons (list (car arglist) (car values)) + bindings) + values (cdr values)))) + (setq arglist (cdr arglist))) + (if values + (progn + (or (eq values 'too-few) + (byte-compile-warn + "attempt to open-code `%s' with too many arguments" name)) + form) + + ;; The following leads to infinite recursion when loading a + ;; file containing `(defsubst f () (f))', and then trying to + ;; byte-compile that file. + ;(setq body (mapcar 'byte-optimize-form body))) + + (let ((newform + (if bindings + (cons 'let (cons (nreverse bindings) body)) + (cons 'progn body)))) + (byte-compile-log " %s\t==>\t%s" form newform) + newform)))) ;;; implementing source-level optimizers @@ -390,12 +390,13 @@ (and (nth 1 form) (not for-effect) form)) - ((eq 'lambda (car-safe fn)) + ((eq (car-safe fn) 'lambda) (let ((newform (byte-compile-unfold-lambda form))) (if (eq newform form) ;; Some error occurred, avoid infinite recursion form (byte-optimize-form-code-walker newform for-effect)))) + ((eq (car-safe fn) 'closure) form) ((memq fn '(let let*)) ;; recursively enter the optimizer for the bindings and body ;; of a let or let*. This for depth-firstness: forms that diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index caa7e3dad33..081ea3183b9 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -147,11 +147,16 @@ This is used by `declare'.") (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) + #'(lambda (name _args spec) + (list 'progn :autoload-end + (list 'put (list 'quote name) + ''edebug-form-spec (list 'quote spec))))) + (cons + (list 'no-font-lock-keyword + #'(lambda (name _args val) + (list 'function-put (list 'quote name) + ''no-font-lock-keyword (list 'quote val)))) + 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 @@ -201,6 +206,19 @@ The return value is undefined. (message "Warning: Unknown macro property %S in %S" (car x) name)))) decls))) + ;; Refresh font-lock if this is a new macro, or it is an + ;; existing macro whose 'no-font-lock-keyword declaration + ;; has changed. + (if (and + ;; If lisp-mode hasn't been loaded, there's no reason + ;; to flush. + (fboundp 'lisp--el-font-lock-flush-elisp-buffers) + (or (not (fboundp name)) ;; new macro + (and (fboundp name) ;; existing macro + (member `(function-put ',name 'no-font-lock-keyword + ',(get name 'no-font-lock-keyword)) + declarations)))) + (lisp--el-font-lock-flush-elisp-buffers)) (if declarations (cons 'prog1 (cons def declarations)) def)))))) @@ -375,7 +393,7 @@ ACCESS-TYPE if non-nil should specify the kind of access that will trigger This uses `defvaralias' and `make-obsolete-variable' (which see). See the Info node `(elisp)Variable Aliases' for more details. -If CURRENT-NAME is a defcustom (more generally, any variable +If CURRENT-NAME is a defcustom or a defvar (more generally, any variable where OBSOLETE-NAME may be set, e.g. in an init file, before the alias is defined), then the define-obsolete-variable-alias statement should be evaluated before the defcustom, if user @@ -389,7 +407,7 @@ variable (this is due to the way `defvaralias' works). 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." +`saved-value', `saved-variable-comment'." (declare (doc-string 4) (advertised-calling-convention ;; New code should always provide the `when' argument. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 548aaa9626b..e929c02eefb 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1353,13 +1353,13 @@ extra args." (let ((keyword-args (cdr (cdr (cdr (cdr form))))) (name (cadr form))) (or (not (eq (car-safe name) 'quote)) - (and (eq (car form) 'custom-declare-group) - (equal name ''emacs)) - (plist-get keyword-args :group) - (not (and (consp name) (eq (car name) 'quote))) - (byte-compile-warn - "%s for `%s' fails to specify containing group" - (cdr (assq (car form) + (and (eq (car form) 'custom-declare-group) + (equal name ''emacs)) + (plist-get keyword-args :group) + (not (and (consp name) (eq (car name) 'quote))) + (byte-compile-warn + "%s for `%s' fails to specify containing group" + (cdr (assq (car form) '((custom-declare-group . defgroup) (custom-declare-face . defface) (custom-declare-variable . defcustom)))) diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index 13de61c4935..8fc299d7e93 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -125,6 +125,14 @@ With optional argument FULL, sums the number of elements in each element." (autoload 'byte-compile-arglist-signature "bytecomp") +(defgroup check-declare nil + "Check declare-function statements." + :group 'tools) + +(defcustom check-declare-ext-errors nil + "When non-nil, warn about functions not found in :ext." + :type 'boolean) + (defun check-declare-verify (fnfile fnlist) "Check that FNFILE contains function definitions matching FNLIST. Each element of FNLIST has the form (FILE FN ARGLIST FILEONLY), where @@ -226,7 +234,8 @@ method\\|class\\)\\|fset\\)\\>" type) (when type (setq errlist (cons (list (car e) (cadr e) type) errlist)))) (message "%s%s" m - (if (or re (not ext)) + (if (or re (or check-declare-ext-errors + (not ext))) (check-declare-errmsg errlist) (progn (setq errlist nil) @@ -251,12 +260,29 @@ Returned list has elements FNFILE (FILE ...)." "Warn that FILE made a false claim about FN in FNFILE. TYPE is a string giving the nature of the error. Warning is displayed in `check-declare-warning-buffer'." - (display-warning 'check-declare - (format "%s said `%s' was defined in %s: %s" - (file-name-nondirectory file) fn - (file-name-nondirectory fnfile) - type) - nil check-declare-warning-buffer)) + (let ((warning-prefix-function + (lambda (level entry) + (let ((line 0) + (col 0)) + (insert + (with-current-buffer (find-file-noselect file) + (goto-char (point-min)) + (when (re-search-forward + (format "(declare-function[ \t\n]+%s" fn) nil t) + (goto-char (match-beginning 0)) + (setq line (line-number-at-pos)) + (setq col (1+ (current-column)))) + (format "%s:%d:%d:" + (file-name-nondirectory file) + line col)))) + entry)) + (warning-fill-prefix " ")) + (display-warning 'check-declare + (format "%s said `%s' was defined in %s: %s" + (file-name-nondirectory file) fn + (file-name-nondirectory fnfile) + type) + nil check-declare-warning-buffer))) (defun check-declare-files (&rest files) "Check veracity of all `declare-function' statements in FILES. @@ -269,13 +295,20 @@ Return a list of any errors found." (dolist (e (check-declare-sort alist)) (if (setq err (check-declare-verify (car e) (cdr e))) (setq errlist (cons (cons (car e) err) errlist)))) + (setq errlist (nreverse errlist)) (if (get-buffer check-declare-warning-buffer) (kill-buffer check-declare-warning-buffer)) + (with-current-buffer (get-buffer-create check-declare-warning-buffer) + (unless (derived-mode-p 'compilation-mode) + (compilation-mode)) + (let ((inhibit-read-only t)) + (insert "\f\n")) + (compilation-forget-errors)) ;; Sort back again so that errors are ordered by the files ;; containing the declare-function statements. (dolist (e (check-declare-sort errlist)) - (dolist (f (cdr e)) - (check-declare-warn (car e) (cadr f) (car f) (nth 2 f)))) + (dolist (f (cdr e)) + (check-declare-warn (car e) (cadr f) (car f) (nth 2 f)))) errlist)) ;;;###autoload diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 47b6e5f81de..777fed082d9 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1663,14 +1663,15 @@ function,command,variable,option or symbol." ms1)))))) ;; Addendum: Make sure they appear in the doc in the same ;; order that they are found in the arg list. - (let ((args (cdr (cdr (cdr (cdr fp))))) + (let ((args (nthcdr 4 fp)) (last-pos 0) (found 1) (order (and (nth 3 fp) (car (nth 3 fp)))) (nocheck (append '("&optional" "&rest") (nth 3 fp))) (inopts nil)) (while (and args found (> found last-pos)) - (if (member (car args) nocheck) + (if (or (member (car args) nocheck) + (string-match "\\`_" (car args))) (setq args (cdr args) inopts t) (setq last-pos found @@ -2619,14 +2620,15 @@ function called to create the messages." (defun checkdoc-show-diagnostics () "Display the checkdoc diagnostic buffer in a temporary window." (if checkdoc-pending-errors - (let ((b (get-buffer checkdoc-diagnostic-buffer))) - (if b (progn (pop-to-buffer b) - (goto-char (point-max)) - (re-search-backward "\C-l" nil t) - (beginning-of-line) - (forward-line 1) - (recenter 0))) - (other-window -1) + (let* ((b (get-buffer checkdoc-diagnostic-buffer)) + (win (if b (display-buffer b)))) + (when win + (with-selected-window win + (goto-char (point-max)) + (re-search-backward "\C-l" nil t) + (beginning-of-line) + (forward-line 1) + (recenter 0))) (setq checkdoc-pending-errors nil) nil))) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index c4232863cfc..fb11a3e25a1 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -3,6 +3,7 @@ ;; Copyright (C) 2015 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Version: 1.0 ;; This file is part of GNU Emacs. @@ -31,37 +32,51 @@ ;; from a significant problem: the method-combination code returns a sexp ;; that needs to be `eval'uated or compiled. IOW it requires run-time ;; code generation. Given how rarely method-combinations are used, -;; I just provided a cl-generic-method-combination-function, which -;; people can use if they are really desperate for such functionality. +;; I just provided a cl-generic-combine-methods generic function, to which +;; people can add methods if they are really desperate for such functionality. ;; - In defgeneric we don't support the options: -;; declare, :method-combination, :generic-function-class, :method-class, -;; :method. +;; declare, :method-combination, :generic-function-class, :method-class. ;; Added elements: ;; - We support aliases to generic functions. -;; - The kind of thing on which to dispatch can be extended. -;; There is support in this file for dispatch on: +;; - cl-generic-generalizers. This generic function lets you extend the kind +;; of thing on which to dispatch. There is support in this file for +;; dispatch on: ;; - (eql <val>) +;; - (head <val>) which checks that the arg is a cons with <val> as its head. ;; - plain old types ;; - type of CL structs ;; eieio-core adds dispatch on: ;; - class of eieio objects ;; - actual class argument, using the syntax (subclass <class>). -;; - cl-generic-method-combination-function (i.s.o define-method-combination). +;; - cl-generic-combine-methods (i.s.o define-method-combination and +;; compute-effective-method). ;; - cl-generic-call-method (which replaces make-method and call-method). +;; - The standard method combination supports ":extra STRING" qualifiers +;; which simply allows adding more methods for the same +;; specializers&qualifiers. ;; Efficiency considerations: overall, I've made an effort to make this fairly ;; efficient for the expected case (e.g. no constant redefinition of methods). ;; - Generic functions which do not dispatch on any argument are implemented ;; optimally (just as efficient as plain old functions). ;; - Generic functions which only dispatch on one argument are fairly efficient -;; (not a lot of room for improvement, I think). +;; (not a lot of room for improvement without changes to the byte-compiler, +;; I think). ;; - Multiple dispatch is implemented rather naively. There's an extra `apply' ;; function call for every dispatch; we don't optimize each dispatch ;; based on the set of candidate methods remaining; we don't optimize the -;; order in which we performs the dispatches either; If/when this -;; becomes a problem, we can try and optimize it. +;; order in which we performs the dispatches either; +;; If/when this becomes a problem, we can try and optimize it. ;; - call-next-method could be made more efficient, but isn't too terrible. +;; TODO: +;; +;; - A generic "filter" generalizer (e.g. could be used to cleanly adds methods +;; to cl-generic-combine-methods with a specializer that says it applies only +;; when some particular qualifier is used). +;; - A way to dispatch on the context (e.g. the major-mode, some global +;; variable, you name it). + ;;; Code: ;; Note: For generic functions that dispatch on several arguments (i.e. those @@ -70,40 +85,24 @@ ;; often suboptimal since after one dispatch, the remaining dispatches can ;; usually be simplified, or even completely skipped. -;; TODO/FIXME: -;; - WIBNI we could use something like -;; (add-function :before (cl-method-function (cl-find-method ...)) ...) - (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'pcase)) -(defvar cl-generic-tagcode-function - (lambda (type _name) - (if (eq type t) '(0 . 'cl--generic-type) - (error "Unknown specializer %S" type))) - "Function to get the Elisp code to extract the tag on which we dispatch. -Takes a \"parameter-specializer-name\" and a variable name, and returns -a pair (PRIORITY . CODE) where CODE is an Elisp expression that should be -used to extract the \"tag\" (from the object held in the named variable) -that should uniquely determine if we have a match -\(i.e. the \"tag\" is the value that will be used to dispatch to the proper -method(s)). -Such \"tagcodes\" will be or'd together. -PRIORITY is an integer from 0 to 100 which is used to sort the tagcodes -in the `or'. The higher the priority, the more specific the tag should be. -More specifically, if PRIORITY is N and we have two objects X and Y -whose tag (according to TAGCODE) is `eql', then it should be the case -that for all other (PRIORITY . TAGCODE) where PRIORITY ≤ N, then -\(eval TAGCODE) for X is `eql' to (eval TAGCODE) for Y.") - -(defvar cl-generic-tag-types-function - (lambda (tag) (if (eq tag 'cl--generic-type) '(t))) - "Function to get the list of types that a given \"tag\" matches. -They should be sorted from most specific to least specific.") +(cl-defstruct (cl--generic-generalizer + (:constructor nil) + (:constructor cl-generic-make-generalizer + (priority tagcode-function specializers-function))) + (priority nil :type integer) + tagcode-function + specializers-function) + +(defconst cl--generic-t-generalizer + (cl-generic-make-generalizer + 0 (lambda (_name) nil) (lambda (_tag) '(t)))) (cl-defstruct (cl--generic-method (:constructor nil) - (:constructor cl--generic-method-make + (:constructor cl--generic-make-method (specializers qualifiers uses-cnm function)) (:predicate nil)) (specializers nil :read-only t :type list) @@ -115,8 +114,7 @@ They should be sorted from most specific to least specific.") (cl-defstruct (cl--generic (:constructor nil) - (:constructor cl--generic-make - (name &optional dispatches method-table)) + (:constructor cl--generic-make (name)) (:predicate nil)) (name nil :type symbol :read-only t) ;Pointer back to the symbol. ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index @@ -125,8 +123,13 @@ They should be sorted from most specific to least specific.") ;; on which to dispatch and PRIORITY is the priority of each expression to ;; decide in which order to sort them. ;; The most important dispatch is last in the list (and the least is first). - (dispatches nil :type (list-of (cons natnum (list-of tagcode)))) - (method-table nil :type (list-of cl--generic-method))) + (dispatches nil :type (list-of (cons natnum (list-of generalizers)))) + (method-table nil :type (list-of cl--generic-method)) + (options nil :type list)) + +(defun cl-generic-function-options (generic) + "Return the options of the generic function GENERIC." + (cl--generic-options generic)) (defmacro cl--generic (name) `(get ,name 'cl--generic)) @@ -170,20 +173,34 @@ is appropriate to use. Specific methods are defined with `cl-defmethod'. With this implementation the ARGS are currently ignored. OPTIONS-AND-METHODS currently understands: - (:documentation DOCSTRING) -- (declare DECLARATIONS)" +- (declare DECLARATIONS) +- (:argument-precedence-order &rest ARGS) +- (:method [QUALIFIERS...] ARGS &rest BODY) +BODY, if present, is used as the body of a default method. + +\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest BODY)" (declare (indent 2) (doc-string 3)) - (let* ((docprop (assq :documentation options-and-methods)) - (doc (cond ((stringp (car-safe options-and-methods)) - (pop options-and-methods)) - (docprop - (prog1 - (cadr docprop) - (setq options-and-methods - (delq docprop options-and-methods)))))) - (declarations (assq 'declare options-and-methods))) - (when declarations - (setq options-and-methods - (delq declarations options-and-methods))) + (let* ((doc (if (stringp (car-safe options-and-methods)) + (pop options-and-methods))) + (declarations nil) + (methods ()) + (options ()) + next-head) + (while (progn (setq next-head (car-safe (car options-and-methods))) + (or (keywordp next-head) + (eq next-head 'declare))) + (pcase next-head + (`:documentation + (when doc (error "Multiple doc strings for %S" name)) + (setq doc (cadr (pop options-and-methods)))) + (`declare + (when declarations (error "Multiple `declare' for %S" name)) + (setq declarations (pop options-and-methods))) + (`:method (push (cdr (pop options-and-methods)) methods)) + (_ (push (pop options-and-methods) options)))) + (when options-and-methods + ;; Anything remaining is assumed to be a default method body. + (push `(,args ,@options-and-methods) methods)) `(progn ,(when (eq 'setf (car-safe name)) (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite @@ -200,8 +217,10 @@ OPTIONS-AND-METHODS currently understands: nil)))) (cdr declarations)) (defalias ',name - (cl-generic-define ',name ',args ',options-and-methods) - ,(help-add-fundoc-usage doc args))))) + (cl-generic-define ',name ',args ',(nreverse options)) + ,(help-add-fundoc-usage doc args)) + ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) + (nreverse methods))))) (defun cl--generic-mandatory-args (args) (let ((res ())) @@ -210,10 +229,10 @@ OPTIONS-AND-METHODS currently understands: (nreverse res))) ;;;###autoload -(defun cl-generic-define (name args options-and-methods) +(defun cl-generic-define (name args options) (let ((generic (cl-generic-ensure-function name)) (mandatory (cl--generic-mandatory-args args)) - (apo (assq :argument-precedence-order options-and-methods))) + (apo (assq :argument-precedence-order options))) (setf (cl--generic-dispatches generic) nil) (when apo (dolist (arg (cdr apo)) @@ -222,6 +241,7 @@ OPTIONS-AND-METHODS currently understands: (push (list (- (length mandatory) (length pos))) (cl--generic-dispatches generic))))) (setf (cl--generic-method-table generic) nil) + (setf (cl--generic-options generic) options) (cl--generic-make-function generic))) (defmacro cl-generic-current-method-specializers () @@ -278,7 +298,7 @@ This macro can only be used within the lexical scope of a cl-generic method." (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody))) (cons (not (not uses-cnm)) `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) - ,@(delq nil (car parsed-body)) + ,@(car parsed-body) ,(if (not (memq nmp uses-cnm)) nbody `(let ((,nmp (lambda () @@ -341,7 +361,7 @@ which case this method will be invoked when the argument is `eql' to VAL. ;; But in practice, it's common to use `cl-defmethod' ;; without a previous `cl-defgeneric'. (declare-function ,name "") - (cl-generic-define-method ',name ',qualifiers ',args + (cl-generic-define-method ',name ',(nreverse qualifiers) ',args ,uses-cnm ,fun))))) (defun cl--generic-member-method (specializers qualifiers methods) @@ -359,28 +379,33 @@ which case this method will be invoked when the argument is `eql' to VAL. (mandatory (cl--generic-mandatory-args args)) (specializers (mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory)) - (method (cl--generic-method-make + (method (cl--generic-make-method specializers qualifiers uses-cnm function)) (mt (cl--generic-method-table generic)) (me (cl--generic-member-method specializers qualifiers mt)) (dispatches (cl--generic-dispatches generic)) (i 0)) (dolist (specializer specializers) - (let* ((tagcode (funcall cl-generic-tagcode-function specializer 'arg)) + (let* ((generalizers (cl-generic-generalizers specializer)) (x (assq i dispatches))) (unless x - (setq x (list i (funcall cl-generic-tagcode-function t 'arg))) + (setq x (cons i (cl-generic-generalizers t))) (setf (cl--generic-dispatches generic) (setq dispatches (cons x dispatches)))) - (unless (member tagcode (cdr x)) - (setf (cdr x) - (nreverse (sort (cons tagcode (cdr x)) - #'car-less-than-car)))) + (dolist (generalizer generalizers) + (unless (member generalizer (cdr x)) + (setf (cdr x) + (sort (cons generalizer (cdr x)) + (lambda (x y) + (> (cl--generic-generalizer-priority x) + (cl--generic-generalizer-priority y))))))) (setq i (1+ i)))) (if me (setcar me method) (setf (cl--generic-method-table generic) (cons method mt))) (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) current-load-list :test #'equal) + ;; FIXME: Try to avoid re-constructing a new function if the old one + ;; is still valid (e.g. still empty method cache)? (let ((gfun (cl--generic-make-function generic)) ;; Prevent `defalias' from recording this as the definition site of ;; the generic function. @@ -399,62 +424,73 @@ which case this method will be invoked when the argument is `eql' to VAL. (defvar cl--generic-dispatchers (make-hash-table :test #'equal)) -(defun cl--generic-get-dispatcher (tagcodes dispatch-arg) +(defun cl--generic-get-dispatcher (dispatch) (cl--generic-with-memoization - (gethash (cons dispatch-arg tagcodes) cl--generic-dispatchers) - (let ((lexical-binding t) - (tag-exp `(or ,@(mapcar #'cdr - ;; Minor optimization: since this tag-exp is - ;; only used to lookup the method-cache, it - ;; doesn't matter if the default value is some - ;; constant or nil. - (if (macroexp-const-p (car (last tagcodes))) - (butlast tagcodes) - tagcodes)))) - (extraargs ())) + (gethash dispatch cl--generic-dispatchers) + (let* ((dispatch-arg (car dispatch)) + (generalizers (cdr dispatch)) + (lexical-binding t) + (tagcodes + (mapcar (lambda (generalizer) + (funcall (cl--generic-generalizer-tagcode-function + generalizer) + 'arg)) + generalizers)) + (typescodes + (mapcar (lambda (generalizer) + `(funcall ',(cl--generic-generalizer-specializers-function + generalizer) + ,(funcall (cl--generic-generalizer-tagcode-function + generalizer) + 'arg))) + generalizers)) + (tag-exp + ;; Minor optimization: since this tag-exp is + ;; only used to lookup the method-cache, it + ;; doesn't matter if the default value is some + ;; constant or nil. + `(or ,@(if (macroexp-const-p (car (last tagcodes))) + (butlast tagcodes) + tagcodes))) + (extraargs ())) (dotimes (_ dispatch-arg) (push (make-symbol "arg") extraargs)) + ;; FIXME: For generic functions with a single method (or with 2 methods, + ;; one of which always matches), using a tagcode + hash-table is + ;; overkill: better just use a `cl-typep' test. (byte-compile - `(lambda (generic dispatches-left) + `(lambda (generic dispatches-left methods) (let ((method-cache (make-hash-table :test #'eql))) (lambda (,@extraargs arg &rest args) (apply (cl--generic-with-memoization (gethash ,tag-exp method-cache) (cl--generic-cache-miss - generic ',dispatch-arg dispatches-left - (list ,@(mapcar #'cdr tagcodes)))) + generic ',dispatch-arg dispatches-left methods + ,(if (cdr typescodes) + `(append ,@typescodes) (car typescodes)))) ,@extraargs arg args)))))))) (defun cl--generic-make-function (generic) - (let* ((dispatches (cl--generic-dispatches generic)) - (dispatch + (cl--generic-make-next-function generic + (cl--generic-dispatches generic) + (cl--generic-method-table generic))) + +(defun cl--generic-make-next-function (generic dispatches methods) + (let* ((dispatch (progn (while (and dispatches - (member (cdar dispatches) - '(nil ((0 . 'cl--generic-type))))) + (let ((x (nth 1 (car dispatches)))) + ;; No need to dispatch for `t' specializers. + (or (null x) (equal x cl--generic-t-generalizer)))) (setq dispatches (cdr dispatches))) (pop dispatches)))) - (if (null dispatch) - (cl--generic-build-combined-method - (cl--generic-name generic) - (cl--generic-method-table generic)) - (let ((dispatcher (cl--generic-get-dispatcher - (cdr dispatch) (car dispatch)))) - (funcall dispatcher generic dispatches))))) - -(defvar cl-generic-method-combination-function - #'cl--generic-standard-method-combination - "Function to build the effective method. -Called with 2 arguments: NAME and METHOD-ALIST. -It should return an effective method, i.e. a function that expects the same -arguments as the methods, and calls those methods in some appropriate order. -NAME is the name (a symbol) of the corresponding generic function. -METHOD-ALIST is a list of elements (QUALIFIERS . METHODS) where -QUALIFIERS is a list of qualifiers, and METHODS is a list of the selected -methods for that qualifier list. -The METHODS lists are sorted from most generic first to most specific last. -The function can use `cl-generic-call-method' to create functions that call those -methods.") + (if (not (and dispatch + ;; If there's no method left, there's no point checking + ;; further arguments. + methods)) + (cl--generic-build-combined-method generic methods) + (let ((dispatcher (cl--generic-get-dispatcher dispatch))) + (funcall dispatcher generic dispatches methods))))) (defvar cl--generic-combined-method-memoization (make-hash-table :test #'equal :weakness 'value) @@ -463,27 +499,37 @@ This is particularly useful when many different tags select the same set of methods, since this table then allows us to share a single combined-method for all those different tags in the method-cache.") -(defun cl--generic-build-combined-method (generic-name methods) - (cl--generic-with-memoization - (gethash (cons generic-name methods) - cl--generic-combined-method-memoization) - (let ((mets-by-qual ())) - (dolist (method methods) - (let* ((qualifiers (cl--generic-method-qualifiers method)) - (x (assoc qualifiers mets-by-qual))) - ;; FIXME: sadly, alist-get only uses `assq' and we need `assoc'. - ;;(push (cdr qm) (alist-get qualifiers mets-by-qual))) - (if x - (push method (cdr x)) - (push (list qualifiers method) mets-by-qual)))) - (funcall cl-generic-method-combination-function - generic-name mets-by-qual)))) +(define-error 'cl--generic-cyclic-definition "Cyclic definition: %S") + +(defun cl--generic-build-combined-method (generic methods) + (if (null methods) + ;; Special case needed to fix a circularity during bootstrap. + (cl--generic-standard-method-combination generic methods) + (let ((f + (cl--generic-with-memoization + ;; FIXME: Since the fields of `generic' are modified, this + ;; hash-table won't work right, because the hashes will change! + ;; It's not terribly serious, but reduces the effectiveness of + ;; the table. + (gethash (cons generic methods) + cl--generic-combined-method-memoization) + (puthash (cons generic methods) :cl--generic--under-construction + cl--generic-combined-method-memoization) + (condition-case nil + (cl-generic-combine-methods generic methods) + ;; Special case needed to fix a circularity during bootstrap. + (cl--generic-cyclic-definition + (cl--generic-standard-method-combination generic methods)))))) + (if (eq f :cl--generic--under-construction) + (signal 'cl--generic-cyclic-definition + (list (cl--generic-name generic))) + f)))) (defun cl--generic-no-next-method-function (generic method) (lambda (&rest args) (apply #'cl-no-next-method generic method args))) -(defun cl-generic-call-method (generic-name method &optional fun) +(defun cl-generic-call-method (generic method &optional fun) "Return a function that calls METHOD. FUN is the function that should be called when METHOD calls `call-next-method'." @@ -491,7 +537,7 @@ FUN is the function that should be called when METHOD calls (cl--generic-method-function method) (let ((met-fun (cl--generic-method-function method)) (next (or fun (cl--generic-no-next-method-function - generic-name method)))) + generic method)))) (lambda (&rest args) (apply met-fun ;; FIXME: This sucks: passing just `next' would @@ -503,42 +549,122 @@ FUN is the function that should be called when METHOD calls (apply next (or cnm-args args))) args))))) -(defun cl--generic-standard-method-combination (generic-name mets-by-qual) - (dolist (x mets-by-qual) - (unless (member (car x) '(() (:after) (:before) (:around))) - (error "Unsupported qualifiers in function %S: %S" generic-name (car x)))) - (cond - ((null mets-by-qual) - (lambda (&rest args) - (apply #'cl-no-applicable-method generic-name args))) - ((null (alist-get nil mets-by-qual)) - (lambda (&rest args) - (apply #'cl-no-primary-method generic-name args))) - (t - (let* ((fun nil) - (ab-call (lambda (m) (cl-generic-call-method generic-name m))) - (before - (mapcar ab-call (reverse (cdr (assoc '(:before) mets-by-qual))))) - (after (mapcar ab-call (cdr (assoc '(:after) mets-by-qual))))) - (dolist (method (cdr (assoc nil mets-by-qual))) - (setq fun (cl-generic-call-method generic-name method fun))) - (when (or after before) - (let ((next fun)) - (setq fun (lambda (&rest args) - (dolist (bf before) - (apply bf args)) - (prog1 - (apply next args) - (dolist (af after) - (apply af args))))))) - (dolist (method (cdr (assoc '(:around) mets-by-qual))) - (setq fun (cl-generic-call-method generic-name method fun))) - fun)))) +;; Standard CLOS name. +(defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers) + +(defun cl--generic-standard-method-combination (generic methods) + (let ((mets-by-qual ())) + (dolist (method methods) + (let ((qualifiers (cl-method-qualifiers method))) + (if (eq (car qualifiers) :extra) (setq qualifiers (cddr qualifiers))) + (unless (member qualifiers '(() (:after) (:before) (:around))) + (error "Unsupported qualifiers in function %S: %S" + (cl--generic-name generic) qualifiers)) + (push method (alist-get (car qualifiers) mets-by-qual)))) + (cond + ((null mets-by-qual) + (lambda (&rest args) + (apply #'cl-no-applicable-method generic args))) + ((null (alist-get nil mets-by-qual)) + (lambda (&rest args) + (apply #'cl-no-primary-method generic args))) + (t + (let* ((fun nil) + (ab-call (lambda (m) (cl-generic-call-method generic m))) + (before + (mapcar ab-call (reverse (cdr (assoc :before mets-by-qual))))) + (after (mapcar ab-call (cdr (assoc :after mets-by-qual))))) + (dolist (method (cdr (assoc nil mets-by-qual))) + (setq fun (cl-generic-call-method generic method fun))) + (when (or after before) + (let ((next fun)) + (setq fun (lambda (&rest args) + (dolist (bf before) + (apply bf args)) + (prog1 + (apply next args) + (dolist (af after) + (apply af args))))))) + (dolist (method (cdr (assoc :around mets-by-qual))) + (setq fun (cl-generic-call-method generic method fun))) + fun))))) + +(defun cl--generic-cache-miss (generic + dispatch-arg dispatches-left methods-left types) + (let ((methods '())) + (dolist (method methods-left) + (let* ((specializer (or (nth dispatch-arg + (cl--generic-method-specializers method)) + t)) + (m (member specializer types))) + (when m + (push (cons (length m) method) methods)))) + ;; Sort the methods, most specific first. + ;; It would be tempting to sort them once and for all in the method-table + ;; rather than here, but the order might depend on the actual argument + ;; (e.g. for multiple inheritance with defclass). + (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car)))) + (cl--generic-make-next-function generic dispatches-left methods))) + +(cl-defgeneric cl-generic-generalizers (specializer) + "Return a list of generalizers for a given SPECIALIZER. +To each kind of `specializer', corresponds a `generalizer' which describes +how to extract a \"tag\" from an object which will then let us check if this +object matches the specializer. A typical example of a \"tag\" would be the +type of an object. It's called a `generalizer' because it +takes a specific object and returns a more general approximation, +denoting a set of objects to which it belongs. +A generalizer gives us the chunk of code which the +dispatch function needs to use to extract the \"tag\" of an object, as well +as a function which turns this tag into an ordered list of +`specializers' that this object matches. +The code which extracts the tag should be as fast as possible. +The tags should be chosen according to the following rules: +- The tags should not be too specific: similar objects which match the + same list of specializers should ideally use the same (`eql') tag. + This insures that the cached computation of the applicable + methods for one object can be reused for other objects. +- Corollary: objects which don't match any of the relevant specializers + should ideally all use the same tag (typically nil). + This insures that this cache does not grow unnecessarily large. +- Two different generalizers G1 and G2 should not use the same tag + unless they use it for the same set of objects. IOW, if G1.tag(X1) = + G2.tag(X2) then G1.tag(X1) = G2.tag(X1) = G1.tag(X2) = G2.tag(X2). +- If G1.priority > G2.priority and G1.tag(X1) = G1.tag(X2) and this tag is + non-nil, then you have to make sure that the G2.tag(X1) = G2.tag(X2). + This is because the method-cache is only indexed with the first non-nil + tag (by order of decreasing priority).") + + +(cl-defgeneric cl-generic-combine-methods (generic methods) + "Build the effective method made of METHODS. +It should return a function that expects the same arguments as the methods, and + calls those methods in some appropriate order. +GENERIC is the generic function (mostly used for its name). +METHODS is the list of the selected methods. +The METHODS list is sorted from most specific first to most generic last. +The function can use `cl-generic-call-method' to create functions that call those +methods.") + +;; Temporary definition to let the next defmethod succeed. +(fset 'cl-generic-generalizers + (lambda (_specializer) (list cl--generic-t-generalizer))) +(fset 'cl-generic-combine-methods + #'cl--generic-standard-method-combination) + +(cl-defmethod cl-generic-generalizers (specializer) + "Support for the catch-all `t' specializer." + (if (eq specializer t) (list cl--generic-t-generalizer) + (error "Unknown specializer %S" specializer))) + +(cl-defmethod cl-generic-combine-methods (generic methods) + "Standard support for :after, :before, :around, and `:extra NAME' qualifiers." + (cl--generic-standard-method-combination generic methods)) (defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t)) (defconst cl--generic-cnm-sample (funcall (cl--generic-build-combined-method - nil (list (cl--generic-method-make () () t #'identity))))) + nil (list (cl--generic-make-method () () t #'identity))))) (defun cl--generic-isnot-nnm-p (cnm) "Return non-nil if CNM is the function that calls `cl-no-next-method'." @@ -566,24 +692,6 @@ FUN is the function that should be called when METHOD calls (setq cnm-env (cdr cnm-env))))) (error "Haven't found no-next-method-sample in cnm-sample"))) -(defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags) - (let ((types (apply #'append (mapcar cl-generic-tag-types-function tags))) - (methods '())) - (dolist (method (cl--generic-method-table generic)) - (let* ((specializer (or (nth dispatch-arg - (cl--generic-method-specializers method)) - t)) - (m (member specializer types))) - (when m - (push (cons (length m) method) methods)))) - ;; Sort the methods, most specific first. - ;; It would be tempting to sort them once and for all in the method-table - ;; rather than here, but the order might depend on the actual argument - ;; (e.g. for multiple inheritance with defclass). - (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car)))) - (cl--generic-make-function (cl--generic-make (cl--generic-name generic) - dispatches-left methods)))) - ;;; Define some pre-defined generic functions, used internally. (define-error 'cl-no-method "No method for %S") @@ -593,19 +701,16 @@ FUN is the function that should be called when METHOD calls 'cl-no-method) (cl-defgeneric cl-no-next-method (generic method &rest args) - "Function called when `cl-call-next-method' finds no next method.") -(cl-defmethod cl-no-next-method (generic method &rest args) - (signal 'cl-no-next-method `(,generic ,method ,@args))) + "Function called when `cl-call-next-method' finds no next method." + (signal 'cl-no-next-method `(,(cl--generic-name generic) ,method ,@args))) (cl-defgeneric cl-no-applicable-method (generic &rest args) - "Function called when a method call finds no applicable method.") -(cl-defmethod cl-no-applicable-method (generic &rest args) - (signal 'cl-no-applicable-method `(,generic ,@args))) + "Function called when a method call finds no applicable method." + (signal 'cl-no-applicable-method `(,(cl--generic-name generic) ,@args))) (cl-defgeneric cl-no-primary-method (generic &rest args) - "Function called when a method call finds no primary method.") -(cl-defmethod cl-no-primary-method (generic &rest args) - (signal 'cl-no-primary-method `(,generic ,@args))) + "Function called when a method call finds no primary method." + (signal 'cl-no-primary-method `(,(cl--generic-name generic) ,@args))) (defun cl-call-next-method (&rest _args) "Function to call the next applicable method. @@ -700,69 +805,110 @@ Can only be used from within the lexical body of a primary or around method." (insert "'.\n"))) (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) +;;; Support for (head <val>) specializers. + +;; For both the `eql' and the `head' specializers, the dispatch +;; is unsatisfactory. Basically, in the "common&fast case", we end up doing +;; +;; (let ((tag (gethash value <tagcode-hashtable>))) +;; (funcall (gethash tag <method-cache>))) +;; +;; whereas we'd like to just do +;; +;; (funcall (gethash value <method-cache>))) +;; +;; but the problem is that the method-cache is normally "open ended", so +;; a nil means "not computed yet" and if we bump into it, we dutifully fill the +;; corresponding entry, whereas we'd want to just fallback on some default +;; effective method (so as not to fill the cache with lots of redundant +;; entries). + +(defvar cl--generic-head-used (make-hash-table :test #'eql)) + +(defconst cl--generic-head-generalizer + (cl-generic-make-generalizer + 80 (lambda (name) `(gethash (car-safe ,name) cl--generic-head-used)) + (lambda (tag) (if (eq (car-safe tag) 'head) (list tag))))) + +(cl-defmethod cl-generic-generalizers :extra "head" (specializer) + "Support for the `(head VAL)' specializers." + ;; We have to implement `head' here using the :extra qualifier, + ;; since we can't use the `head' specializer to implement itself. + (if (not (eq (car-safe specializer) 'head)) + (cl-call-next-method) + (cl--generic-with-memoization + (gethash (cadr specializer) cl--generic-head-used) specializer) + (list cl--generic-head-generalizer))) + ;;; Support for (eql <val>) specializers. (defvar cl--generic-eql-used (make-hash-table :test #'eql)) -(add-function :before-until cl-generic-tagcode-function - #'cl--generic-eql-tagcode) -(defun cl--generic-eql-tagcode (type name) - (when (eq (car-safe type) 'eql) - (puthash (cadr type) type cl--generic-eql-used) - `(100 . (gethash ,name cl--generic-eql-used)))) +(defconst cl--generic-eql-generalizer + (cl-generic-make-generalizer + 100 (lambda (name) `(gethash ,name cl--generic-eql-used)) + (lambda (tag) (if (eq (car-safe tag) 'eql) (list tag))))) -(add-function :before-until cl-generic-tag-types-function - #'cl--generic-eql-tag-types) -(defun cl--generic-eql-tag-types (tag) - (if (eq (car-safe tag) 'eql) (list tag))) +(cl-defmethod cl-generic-generalizers ((specializer (head eql))) + "Support for the `(eql VAL)' specializers." + (puthash (cadr specializer) specializer cl--generic-eql-used) + (list cl--generic-eql-generalizer)) ;;; Support for cl-defstructs specializers. -(add-function :before-until cl-generic-tagcode-function - #'cl--generic-struct-tagcode) - (defun cl--generic-struct-tag (name) + ;; It's tempting to use (and (vectorp ,name) (aref ,name 0)) + ;; but that would suffer from some problems: + ;; - the vector may have size 0. + ;; - when called on an actual vector (rather than an object), we'd + ;; end up returning an arbitrary value, possibly colliding with + ;; other tagcode's values. + ;; - it can also result in returning all kinds of irrelevant + ;; values which would end up filling up the method-cache with + ;; lots of irrelevant/redundant entries. + ;; FIXME: We could speed this up by introducing a dedicated + ;; vector type at the C level, so we could do something like + ;; (and (vector-objectp ,name) (aref ,name 0)) `(and (vectorp ,name) (> (length ,name) 0) (let ((tag (aref ,name 0))) (if (eq (symbol-function tag) :quick-object-witness-check) tag)))) -(defun cl--generic-struct-tagcode (type name) - (and (symbolp type) - (get type 'cl-struct-type) - (or (eq 'vector (car (get type 'cl-struct-type))) - (error "Can't dispatch on cl-struct %S: type is %S" - type (car (get type 'cl-struct-type)))) - (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots))) - (error "Can't dispatch on cl-struct %S: no tag in slot 0" - type)) - ;; It's tempting to use (and (vectorp ,name) (aref ,name 0)) - ;; but that would suffer from some problems: - ;; - the vector may have size 0. - ;; - when called on an actual vector (rather than an object), we'd - ;; end up returning an arbitrary value, possibly colliding with - ;; other tagcode's values. - ;; - it can also result in returning all kinds of irrelevant - ;; values which would end up filling up the method-cache with - ;; lots of irrelevant/redundant entries. - ;; FIXME: We could speed this up by introducing a dedicated - ;; vector type at the C level, so we could do something like - ;; (and (vector-objectp ,name) (aref ,name 0)) - `(50 . ,(cl--generic-struct-tag name)))) - -(add-function :before-until cl-generic-tag-types-function - #'cl--generic-struct-tag-types) -(defun cl--generic-struct-tag-types (tag) - ;; FIXME: cl-defstruct doesn't make it easy for us. - (and (symbolp tag) - ;; A method call shouldn't itself mess with the match-data. - (string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag)) - (let ((types (list (intern (substring (symbol-name tag) 10))))) - (while (get (car types) 'cl-struct-include) - (push (get (car types) 'cl-struct-include) types)) - (push 'cl-struct types) ;The "parent type" of all cl-structs. - (nreverse types)))) +(defun cl--generic-struct-specializers (tag) + (and (symbolp tag) (boundp tag) + (let ((class (symbol-value tag))) + (when (cl-typep class 'cl-structure-class) + (let ((types ()) + (classes (list class))) + ;; BFS precedence. + (while (let ((class (pop classes))) + (push (cl--class-name class) types) + (setq classes + (append classes + (cl--class-parents class))))) + (nreverse types)))))) + +(defconst cl--generic-struct-generalizer + (cl-generic-make-generalizer + 50 #'cl--generic-struct-tag + #'cl--generic-struct-specializers)) + +(cl-defmethod cl-generic-generalizers :extra "cl-struct" (type) + "Support for dispatch on cl-struct types." + (or + (when (symbolp type) + ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than + ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can + ;; take place without requiring cl-lib. + (let ((class (cl--find-class type))) + (and (cl-typep class 'cl-structure-class) + (or (null (cl--struct-class-type class)) + (error "Can't dispatch on cl-struct %S: type is %S" + type (cl--struct-class-type class))) + (progn (cl-assert (null (cl--struct-class-named class))) t) + (list cl--generic-struct-generalizer)))) + (cl-call-next-method))) ;;; Dispatch on "system types". @@ -784,23 +930,23 @@ Can only be used from within the lexical body of a primary or around method." (sequence) (number))) -(add-function :before-until cl-generic-tagcode-function - #'cl--generic-typeof-tagcode) -(defun cl--generic-typeof-tagcode (type name) +(defconst cl--generic-typeof-generalizer + (cl-generic-make-generalizer + ;; FIXME: We could also change `type-of' to return `null' for nil. + 10 (lambda (name) `(if ,name (type-of ,name) 'null)) + (lambda (tag) (and (symbolp tag) (assq tag cl--generic-typeof-types))))) + +(cl-defmethod cl-generic-generalizers :extra "typeof" (type) + "Support for dispatch on builtin types." ;; FIXME: Add support for other types accepted by `cl-typep' such ;; as `character', `atom', `face', `function', ... - (and (assq type cl--generic-typeof-types) - (progn - (if (memq type '(vector array sequence)) - (message "`%S' also matches CL structs and EIEIO classes" type)) - ;; FIXME: We could also change `type-of' to return `null' for nil. - `(10 . (if ,name (type-of ,name) 'null))))) - -(add-function :before-until cl-generic-tag-types-function - #'cl--generic-typeof-types) -(defun cl--generic-typeof-types (tag) - (and (symbolp tag) - (assq tag cl--generic-typeof-types))) + (or + (and (assq type cl--generic-typeof-types) + (progn + (if (memq type '(vector array sequence)) + (message "`%S' also matches CL structs and EIEIO classes" type)) + (list cl--generic-typeof-generalizer))) + (cl-call-next-method))) ;;; Just for kicks: dispatch on major-mode ;; @@ -814,7 +960,7 @@ Can only be used from within the lexical body of a primary or around method." ;; (defvar cl--generic-major-modes (make-hash-table :test #'eq)) ;; -;; (add-function :before-until cl-generic-tagcode-function +;; (add-function :before-until cl-generic-generalizer-function ;; #'cl--generic-major-mode-tagcode) ;; (defun cl--generic-major-mode-tagcode (type name) ;; (if (eq 'major-mode (car-safe type)) diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 1bcfb6df2cf..5e75406cf22 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -138,6 +138,19 @@ If non-nil, alignment is done with the first parameter :type 'boolean :group 'lisp-indent) +(defcustom lisp-indent-backquote-substitution-mode t + "How to indent substitutions in backquotes. +If `t', the default, indent substituted forms normally. +If `nil', do not apply special indentation rule to substituted +forms. If `corrected', subtract the `,' or `,@' from the form +column, indenting as if this character sequence were not present. +In any case, do not backtrack beyond a backquote substitution. + +Until Emacs 25.1, the `nil' behavior was hard-wired." + :version "25.1" + :type '(choice (const corrected) (const nil) (const t)) + :group 'lisp-indent) + (defvar lisp-indent-defun-method '(4 &lambda &body) "Defun-like indentation method. @@ -145,7 +158,7 @@ This applies when the value of the `common-lisp-indent-function' property is set to `defun'.") -(defun extended-loop-p (loop-start) +(defun lisp-extended-loop-p (loop-start) "True if an extended loop form starts at LOOP-START." (condition-case () (save-excursion @@ -170,11 +183,22 @@ the standard lisp indent package." "Compute the indentation of loop form constituents." (let* ((loop-indentation (save-excursion (goto-char (elt state 1)) - (current-column)))) + (current-column)))) + (when (and (eq lisp-indent-backquote-substitution-mode 'corrected)) + (save-excursion + (goto-char (elt state 1)) + (incf loop-indentation + (cond ((eq (char-before) ?,) -1) + ((and (eq (char-before) ?@) + (progn (backward-char) + (eq (char-before) ?,))) + -2) + (t 0))))) + (goto-char indent-point) (beginning-of-line) (list - (cond ((not (extended-loop-p (elt state 1))) + (cond ((not (lisp-extended-loop-p (elt state 1))) (+ loop-indentation lisp-simple-loop-indentation)) ((looking-at "^\\s-*\\(:?\\sw+\\|;\\)") (+ loop-indentation lisp-loop-keyword-indentation)) @@ -264,9 +288,15 @@ at `common-lisp-indent-function' and, if set, use its value instead." ;; FIXME: why do we need to special-case loop? (if (save-excursion (goto-char (elt state 1)) - (looking-at (if (derived-mode-p 'emacs-lisp-mode) - "(\\(cl-\\)?[Ll][Oo][Oo][Pp]" - "([Ll][Oo][Oo][Pp]"))) + (and (looking-at (if (derived-mode-p 'emacs-lisp-mode) + "(\\(cl-\\)?loop" + "([Ll][Oo][Oo][Pp]")) + (or lisp-indent-backquote-substitution-mode + (not + (or (and (eq (char-before) ?@) + (progn (backward-char) + (eq (char-before) ?,))) + (eq (char-before) ?,)))))) (common-lisp-loop-part-indentation indent-point state) (common-lisp-indent-function-1 indent-point state))) @@ -373,11 +403,21 @@ instead." (not (eq (char-after (- containing-sexp 2)) ?\#))) ;; No indentation for "'(...)" elements (setq calculated (1+ sexp-column))) - ((or (eq (char-after (1- containing-sexp)) ?\,) - (and (eq (char-after (1- containing-sexp)) ?\@) - (eq (char-after (- containing-sexp 2)) ?\,))) - ;; ",(...)" or ",@(...)" - (setq calculated normal-indent)) + ((when + (or (eq (char-after (1- containing-sexp)) ?\,) + (and (eq (char-after (1- containing-sexp)) ?\@) + (eq (char-after (- containing-sexp 2)) ?\,))) + ;; ",(...)" or ",@(...)" + (when (eq lisp-indent-backquote-substitution-mode + 'corrected) + (incf sexp-column -1) + (when (eq (char-after (1- containing-sexp)) ?\@) + (incf sexp-column -1))) + (cond (lisp-indent-backquote-substitution-mode + (setf tentative-calculated normal-indent) + (setq depth lisp-indent-maximum-backtracking) + nil) + (t (setq calculated normal-indent))))) ((eq (char-after (1- containing-sexp)) ?\#) ;; "#(...)" (setq calculated (1+ sexp-column))) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 0f534181b22..10651cc29bd 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -629,7 +629,6 @@ 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)) - ;;; Generalized variables. ;; These used to be in cl-macs.el since all macros that use them (like setf) @@ -731,22 +730,6 @@ If ALIST is non-nil, the new pairs are prepended to it." ;;; Miscellaneous. -;;;###autoload -(progn - ;; The `assert' macro from the cl package signals - ;; `cl-assertion-failed' at runtime so always define it. - (define-error 'cl-assertion-failed (purecopy "Assertion failed")) - ;; Make sure functions defined with cl-defsubst can be inlined even in - ;; packages which do not require CL. We don't put an autoload cookie - ;; directly on that function, since those cookies only go to cl-loaddefs. - (autoload 'cl--defsubst-expand "cl-macs") - ;; 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)) - (provide 'cl-lib) (or (load "cl-loaddefs" 'noerror 'quiet) ;; When bootstrapping, cl-loaddefs hasn't been built yet! diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index eaec2c5263c..f8ddc00c3bf 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -220,7 +220,20 @@ The name is made by appending a number to PREFIX, default \"G\"." (defconst cl--lambda-list-keywords '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) -(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote) +;; Internal hacks used in formal arg lists: +;; - &cl-quote: Added to formal-arglists to mean that any default value +;; mentioned in the formal arglist should be considered as implicitly +;; quoted rather than evaluated. This is used in `cl-defsubst' when +;; performing compiler-macro-expansion, since at that time the +;; arguments hold expressions rather than values. +;; - &cl-defs (DEF . DEFS): Gives the default value to use for missing +;; optional arguments which don't have an explicit default value. +;; DEFS is an alist mapping vars to their default default value. +;; and DEF is the default default to use for all other vars. + +(defvar cl--bind-block) ;Name of surrounding block, only use for `signal' data. +(defvar cl--bind-defs) ;(DEF . DEFS) giving the "default default" for optargs. +(defvar cl--bind-enquote) ;Non-nil if &cl-quote was in the formal arglist! (defvar cl--bind-lets) (defvar cl--bind-forms) (defun cl--transform-lambda (form bind-block) @@ -229,20 +242,22 @@ BIND-BLOCK is the name of the symbol to which the function will be bound, and which will be used for the name of the `cl-block' surrounding the function's body. FORM is of the form (ARGS . BODY)." - ;; FIXME: (lambda (a &aux b) 1) expands to (lambda (a &rest --cl-rest--) ...) - ;; where the --cl-rest-- is clearly undesired. (let* ((args (car form)) (body (cdr form)) (orig-args args) (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote 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 cl-declare))) - (push (pop body) header)) + (parsed-body (macroexp-parse-body body)) + (header (car parsed-body)) (simple-args nil)) + (setq body (cdr parsed-body)) + ;; "(. X) to (&rest X)" conversion already done in cl--do-arglist, but we + ;; do it here as well, so as to be able to see if we can avoid + ;; cl--do-arglist. (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 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))) + (let ((cl-defs (memq '&cl-defs args))) + (when cl-defs + (setq cl--bind-defs (cadr cl-defs)) + ;; Remove "&cl-defs DEFS" from args. + (setcdr cl-defs (cddr cl-defs)) + (setq args (delq '&cl-defs args)))) (if (setq cl--bind-enquote (memq '&cl-quote args)) (setq args (delq '&cl-quote args))) (if (memq '&whole args) (error "&whole not currently implemented")) @@ -250,39 +265,68 @@ FORM is of the form (ARGS . BODY)." (v (cadr p))) (if p (setq args (nconc (delq (car p) (delq v args)) `(&aux (,v macroexpand-all-environment)))))) - (while (and args (symbolp (car args)) - (not (memq (car args) '(nil &rest &body &key &aux))) - (not (and (eq (car args) '&optional) - (or cl--bind-defs (consp (cadr args)))))) - (push (pop args) simple-args)) + ;; Take away all the simple args whose parsing can be handled more + ;; efficiently by a plain old `lambda' than the manual parsing generated + ;; by `cl--do-arglist'. + (let ((optional nil)) + (while (and args (symbolp (car args)) + (not (memq (car args) '(nil &rest &body &key &aux))) + (or (not optional) + ;; Optional args whose default is nil are simple. + (null (nth 1 (assq (car args) (cdr cl--bind-defs))))) + (not (and (eq (car args) '&optional) (setq optional t) + (car cl--bind-defs)))) + (push (pop args) simple-args)) + (when optional + (if args (push '&optional args)) + ;; Don't keep a dummy trailing &optional without actual optional args. + (if (eq '&optional (car simple-args)) (pop simple-args)))) (or (eq cl--bind-block 'cl-none) (setq body (list `(cl-block ,cl--bind-block ,@body)))) - (if (null args) - (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 cl--bind-lets (nreverse cl--bind-lets)) - (cl-list* nil - (nconc (nreverse simple-args) - (list '&rest (car (pop cl--bind-lets)))) - (nconc (let ((hdr (nreverse header))) + (let* ((cl--bind-lets nil) (cl--bind-forms nil) + (rest-args + (cond + ((null args) nil) + ((eq (car args) '&aux) + (cl--do-&aux args) + (setq cl--bind-lets (nreverse cl--bind-lets)) + nil) + (t ;; `simple-args' doesn't handle all the parsing that we need, + ;; so we pass the rest to cl--do-arglist which will do + ;; "manual" parsing. + (let ((slen (length simple-args))) + (when (memq '&optional simple-args) + (cl-decf slen)) + (setq header ;; Macro expansion can take place in the middle of ;; apparently harmless computation, so it should not ;; touch the match-data. (save-match-data (require 'help-fns) (cons (help-add-fundoc-usage - (if (stringp (car hdr)) (pop hdr)) + (if (stringp (car header)) (pop header)) ;; Be careful with make-symbol and (back)quote, ;; see bug#12884. (let ((print-gensym nil) (print-quoted t)) (format "%S" (cons 'fn (cl--make-usage-args orig-args))))) - hdr))) - (list `(let* ,cl--bind-lets - ,@(nreverse cl--bind-forms) - ,@body))))))) + header))) + ;; FIXME: we'd want to choose an arg name for the &rest param + ;; and pass that as `expr' to cl--do-arglist, but that ends up + ;; generating code with a redundant let-binding, so we instead + ;; pass a dummy and then look in cl--bind-lets to find what var + ;; this was bound to. + (cl--do-arglist args :dummy slen) + (setq cl--bind-lets (nreverse cl--bind-lets)) + ;; (cl-assert (eq :dummy (nth 1 (car cl--bind-lets)))) + (list '&rest (car (pop cl--bind-lets)))))))) + `(nil + (,@(nreverse simple-args) ,@rest-args) + ,@header + ,(macroexp-let* cl--bind-lets + (macroexp-progn + `(,@(nreverse cl--bind-forms) + ,@body))))))) ;;;###autoload (defmacro cl-defun (name args &rest body) @@ -304,6 +348,27 @@ and BODY is implicitly surrounded by (cl-block NAME ...). (form `(defun ,name ,@(cdr res)))) (if (car res) `(progn ,(car res) ,form) form))) +;;;###autoload +(defmacro cl-iter-defun (name args &rest body) + "Define NAME as a generator function. +Like normal `iter-defun', except ARGLIST allows full Common Lisp conventions, +and BODY is implicitly surrounded by (cl-block NAME ...). + +\(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug + ;; Same as iter-defun but use cl-lambda-list. + (&define [&or name ("setf" :name setf name)] + cl-lambda-list + cl-declarations-or-string + [&optional ("interactive" interactive)] + def-body)) + (doc-string 3) + (indent 2)) + (require 'generator) + (let* ((res (cl--transform-lambda (cons args body) name)) + (form `(iter-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. @@ -404,8 +469,7 @@ its argument list allows full Common Lisp conventions." (setcdr last nil) (nconc (cl--make-usage-args arglist) (cl--make-usage-var tail))) (setcdr last tail))) - ;; `orig-args' can contain &cl-defs (an internal - ;; CL thingy I don't understand), so remove it. + ;; `orig-args' can contain &cl-defs. (let ((x (memq '&cl-defs arglist))) (when x (setq arglist (delq (car x) (remq (cadr x) arglist))))) (let ((state nil)) @@ -432,6 +496,17 @@ its argument list allows full Common Lisp conventions." )))) arglist)))) +(defun cl--do-&aux (args) + (while (and (eq (car args) '&aux) (pop args)) + (while (and args (not (memq (car args) cl--lambda-list-keywords))) + (if (consp (car args)) + (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 ends with: %S" args))) + (defun cl--do-arglist (args expr &optional num) ; uses cl--bind-* (if (nlistp args) (if (or (memq args cl--lambda-list-keywords) (not (symbolp args))) @@ -441,8 +516,7 @@ its argument list allows full Common Lisp conventions." (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")) - (let ((save-args args) - (restarg (memq '&rest args)) + (let ((restarg (memq '&rest args)) (safety (if (cl--compiling-file) cl--optimize-safety 3)) (keys nil) (laterarg nil) (exactarg nil) minarg) @@ -512,7 +586,12 @@ its argument list allows full Common Lisp conventions." (intern (format ":%s" name))))) (varg (if (consp (car arg)) (cl-cadar arg) (car arg))) (def (if (cdr arg) (cadr arg) - (or (car cl--bind-defs) (cadr (assq varg cl--bind-defs))))) + ;; The ordering between those two or clauses is + ;; irrelevant, since in practice only one of the two + ;; is ever non-nil (the car is only used for + ;; cl-deftype which doesn't use the cdr). + (or (car cl--bind-defs) + (cadr (assq varg cl--bind-defs))))) (look `(plist-member ,restarg ',karg))) (and def cl--bind-enquote (setq def `',def)) (if (cddr arg) @@ -549,15 +628,8 @@ its argument list allows full Common Lisp conventions." 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) cl--lambda-list-keywords))) - (if (consp (car args)) - (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))))) + (cl--do-&aux args) + nil))) (defun cl--arglist-args (args) (if (nlistp args) (list args) @@ -1680,7 +1752,7 @@ An implicit nil block is established around the loop. (declare (debug ((symbolp form &optional form) cl-declarations body)) (indent 1)) (let ((loop `(dolist ,spec ,@body))) - (if (advice-member-p #'cl--wrap-in-nil-block 'dolist) + (if (advice-member-p 'cl--wrap-in-nil-block 'dolist) loop `(cl-block nil ,loop)))) ;;;###autoload @@ -1693,7 +1765,7 @@ nil. \(fn (VAR COUNT [RESULT]) BODY...)" (declare (debug cl-dolist) (indent 1)) (let ((loop `(dotimes ,spec ,@body))) - (if (advice-member-p #'cl--wrap-in-nil-block 'dotimes) + (if (advice-member-p 'cl--wrap-in-nil-block 'dotimes) loop `(cl-block nil ,loop)))) (defvar cl--tagbody-alist nil) @@ -2362,8 +2434,80 @@ Like `cl-callf', but PLACE is the second argument of FUNC, not the first. (if (symbolp func) (cons func rargs) `(funcall #',func ,@rargs)))))))) +;;;###autoload +(defmacro cl-defsubst (name args &rest body) + "Define NAME as a function. +Like `defun', except the function is automatically declared `inline' and +the arguments are immutable. +ARGLIST allows full Common Lisp conventions, and BODY is implicitly +surrounded by (cl-block NAME ...). +The function's arguments should be treated as immutable. + +\(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug cl-defun) (indent 2)) + (let* ((argns (cl--arglist-args args)) + (real-args (if (eq '&cl-defs (car args)) (cddr args) args)) + (p argns) + ;; (pbody (cons 'progn body)) + ) + (while (and p (eq (cl--expr-contains real-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) nil ,@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)) + (let* ((substs ()) + (lets (delq nil + (cl-mapcar (lambda (argn argv) + (if (or simple (macroexp-const-p argv)) + (progn (push (cons argn argv) substs) + nil) + (list argn argv))) + argns argvs)))) + ;; FIXME: `sublis/subst' will happily substitute the symbol + ;; `argn' in places where it's not used as a reference + ;; to a variable. + ;; FIXME: `sublis/subst' will happily copy `argv' to a different + ;; scope, leading to name capture. + (setq body (cond ((null substs) body) + ((null (cdr substs)) + (cl-subst (cdar substs) (caar substs) body)) + (t (cl--sublis substs body)))) + (if lets `(let ,lets ,body) body)))) + +(defun cl--sublis (alist tree) + "Perform substitutions indicated by ALIST in TREE (non-destructively)." + (let ((x (assq tree alist))) + (cond + (x (cdr x)) + ((consp tree) + (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree)))) + (t tree)))) + ;;; Structures. +(defmacro cl--find-class (type) + `(get ,type 'cl--class)) + +;; Rather than hard code cl-structure-object, we indirect through this variable +;; for bootstrapping reasons. +(defvar cl--struct-default-parent nil) + ;;;###autoload (defmacro cl-defstruct (struct &rest descs) "Define a struct type. @@ -2419,6 +2563,7 @@ non-nil value, that slot cannot be set via `setf'. (tag (intern (format "cl-struct-%s" name))) (tag-symbol (intern (format "cl-struct-%s-tags" name))) (include-descs nil) + (include-name nil) (type nil) (named nil) (forms nil) @@ -2448,12 +2593,14 @@ non-nil value, that slot cannot be set via `setf'. ((eq opt :predicate) (if args (setq predicate (car args)))) ((eq opt :include) - (when include (error "Can't :include more than once")) - (setq include (car args) - include-descs (mapcar (function - (lambda (x) - (if (consp x) x (list x)))) - (cdr args)))) + ;; FIXME: Actually, we can include more than once as long as + ;; we include EIEIO classes rather than cl-structs! + (when include-name (error "Can't :include more than once")) + (setq include-name (car args)) + (setq include-descs (mapcar (function + (lambda (x) + (if (consp x) x (list x)))) + (cdr args)))) ((eq opt :print-function) (setq print-func (car args))) ((eq opt :type) @@ -2465,19 +2612,21 @@ non-nil value, that slot cannot be set via `setf'. descs))) (t (error "Slot option %s unrecognized" opt))))) + (unless (or include-name type) + (setq include-name cl--struct-default-parent)) + (when include-name (setq include (cl--struct-get-class include-name))) (if print-func (setq print-func `(progn (funcall #',print-func cl-x cl-s cl-n) t)) - (or type (and include (not (get include 'cl-struct-print))) + (or type (and include (not (cl--struct-class-print include))) (setq print-auto t print-func (and (or (not (or include type)) (null print-func)) `(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))) - (or inc-type (error "%s is not a struct name" include)) - (and type (not (eq (car inc-type) type)) + (let* ((inc-type (cl--struct-class-type include)) + (old-descs (cl-struct-slot-info include))) + (and type (not (eq inc-type type)) (error ":type disagrees with :include for %s" name)) (while include-descs (setcar (memq (or (assq (caar include-descs) old-descs) @@ -2486,21 +2635,15 @@ non-nil value, that slot cannot be set via `setf'. old-descs) (pop include-descs))) (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) - type (car inc-type) - named (assq 'cl-tag-slot descs)) - (if (cadr inc-type) (setq tag name named t)) - (let ((incl include)) - (while incl - (push `(cl-pushnew ',tag - ,(intern (format "cl-struct-%s-tags" incl))) - forms) - (setq incl (get incl 'cl-struct-include))))) + type inc-type + named (if type (assq 'cl-tag-slot descs) 'true)) + (if (cl--struct-class-named include) (setq tag name named t))) (if type (progn (or (memq type '(vector list)) (error "Invalid :type specifier: %s" type)) (if named (setq tag name))) - (setq type 'vector named 'true))) + (setq named 'true))) (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) (when (and (null predicate) named) (setq predicate (intern (format "cl--struct-%s-p" name)))) @@ -2509,7 +2652,7 @@ non-nil value, that slot cannot be set via `setf'. (length (memq (assq 'cl-tag-slot descs) descs))))) (cond - ((eq type 'vector) + ((memq type '(nil vector)) `(and (vectorp cl-x) (>= (length cl-x) ,(length descs)) (memq (aref cl-x ,pos) ,tag-symbol))) @@ -2539,9 +2682,9 @@ non-nil value, that slot cannot be set via `setf'. (declare (side-effect-free t)) ,@(and pred-check (list `(or ,pred-check - (error "%s accessing a non-%s" - ',accessor ',name)))) - ,(if (eq type 'vector) `(aref cl-x ,pos) + (signal 'wrong-type-argument + (list ',name cl-x))))) + ,(if (memq type '(nil vector)) `(aref cl-x ,pos) (if (= pos 0) '(car cl-x) `(nth ,pos cl-x)))) forms) @@ -2596,10 +2739,10 @@ non-nil value, that slot cannot be set via `setf'. (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) slots defaults))) (push `(cl-defsubst ,name - (&cl-defs '(nil ,@descs) ,@args) + (&cl-defs (nil ,@descs) ,@args) ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) '((declare (side-effect-free t)))) - (,type ,@make)) + (,(or type #'vector) ,@make)) forms))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) ;; Don't bother adding to cl-custom-print-functions since it's not used @@ -2616,18 +2759,87 @@ non-nil value, that slot cannot be set via `setf'. `(progn (defvar ,tag-symbol) ,@(nreverse forms) + ;; Call cl-struct-define during compilation as well, so that + ;; a subsequent cl-defstruct in the same file can correctly include this + ;; struct as a parent. (eval-and-compile - (cl-struct-define ',name ,docstring ',include + (cl-struct-define ',name ,docstring ',include-name ',type ,(eq named t) ',descs ',tag-symbol ',tag ',print-auto)) ',name))) +;;; Add cl-struct support to pcase + +(defun cl--struct-all-parents (class) + (when (cl--struct-class-p class) + (let ((res ()) + (classes (list class))) + ;; BFS precedence. + (while (let ((class (pop classes))) + (push class res) + (setq classes + (append classes + (cl--class-parents class))))) + (nreverse res)))) + +;;;###autoload +(pcase-defmacro cl-struct (type &rest fields) + "Pcase patterns to match cl-structs. +Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of +field NAME is matched against UPAT, or they can be of the form NAME which +is a shorthand for (NAME NAME)." + `(and (pred (pcase--flip cl-typep ',type)) + ,@(mapcar + (lambda (field) + (let* ((name (if (consp field) (car field) field)) + (pat (if (consp field) (cadr field) field))) + `(app ,(if (eq (cl-struct-sequence-type type) 'list) + `(nth ,(cl-struct-slot-offset type name)) + `(pcase--flip aref ,(cl-struct-slot-offset type name))) + ,pat))) + fields))) + +(defun cl--pcase-mutually-exclusive-p (orig pred1 pred2) + "Extra special cases for `cl-typep' predicates." + (let* ((x1 pred1) (x2 pred2) + (t1 + (and (eq 'pcase--flip (car-safe x1)) (setq x1 (cdr x1)) + (eq 'cl-typep (car-safe x1)) (setq x1 (cdr x1)) + (null (cdr-safe x1)) (setq x1 (car x1)) + (eq 'quote (car-safe x1)) (cadr x1))) + (t2 + (and (eq 'pcase--flip (car-safe x2)) (setq x2 (cdr x2)) + (eq 'cl-typep (car-safe x2)) (setq x2 (cdr x2)) + (null (cdr-safe x2)) (setq x2 (car x2)) + (eq 'quote (car-safe x2)) (cadr x2)))) + (or + (and (symbolp t1) (symbolp t2) + (let ((c1 (cl--find-class t1)) + (c2 (cl--find-class t2))) + (and c1 c2 + (not (or (memq c1 (cl--struct-all-parents c2)) + (memq c2 (cl--struct-all-parents c1))))))) + (let ((c1 (and (symbolp t1) (cl--find-class t1)))) + (and c1 (cl--struct-class-p c1) + (funcall orig (if (eq 'list (cl-struct-sequence-type t1)) + 'consp 'vectorp) + pred2))) + (let ((c2 (and (symbolp t2) (cl--find-class t2)))) + (and c2 (cl--struct-class-p c2) + (funcall orig pred1 + (if (eq 'list (cl-struct-sequence-type t2)) + 'consp 'vectorp)))) + (funcall orig pred1 pred2)))) +(advice-add 'pcase--mutually-exclusive-p + :around #'cl--pcase-mutually-exclusive-p) + + (defun cl-struct-sequence-type (struct-type) "Return the sequence used to build STRUCT-TYPE. STRUCT-TYPE is a symbol naming a struct type. Return 'vector or 'list, or nil if STRUCT-TYPE is not a struct type. " (declare (side-effect-free t) (pure t)) - (car (get struct-type 'cl-struct-type))) + (cl--struct-class-type (cl--struct-get-class struct-type))) (defun cl-struct-slot-info (struct-type) "Return a list of slot names of struct STRUCT-TYPE. @@ -2636,7 +2848,19 @@ slot name symbol and OPTS is a list of slot options given to `cl-defstruct'. Dummy slots that represent the struct name and slots skipped by :initial-offset may appear in the list." (declare (side-effect-free t) (pure t)) - (get struct-type 'cl-struct-slots)) + (let* ((class (cl--struct-get-class struct-type)) + (slots (cl--struct-class-slots class)) + (type (cl--struct-class-type class)) + (descs (if type () (list '(cl-tag-slot))))) + (dotimes (i (length slots)) + (let ((slot (aref slots i))) + (push `(,(cl--slot-descriptor-name slot) + ,(cl--slot-descriptor-initform slot) + ,@(if (not (eq (cl--slot-descriptor-type slot) t)) + `(:type ,(cl--slot-descriptor-type slot))) + ,@(cl--slot-descriptor-props slot)) + descs))) + (nreverse descs))) (defun cl-struct-slot-offset (struct-type slot-name) "Return the offset of slot SLOT-NAME in STRUCT-TYPE. @@ -2645,9 +2869,8 @@ the structure data type and is adjusted for any structure name and :initial-offset slots. Signal error if struct STRUCT-TYPE does not contain SLOT-NAME." (declare (side-effect-free t) (pure t)) - (or (cl-position slot-name - (cl-struct-slot-info struct-type) - :key #'car :test #'eq) + (or (gethash slot-name + (cl--class-index-table (cl--struct-get-class struct-type))) (error "struct %s has no slot %s" struct-type slot-name))) (defvar byte-compile-function-environment) @@ -2661,64 +2884,70 @@ Of course, we really can't know that for sure, so it's just a heuristic." (or (cdr (assq sym byte-compile-function-environment)) (cdr (assq sym byte-compile-macro-environment)))))) -(defun cl--make-type-test (val type) - (pcase type - ((and `(,name . ,args) (guard (get name 'cl-deftype-handler))) - (cl--make-type-test val (apply (get name 'cl-deftype-handler) - args))) - (`(,(and name (or 'integer 'float 'real 'number)) - . ,(or `(,min ,max) pcase--dontcare)) - `(and ,(cl--make-type-test val name) - ,(if (memq min '(* nil)) t - (if (consp min) `(> ,val ,(car min)) - `(>= ,val ,min))) - ,(if (memq max '(* nil)) t - (if (consp max) - `(< ,val ,(car max)) - `(<= ,val ,max))))) - (`(,(and name (or 'and 'or 'not)) . ,args) - (cons name (mapcar (lambda (x) (cl--make-type-test val x)) args))) - (`(member . ,args) - `(and (cl-member ,val ',args) t)) - (`(satisfies ,pred) `(funcall #',pred ,val)) - ((and (pred symbolp) (guard (get type 'cl-deftype-handler))) - (cl--make-type-test val (funcall (get type 'cl-deftype-handler)))) - ((and (pred symbolp) (guard (get type 'cl-deftype-satisfies))) - `(funcall #',(get type 'cl-deftype-satisfies) ,val)) - ((or 'nil 't) type) - ('null `(null ,val)) - ('atom `(atom ,val)) - ('float `(floatp ,val)) - ('real `(numberp ,val)) - ('fixnum `(integerp ,val)) - ;; FIXME: Implement `base-char' and `extended-char'. - ('character `(characterp ,val)) - ((pred symbolp) - (let* ((name (symbol-name type)) - (namep (intern (concat name "p")))) - (cond - ((cl--macroexp-fboundp namep) (list namep val)) - ((cl--macroexp-fboundp - (setq namep (intern (concat name "-p")))) - (list namep val)) - ((cl--macroexp-fboundp type) (list type val)) - (t (error "Unknown type %S" type))))) - (_ (error "Bad type spec: %s" type)))) - -(defvar cl--object) +(put 'null 'cl-deftype-satisfies #'null) +(put 'atom 'cl-deftype-satisfies #'atom) +(put 'real 'cl-deftype-satisfies #'numberp) +(put 'fixnum 'cl-deftype-satisfies #'integerp) +(put 'base-char 'cl-deftype-satisfies #'characterp) +(put 'character 'cl-deftype-satisfies #'integerp) + + ;;;###autoload -(defun cl-typep (object type) ; See compiler macro below. - "Check that OBJECT is of type TYPE. -TYPE is a Common Lisp-style type specifier." - (declare (compiler-macro cl--compiler-macro-typep)) - (let ((cl--object object)) ;; Yuck!! - (eval (cl--make-type-test 'cl--object type)))) - -(defun cl--compiler-macro-typep (form val type) - (if (macroexp-const-p type) - (macroexp-let2 macroexp-copyable-p temp val - (cl--make-type-test temp (cl--const-expr-val type))) - form)) +(define-inline cl-typep (val type) + (inline-letevals (val) + (pcase (inline-const-val type) + ((and `(,name . ,args) (guard (get name 'cl-deftype-handler))) + (inline-quote + (cl-typep ,val ',(apply (get name 'cl-deftype-handler) args)))) + (`(,(and name (or 'integer 'float 'real 'number)) + . ,(or `(,min ,max) pcase--dontcare)) + (inline-quote + (and (cl-typep ,val ',name) + ,(if (memq min '(* nil)) t + (if (consp min) + (inline-quote (> ,val ',(car min))) + (inline-quote (>= ,val ',min)))) + ,(if (memq max '(* nil)) t + (if (consp max) + (inline-quote (< ,val ',(car max))) + (inline-quote (<= ,val ',max))))))) + (`(not ,type) (inline-quote (not (cl-typep ,val ',type)))) + (`(,(and name (or 'and 'or)) . ,types) + (cond + ((null types) (inline-quote ',(eq name 'and))) + ((null (cdr types)) + (inline-quote (cl-typep ,val ',(car types)))) + (t + (let ((head (car types)) + (rest `(,name . ,(cdr types)))) + (cond + ((eq name 'and) + (inline-quote (and (cl-typep ,val ',head) + (cl-typep ,val ',rest)))) + (t + (inline-quote (or (cl-typep ,val ',head) + (cl-typep ,val ',rest))))))))) + (`(eql ,v) (inline-quote (and (eql ,val ',v) t))) + (`(member . ,args) (inline-quote (and (memql ,val ',args) t))) + (`(satisfies ,pred) (inline-quote (funcall #',pred ,val))) + ((and (pred symbolp) type (guard (get type 'cl-deftype-handler))) + (inline-quote + (cl-typep ,val ',(funcall (get type 'cl-deftype-handler))))) + ((and (pred symbolp) type (guard (get type 'cl-deftype-satisfies))) + (inline-quote (funcall #',(get type 'cl-deftype-satisfies) ,val))) + ((and (or 'nil 't) type) (inline-quote ',type)) + ((and (pred symbolp) type) + (let* ((name (symbol-name type)) + (namep (intern (concat name "p")))) + (cond + ((cl--macroexp-fboundp namep) (inline-quote (funcall #',namep ,val))) + ((cl--macroexp-fboundp + (setq namep (intern (concat name "-p")))) + (inline-quote (funcall #',namep ,val))) + ((cl--macroexp-fboundp type) (inline-quote (funcall #',type ,val))) + (t (error "Unknown type %S" type))))) + (type (error "Bad type spec: %s" type))))) + ;;;###autoload (defmacro cl-check-type (form type &optional string) @@ -2751,10 +2980,9 @@ omitted, a default message listing FORM itself is used." (cdr form)))))) `(progn (or ,form - ,(if string - `(error ,string ,@sargs ,@args) - `(signal 'cl-assertion-failed - (list ',form ,@sargs)))) + (cl--assertion-failed + ',form ,@(if (or string sargs args) + `(,string (list ,@sargs) (list ,@args))))) nil)))) ;;; Compiler macros. @@ -2827,70 +3055,6 @@ macro that returns its `&whole' argument." (if cl-found (setcdr cl-found t))) `(throw ,cl-tag ,cl-value)) -;;;###autoload -(defmacro cl-defsubst (name args &rest body) - "Define NAME as a function. -Like `defun', except the function is automatically declared `inline' and -the arguments are immutable. -ARGLIST allows full Common Lisp conventions, and BODY is implicitly -surrounded by (cl-block NAME ...). -The function's arguments should be treated as immutable. - -\(fn NAME ARGLIST [DOCSTRING] BODY...)" - (declare (debug cl-defun) (indent 2)) - (let* ((argns (cl--arglist-args args)) - (p argns) - ;; (pbody (cons 'progn body)) - ) - (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) nil ,@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)) - (let* ((substs ()) - (lets (delq nil - (cl-mapcar (lambda (argn argv) - (if (or simple (macroexp-const-p argv)) - (progn (push (cons argn argv) substs) - nil) - (list argn argv))) - argns argvs)))) - ;; FIXME: `sublis/subst' will happily substitute the symbol - ;; `argn' in places where it's not used as a reference - ;; to a variable. - ;; FIXME: `sublis/subst' will happily copy `argv' to a different - ;; scope, leading to name capture. - (setq body (cond ((null substs) body) - ((null (cdr substs)) - (cl-subst (cdar substs) (caar substs) body)) - (t (cl--sublis substs body)))) - (if lets `(let ,lets ,body) body)))) - -(defun cl--sublis (alist tree) - "Perform substitutions indicated by ALIST in TREE (non-destructively)." - (let ((x (assq tree alist))) - (cond - (x (cdr x)) - ((consp tree) - (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree)))) - (t tree)))) - ;; Compile-time optimizations for some functions defined in this package. (defun cl--compiler-macro-member (form a list &rest keys) @@ -2960,25 +3124,28 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (declare (debug cl-defmacro) (doc-string 3) (indent 2)) `(cl-eval-when (compile load eval) (put ',name 'cl-deftype-handler - (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body))))) + (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body))))) + +(cl-deftype extended-char () `(and character (not base-char))) ;;; Additional functions that we can now define because we've defined ;;; `cl-defsubst' and `cl-typep'. -(cl-defsubst cl-struct-slot-value (struct-type slot-name inst) - ;; The use of `cl-defsubst' here gives us both a compiler-macro - ;; and a gv-expander "for free". +(define-inline cl-struct-slot-value (struct-type slot-name inst) "Return the value of slot SLOT-NAME in INST of STRUCT-TYPE. STRUCT and SLOT-NAME are symbols. INST is a structure instance." (declare (side-effect-free t)) - (unless (cl-typep inst struct-type) - (signal 'wrong-type-argument (list struct-type inst))) - ;; We could use `elt', but since the byte compiler will resolve the - ;; branch below at compile time, it's more efficient to use the - ;; type-specific accessor. - (if (eq (cl-struct-sequence-type struct-type) 'vector) - (aref inst (cl-struct-slot-offset struct-type slot-name)) - (nth (cl-struct-slot-offset struct-type slot-name) inst))) + (inline-letevals (struct-type slot-name inst) + (inline-quote + (progn + (unless (cl-typep ,inst ,struct-type) + (signal 'wrong-type-argument (list ,struct-type ,inst))) + ;; We could use `elt', but since the byte compiler will resolve the + ;; branch below at compile time, it's more efficient to use the + ;; type-specific accessor. + (if (eq (cl-struct-sequence-type ,struct-type) 'list) + (nth (cl-struct-slot-offset ,struct-type ,slot-name) ,inst) + (aref ,inst (cl-struct-slot-offset ,struct-type ,slot-name))))))) (run-hooks 'cl-macs-load-hook) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index c9867b412a1..ed0639b63ab 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -21,28 +21,239 @@ ;;; Commentary: -;; The expectation is that structs defined with cl-defstruct do not -;; need cl-lib at run-time, but we'd like to hide the details of the -;; cl-struct metadata behind the cl-struct-define function, so we put -;; it in this pre-loaded file. +;; The cl-defstruct macro is full of circularities, since it uses the +;; cl-structure-class type (and its accessors) which is defined with itself, +;; and it setups a default parent (cl-structure-object) which is also defined +;; with cl-defstruct, and to make things more interesting, the class of +;; cl-structure-object is of course an object of type cl-structure-class while +;; cl-structure-class's parent is cl-structure-object. +;; Furthermore, the code generated by cl-defstruct generally assumes that the +;; parent will be loaded when the child is loaded. But at the same time, the +;; expectation is that structs defined with cl-defstruct do not need cl-lib at +;; run-time, which means that the `cl-structure-object' parent can't be in +;; cl-lib but should be preloaded. So here's this preloaded circular setup. ;;; Code: +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'cl-macs)) ;For cl--struct-class. + +;; The `assert' macro from the cl package signals +;; `cl-assertion-failed' at runtime so always define it. +(define-error 'cl-assertion-failed (purecopy "Assertion failed")) + +(defun cl--assertion-failed (form &optional string sargs args) + (if debug-on-error + (debug `(cl-assertion-failed ,form ,string ,@sargs)) + (if string + (apply #'error string (append sargs args)) + (signal 'cl-assertion-failed `(,form ,@sargs))))) + +;; When we load this (compiled) file during pre-loading, the cl--struct-class +;; code below will need to access the `cl-struct' info, since it's considered +;; already as its parent (because `cl-struct' was defined while the file was +;; compiled). So let's temporarily setup a fake. +(defvar cl-struct-cl-structure-object-tags nil) +(unless (cl--find-class 'cl-structure-object) + (setf (cl--find-class 'cl-structure-object) 'dummy)) + +(fset 'cl--make-slot-desc + ;; To break circularity, we pre-define the slot constructor by hand. + ;; It's redefined a bit further down as part of the cl-defstruct of + ;; cl--slot-descriptor. + ;; BEWARE: Obviously, it's important to keep the two in sync! + (lambda (name &optional initform type props) + (vector 'cl-struct-cl-slot-descriptor + name initform type props))) + +(defun cl--struct-get-class (name) + (or (if (not (symbolp name)) name) + (cl--find-class name) + (if (not (get name 'cl-struct-type)) + ;; FIXME: Add a conversion for `eieio--class' so we can + ;; create a cl-defstruct that inherits from an eieio class? + (error "%S is not a struct name" name) + ;; Backward compatibility with a defstruct compiled with a version + ;; cl-defstruct from Emacs<25. Convert to new format. + (let ((tag (intern (format "cl-struct-%s" name))) + (type-and-named (get name 'cl-struct-type)) + (descs (get name 'cl-struct-slots))) + (cl-struct-define name nil (get name 'cl-struct-include) + (unless (and (eq (car type-and-named) 'vector) + (null (cadr type-and-named)) + (assq 'cl-tag-slot descs)) + (car type-and-named)) + (cadr type-and-named) + descs + (intern (format "cl-struct-%s-tags" name)) + tag + (get name 'cl-struct-print)) + (cl--find-class name))))) + +(defun cl--plist-remove (plist member) + (cond + ((null plist) nil) + ((null member) plist) + ((eq plist member) (cddr plist)) + (t `(,(car plist) ,(cadr plist) ,@(cl--plist-remove (cddr plist) member))))) + +(defun cl--struct-register-child (parent tag) + ;; Can't use (cl-typep parent 'cl-structure-class) at this stage + ;; because `cl-structure-class' is defined later. + (while (vectorp parent) + (add-to-list (cl--struct-class-children-sym parent) tag) + ;; Only register ourselves as a child of the leftmost parent since structs + ;; can only only have one parent. + (setq parent (car (cl--struct-class-parents parent))))) + +;;;###autoload (defun cl-struct-define (name docstring parent type named slots children-sym - tag print-auto) + tag print) + (cl-assert (or type (not named))) (if (boundp children-sym) (add-to-list children-sym tag) (set children-sym (list tag))) - ;; If the cl-generic support, we need to be able to check - ;; if a vector is a cl-struct object, without knowing its particular type. - ;; So we use the (otherwise) unused function slots of the tag symbol - ;; to put a special witness value, to make the check easy and reliable. - (unless named (fset tag :quick-object-witness-check)) - (put name 'cl-struct-slots slots) - (put name 'cl-struct-type (list type named)) - (if parent (put name 'cl-struct-include parent)) - (if print-auto (put name 'cl-struct-print print-auto)) - (if docstring (put name 'structure-documentation docstring))) + (and (null type) (eq (caar slots) 'cl-tag-slot) + ;; Hide the tag slot from "standard" (i.e. non-`type'd) structs. + (setq slots (cdr slots))) + (let* ((parent-class (when parent (cl--struct-get-class parent))) + (n (length slots)) + (index-table (make-hash-table :test 'eq :size n)) + (vslots (let ((v (make-vector n nil)) + (i 0) + (offset (if type 0 1))) + (dolist (slot slots) + (let* ((props (cddr slot)) + (typep (plist-member props :type)) + (type (if typep (cadr typep) t))) + (aset v i (cl--make-slot-desc + (car slot) (nth 1 slot) + type (cl--plist-remove props typep)))) + (puthash (car slot) (+ i offset) index-table) + (cl-incf i)) + v)) + (class (cl--struct-new-class + name docstring + (unless (symbolp parent-class) (list parent-class)) + type named vslots index-table children-sym tag print))) + (unless (symbolp parent-class) + (let ((pslots (cl--struct-class-slots parent-class))) + (or (>= n (length pslots)) + (let ((ok t)) + (dotimes (i (length pslots)) + (unless (eq (cl--slot-descriptor-name (aref pslots i)) + (cl--slot-descriptor-name (aref vslots i))) + (setq ok nil))) + ok) + (error "Included struct %S has changed since compilation of %S" + parent name)))) + (cl--struct-register-child parent-class tag) + (unless (eq named t) + (eval `(defconst ,tag ',class) t) + ;; In the cl-generic support, we need to be able to check + ;; if a vector is a cl-struct object, without knowing its particular type. + ;; So we use the (otherwise) unused function slots of the tag symbol + ;; to put a special witness value, to make the check easy and reliable. + (fset tag :quick-object-witness-check)) + (setf (cl--find-class name) class))) + +(cl-defstruct (cl-structure-class + (:conc-name cl--struct-class-) + (:predicate cl--struct-class-p) + (:constructor nil) + (:constructor cl--struct-new-class + (name docstring parents type named slots index-table + children-sym tag print)) + (:copier nil)) + "The type of CL structs descriptors." + ;; The first few fields here are actually inherited from cl--class, but we + ;; have to define this one before, to break the circularity, so we manually + ;; list the fields here and later "backpatch" cl--class as the parent. + ;; BEWARE: Obviously, it's indispensable to keep these two structs in sync! + (name nil :type symbol) ;The type name. + (docstring nil :type string) + (parents nil :type (list-of cl--class)) ;The included struct. + (slots nil :type (vector cl--slot-descriptor)) + (index-table nil :type hash-table) + (tag nil :type symbol) ;Placed in cl-tag-slot. Holds the struct-class object. + (type nil :type (memq (vector list))) + (named nil :type bool) + (print nil :type bool) + (children-sym nil :type symbol) ;This sym's value holds the tags of children. + ) + +(cl-defstruct (cl-structure-object + (:predicate cl-struct-p) + (:constructor nil) + (:copier nil)) + "The root parent of all \"normal\" CL structs") + +(setq cl--struct-default-parent 'cl-structure-object) + +(cl-defstruct (cl-slot-descriptor + (:conc-name cl--slot-descriptor-) + (:constructor nil) + (:constructor cl--make-slot-descriptor + (name &optional initform type props)) + (:copier cl--copy-slot-descriptor)) + ;; FIXME: This is actually not used yet, for circularity reasons! + "Descriptor of structure slot." + name ;Attribute name (symbol). + initform + type + ;; Extra properties, kept in an alist, can include: + ;; :documentation, :protection, :custom, :label, :group, :printer. + (props nil :type alist)) + +(cl-defstruct (cl--class + (:constructor nil) + (:copier nil)) + "Type of descriptors for any kind of structure-like data." + ;; Intended to be shared between defstruct and defclass. + (name nil :type symbol) ;The type name. + (docstring nil :type string) + ;; For structs there can only be one parent, but when EIEIO classes inherit + ;; from cl--class, we'll need this to hold a list. + (parents nil :type (list-of cl--class)) + (slots nil :type (vector cl-slot-descriptor)) + (index-table nil :type hash-table)) + +(cl-assert + (let ((sc-slots (cl--struct-class-slots (cl--find-class 'cl-structure-class))) + (c-slots (cl--struct-class-slots (cl--find-class 'cl--class))) + (eq t)) + (dotimes (i (length c-slots)) + (let ((sc-slot (aref sc-slots i)) + (c-slot (aref c-slots i))) + (unless (eq (cl--slot-descriptor-name sc-slot) + (cl--slot-descriptor-name c-slot)) + (setq eq nil)))) + eq)) + +;; Close the recursion between cl-structure-object and cl-structure-class. +(setf (cl--struct-class-parents (cl--find-class 'cl-structure-class)) + (list (cl--find-class 'cl--class))) +(cl--struct-register-child + (cl--find-class 'cl--class) + (cl--struct-class-tag (cl--find-class 'cl-structure-class))) + +(cl-assert (cl--find-class 'cl-structure-class)) +(cl-assert (cl--find-class 'cl-structure-object)) +(cl-assert (cl-struct-p (cl--find-class 'cl-structure-class))) +(cl-assert (cl-struct-p (cl--find-class 'cl-structure-object))) +(cl-assert (cl--class-p (cl--find-class 'cl-structure-class))) +(cl-assert (cl--class-p (cl--find-class 'cl-structure-object))) + +;; Make sure functions defined with cl-defsubst can be inlined even in +;; packages which do not require CL. We don't put an autoload cookie +;; directly on that function, since those cookies only go to cl-loaddefs. +(autoload 'cl--defsubst-expand "cl-macs") +;; 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) (provide 'cl-preloaded) ;;; cl-preloaded.el ends here diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index dc0e666836e..ce5c7863c3c 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -106,10 +106,10 @@ This is to optimize `debugger-make-xrefs'.") "Non-nil if we expect to get back in the debugger soon.") (defvar inhibit-debug-on-entry nil - "Non-nil means that debug-on-entry is disabled.") + "Non-nil means that `debug-on-entry' is disabled.") (defvar debugger-jumping-flag nil - "Non-nil means that debug-on-entry is disabled. + "Non-nil means that `debug-on-entry' is disabled. This variable is used by `debugger-jump', `debugger-step-through', and `debugger-reenable' to temporarily disable debug-on-entry.") @@ -165,7 +165,6 @@ first will be printed into the backtrace buffer." ;; Don't let these magic variables affect the debugger itself. (let ((last-command nil) this-command track-mouse (inhibit-trace t) - (inhibit-debug-on-entry t) unread-command-events unread-post-input-method-events last-input-event last-command-event last-nonmenu-event @@ -193,8 +192,10 @@ first will be printed into the backtrace buffer." debugger-buffer `((display-buffer-reuse-window display-buffer-in-previous-window) - . (,(when debugger-previous-window - `(previous-window . ,debugger-previous-window))))) + . (,(when (and (window-live-p debugger-previous-window) + (frame-visible-p + (window-frame debugger-previous-window))) + `(previous-window . ,debugger-previous-window))))) (setq debugger-window (selected-window)) (if (eq debugger-previous-window debugger-window) (when debugger-jumping-flag @@ -535,11 +536,7 @@ Applies to the frame whose line point is on in the backtrace." (defmacro debugger-env-macro (&rest body) "Run BODY in original environment." (declare (indent 0)) - `(save-excursion - (if (null (buffer-live-p debugger-old-buffer)) - ;; old buffer deleted - (setq debugger-old-buffer (current-buffer))) - (set-buffer debugger-old-buffer) + `(progn (set-match-data debugger-outer-match-data) (prog1 (progn ,@body) @@ -767,7 +764,8 @@ A call to this function is inserted by `debug-on-entry' to cause functions to break on entry." (if (or inhibit-debug-on-entry debugger-jumping-flag) nil - (funcall debugger 'debug))) + (let ((inhibit-debug-on-entry t)) + (funcall debugger 'debug)))) ;;;###autoload (defun debug-on-entry (function) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index f7e8619948a..bd95a6018ff 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -114,9 +114,12 @@ Optional KEYMAP is the default keymap bound to the mode keymap. BODY contains code to execute each time the mode is enabled or disabled. It is executed after toggling the mode, and before running MODE-hook. Before the actual body code, you can write keyword arguments, i.e. - alternating keywords and values. These following special keywords - are supported (other keywords are passed to `defcustom' if the minor - mode is global): + alternating keywords and values. If you provide BODY, then you must + provide (even if just nil) INIT-VALUE, LIGHTER, and KEYMAP, or provide + at least one keyword argument, or both; otherwise, BODY would be + misinterpreted as the first omitted argument. The following special + keywords are supported (other keywords are passed to `defcustom' if + the minor mode is global): :group GROUP Custom group name to use in all generated `defcustom' forms. Defaults to MODE without the possible trailing \"-mode\". @@ -159,7 +162,8 @@ For example, you could write ;; Allow skipping the first three args. (cond ((keywordp init-value) - (setq body `(,init-value ,lighter ,keymap ,@body) + (setq body (if keymap `(,init-value ,lighter ,keymap ,@body) + `(,init-value ,lighter)) init-value nil lighter nil keymap nil)) ((keywordp lighter) (setq body `(,lighter ,keymap ,@body) lighter nil keymap nil)) @@ -280,14 +284,23 @@ the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. (if (called-interactively-p 'any) (progn ,(if (and globalp (symbolp mode)) + ;; Unnecessary but harmless if mode set buffer-locally `(customize-mark-as-set ',mode)) ;; Avoid overwriting a message shown by the body, ;; but do overwrite previous messages. (unless (and (current-message) (not (equal ,last-message (current-message)))) - (message ,(format "%s %%sabled" pretty-name) - (if ,mode "en" "dis"))))) + (let ((local + ,(if globalp + (if (symbolp mode) + `(if (local-variable-p ',mode) + " in current buffer" + "") + "") + " in current buffer"))) + (message ,(format "%s %%sabled%%s" pretty-name) + (if ,mode "en" "dis") local))))) ,@(when after-hook `(,after-hook))) (force-mode-line-update) ;; Return the new setting. diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 7faa101299e..aa7cdf96337 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -2358,6 +2358,12 @@ MSG is printed after `::::} '." (defalias 'edebug-mark-marker 'mark-marker) (defun edebug--display (value offset-index arg-mode) + ;; edebug--display-1 is too big, we should split it. This function + ;; here was just introduced to avoid making edebug--display-1 + ;; yet a bit deeper. + (save-excursion (edebug--display-1 value offset-index arg-mode))) + +(defun edebug--display-1 (value offset-index arg-mode) (unless (marker-position edebug-def-mark) ;; The buffer holding the source has been killed. ;; Let's at least show a backtrace so the user can figure out @@ -2440,18 +2446,6 @@ MSG is printed after `::::} '." edebug-function) )) - (setcdr edebug-window-data - (edebug-adjust-window (cdr edebug-window-data))) - - ;; Test if there is input, not including keyboard macros. - (if (input-pending-p) - (progn - (setq edebug-execution-mode 'step - edebug-stop t) - (edebug-stop) - ;; (discard-input) ; is this unfriendly?? - )) - ;; Make sure we bind those in the right buffer (bug#16410). (let ((overlay-arrow-position overlay-arrow-position) (overlay-arrow-string overlay-arrow-string)) @@ -2504,14 +2498,18 @@ MSG is printed after `::::} '." ((eq edebug-execution-mode 'Trace-fast) (sit-for 0))) ; Force update and continue. + (when (input-pending-p) + (setq edebug-stop t) + (setq edebug-execution-mode 'step) ; for `edebug-overlay-arrow' + (edebug-stop)) + + (edebug-overlay-arrow) + (unwind-protect (if (or edebug-stop (memq edebug-execution-mode '(step next)) (eq arg-mode 'error)) - (progn - ;; (setq edebug-execution-mode 'step) - ;; (edebug-overlay-arrow) ; This doesn't always show up. - (edebug--recursive-edit arg-mode))) ; <--- Recursive edit + (edebug--recursive-edit arg-mode)) ; <--- Recursive edit ;; Reset the edebug-window-data to whatever it is now. (let ((window (if (eq (window-buffer) edebug-buffer) @@ -2671,12 +2669,6 @@ MSG is printed after `::::} '." (defining-kbd-macro (if edebug-continue-kbd-macro defining-kbd-macro)) - ;; Disable command hooks. This is essential when - ;; a hook function is instrumented - to avoid infinite loop. - ;; This may be more than we need, however. - (pre-command-hook nil) - (post-command-hook nil) - ;; others?? ) @@ -2705,8 +2697,9 @@ MSG is printed after `::::} '." (if (buffer-name edebug-buffer) ; if it still exists (progn (set-buffer edebug-buffer) - (if (memq edebug-execution-mode '(go Go-nonstop)) - (edebug-overlay-arrow)) + (when (memq edebug-execution-mode '(go Go-nonstop)) + (edebug-overlay-arrow) + (sit-for 0)) (edebug-mode -1)) ;; gotta have a buffer to let its buffer local variables be set (get-buffer-create " bogus edebug buffer")) @@ -2716,31 +2709,6 @@ MSG is printed after `::::} '." ;;; Display related functions -(defun edebug-adjust-window (old-start) - ;; If pos is not visible, adjust current window to fit following context. - ;; (message "window: %s old-start: %s window-start: %s pos: %s" - ;; (selected-window) old-start (window-start) (point)) (sit-for 5) - (if (not (pos-visible-in-window-p)) - (progn - ;; First try old-start - (if old-start - (set-window-start (selected-window) old-start)) - (if (not (pos-visible-in-window-p)) - (progn - ;; (message "resetting window start") (sit-for 2) - (set-window-start - (selected-window) - (save-excursion - (forward-line - (if (< (point) (window-start)) -1 ; one line before if in back - (- (/ (window-height) 2)) ; center the line moving forward - )) - (beginning-of-line) - (point))))))) - (window-start)) - - - (defconst edebug-arrow-alist '((Continue-fast . "=") (Trace-fast . "-") @@ -2749,7 +2717,7 @@ MSG is printed after `::::} '." (step . "=>") (next . "=>") (go . "<>") - (Go-nonstop . "..") ; not used + (Go-nonstop . "..") ) "Association list of arrows for each edebug mode.") @@ -3317,6 +3285,9 @@ Return the result of the last expression." ;; Restore outside context. (setq-default cursor-in-non-selected-windows edebug-outside-d-c-i-n-s-w) (unwind-protect + ;; FIXME: This restoring of edebug-outside-buffer and + ;; edebug-outside-point is redundant now that backtrace-eval does it + ;; for us. (with-current-buffer edebug-outside-buffer ; of edebug-buffer (goto-char edebug-outside-point) (if (marker-buffer (edebug-mark-marker)) diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index fcf02b92736..2e280365a7a 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -140,7 +140,7 @@ Multiple calls to `make-instance' will return this object.")) A singleton is a class which will only ever have one instance." :abstract t) -(cl-defmethod eieio-constructor ((class (subclass eieio-singleton)) &rest _slots) +(cl-defmethod make-instance ((class (subclass eieio-singleton)) &rest _slots) "Constructor for singleton CLASS. NAME and SLOTS initialize the new object. This constructor guarantees that no matter how many you request, @@ -254,25 +254,28 @@ malicious code. Note: This function recurses when a slot of :type of some object is identified, and needing more object creation." - (let ((objclass (nth 0 inputlist)) - ;; (objname (nth 1 inputlist)) - (slots (nthcdr 2 inputlist)) - (createslots nil)) - - ;; If OBJCLASS is an eieio autoload object, then we need to load it. - (eieio-class-un-autoload objclass) + (let* ((objclass (nth 0 inputlist)) + ;; (objname (nth 1 inputlist)) + (slots (nthcdr 2 inputlist)) + (createslots nil) + (class + (progn + ;; If OBJCLASS is an eieio autoload object, then we need to + ;; load it. + (eieio-class-un-autoload objclass) + (eieio--class-object objclass)))) (while slots - (let ((name (car slots)) + (let ((initarg (car slots)) (value (car (cdr slots)))) ;; Make sure that the value proposed for SLOT is valid. ;; In addition, strip out quotes, list functions, and update ;; object constructors as needed. (setq value (eieio-persistent-validate/fix-slot-value - (eieio--class-v objclass) name value)) + class (eieio--initarg-to-attribute class initarg) value)) - (push name createslots) + (push initarg createslots) (push value createslots) ) @@ -290,16 +293,12 @@ constructor functions are considered valid. Second, any text properties will be stripped from strings." (cond ((consp proposed-value) ;; Lists with something in them need special treatment. - (let ((slot-idx (eieio--slot-name-index class slot)) - (type nil) - (classtype nil)) - (setq slot-idx (- slot-idx - (eval-when-compile eieio--object-num-slots))) - (setq type (aref (eieio--class-public-type class) - slot-idx)) - - (setq classtype (eieio-persistent-slot-type-is-class-p - type)) + (let* ((slot-idx (- (eieio--slot-name-index class slot) + (eval-when-compile + (length (cl-struct-slot-info 'eieio--object))))) + (type (cl--slot-descriptor-type (aref (eieio--class-slots class) + slot-idx))) + (classtype (eieio-persistent-slot-type-is-class-p type))) (cond ((eq (car proposed-value) 'quote) (car (cdr proposed-value))) @@ -500,6 +499,15 @@ All slots are unbound, except those initialized with PARAMS." (concat nm "-1"))))) nobj)) +(cl-defmethod make-instance ((class (subclass eieio-named)) &rest args) + (if (not (stringp (car args))) + (cl-call-next-method) + (funcall (if eieio-backward-compatibility #'ignore #'message) + "Obsolete: name passed without :object-name to %S constructor" + class) + (apply #'cl-call-next-method class :object-name args))) + + (provide 'eieio-base) ;;; eieio-base.el ends here diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index 7468c040e10..0283704e033 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -124,30 +124,41 @@ Summary: (defgeneric ,method ,args) (eieio--defmethod ',method ',key ',class #',code)))) -(add-function :before-until cl-generic-tagcode-function - #'eieio--generic-static-tagcode) -(defun eieio--generic-static-tagcode (type name) - (and (eq 'eieio--static (car-safe type)) - `(40 . (cond - ((symbolp ,name) (eieio--class-v ,name)) - ((vectorp ,name) (aref ,name 0)))))) - -(add-function :around cl-generic-tag-types-function - #'eieio--generic-static-tag-types) -(defun eieio--generic-static-tag-types (orig-fun tag) - (cond - ((or (eieio--class-p tag) - (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)))) - (let ((superclasses (funcall orig-fun tag)) - (types ())) - ;; Interleave: (subclass <foo>) (eieio--static <foo>) <subclass <bar>) .. +(defun eieio--generic-static-symbol-specializers (tag) + (cl-assert (or (null tag) (eieio--class-p tag))) + (when (eieio--class-p tag) + (let ((superclasses (eieio--generic-subclass-specializers tag)) + (specializers ())) (dolist (superclass superclasses) - (push superclass types) - (push `(eieio--static - ,(if (consp superclass) (cadr superclass) superclass)) - types)) - (nreverse types))) - (t (funcall orig-fun tag)))) + (push superclass specializers) + (push `(eieio--static ,(cadr superclass)) specializers)) + (nreverse specializers)))) + +(defconst eieio--generic-static-symbol-generalizer + (cl-generic-make-generalizer + ;; Give it a slightly higher priority than `subclass' so that the + ;; interleaved list comes before subclass's non-interleaved list. + 61 (lambda (name) `(and (symbolp ,name) (eieio--class-v ,name))) + #'eieio--generic-static-symbol-specializers)) +(defconst eieio--generic-static-object-generalizer + (cl-generic-make-generalizer + ;; Give it a slightly higher priority than `class' so that the + ;; interleaved list comes before the class's non-interleaved list. + 51 #'cl--generic-struct-tag + (lambda (tag) + (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag)) + (eieio--class-p tag) + (let ((superclasses (eieio--class-precedence-list tag)) + (specializers ())) + (dolist (superclass superclasses) + (setq superclass (eieio--class-name superclass)) + (push superclass specializers) + (push `(eieio--static ,superclass) specializers)) + (nreverse specializers)))))) + +(cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static))) + (list eieio--generic-static-symbol-generalizer + eieio--generic-static-object-generalizer)) ;;;###autoload (defun eieio--defgeneric-init-form (method doc-string) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index e71c54d4123..6fd9c14088e 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -85,9 +85,10 @@ Currently under control of this var: ;; Arrange for field access not to bother checking if the access is indeed ;; made to an eieio--class object. (cl-declaim (optimize (safety 0))) + (cl-defstruct (eieio--class (:constructor nil) - (:constructor eieio--class-make (symbol &aux (tag 'defclass))) + (:constructor eieio--class-make (name &aux (tag 'defclass))) (:type vector) (:copier nil)) ;; We use an untagged cl-struct, with our own hand-made tag as first field @@ -96,30 +97,16 @@ Currently under control of this var: ;; predicate for us), but that breaks compatibility with .elc files compiled ;; against older versions of EIEIO. tag - symbol ;; symbol (self-referencing) - parent children - symbol-hashtable ;; hashtable permitting fast access to variable position indexes - ;; @todo - ;; the word "public" here is leftovers from the very first version. - ;; Get rid of it! - public-a ;; class attribute index - public-d ;; class attribute defaults index - public-doc ;; class documentation strings for attributes - public-type ;; class type for a slot - public-custom ;; class custom type for a slot - public-custom-label ;; class custom group for a slot - public-custom-group ;; class custom group for a slot - public-printer ;; printer for a slot - protection ;; protection for a slot + ;; Fields we could inherit from cl--class (if we used a tagged cl-struct): + (name nil :type symbol) ;The type name. + (docstring nil :type string) + (parents nil :type (or eieio--class (list-of eieio--class))) + (slots nil :type (vector cl-slot-descriptor)) + (index-table nil :type hash-table) + ;; Fields specific to EIEIO classes: + children initarg-tuples ;; initarg tuples list - class-allocation-a ;; class allocated attributes - class-allocation-doc ;; class allocated documentation - class-allocation-type ;; class allocated value type - class-allocation-custom ;; class allocated custom descriptor - class-allocation-custom-label ;; class allocated custom descriptor - class-allocation-custom-group ;; class allocated custom group - class-allocation-printer ;; class allocated printer for a slot - class-allocation-protection ;; class allocated protection list + (class-slots nil :type eieio--slot) class-allocation-values ;; class allocated value vector default-object-cache ;; what a newly created object would look like. ; This will speed up instantiation time as @@ -142,18 +129,13 @@ Currently under control of this var: ;; object/struct in its `symbol-value' slot. class-tag) -(eval-and-compile +(eval-when-compile (defconst eieio--object-num-slots - (length (get 'eieio--object 'cl-struct-slots)))) + (length (cl-struct-slot-info 'eieio--object)))) -(defsubst eieio--object-class-object (obj) +(defsubst eieio--object-class (obj) (symbol-value (eieio--object-class-tag obj))) -(defsubst eieio--object-class-name (obj) - ;; FIXME: Most uses of this function should be changed to use - ;; eieio--object-class-object instead! - (eieio--class-symbol (eieio--object-class-object obj))) - ;;; Important macros used internally in eieio. @@ -181,15 +163,15 @@ Currently under control of this var: CLASS is a symbol." ;FIXME: Is it a vector or a symbol? (and (symbolp class) (eieio--class-p (eieio--class-v class)))) +(defun eieio--class-print-name (class) + "Return a printed representation of CLASS." + (format "#<class %s>" (eieio-class-name class))) + (defun eieio-class-name (class) "Return a Lisp like symbol name for CLASS." - ;; FIXME: What's a "Lisp like symbol name"? - ;; FIXME: CLOS returns a symbol, but the code returns a string. - (if (eieio--class-p class) (setq class (eieio--class-symbol class))) - (cl-check-type class class) - ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, - ;; and I wanted a string. Arg! - (format "#<class %s>" (symbol-name class))) + (setq class (eieio--class-object class)) + (cl-check-type class eieio--class) + (eieio--class-name class)) (define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") (defalias 'eieio--class-constructor #'identity @@ -317,7 +299,7 @@ See `defclass' for more information." (newc (if (and oldc (not (eieio--class-default-object-cache oldc))) ;; The oldc class is a stub setup by eieio-defclass-autoload. ;; Reuse it instead of creating a new one, so that existing - ;; references are still valid. + ;; references stay valid. oldc (eieio--class-make cname))) (groups nil) ;; list of groups id'd from slots @@ -354,10 +336,10 @@ See `defclass' for more information." (mapc (lambda (g) (cl-pushnew g groups :test #'equal)) (eieio--class-option c :custom-groups)) ;; Save parent in child. - (push c (eieio--class-parent newc)))))) + (push c (eieio--class-parents newc)))))) ;; Reverse the list of our parents so that they are prioritized in ;; the same order as specified in the code. - (cl-callf nreverse (eieio--class-parent newc))) + (cl-callf nreverse (eieio--class-parents newc))) ;; If there is nothing to loop over, then inherit from the ;; default superclass. (unless (eq cname 'eieio-default-superclass) @@ -366,7 +348,7 @@ See `defclass' for more information." ;; save new child in parent (cl-pushnew cname (eieio--class-children eieio-default-superclass)) ;; save parent in child - (setf (eieio--class-parent newc) (list eieio-default-superclass)))) + (setf (eieio--class-parents newc) (list eieio-default-superclass)))) ;; turn this into a usable self-pointing symbol; FIXME: Why? (when eieio-backward-compatibility @@ -442,68 +424,70 @@ See `defclass' for more information." (make-obsolete-variable initarg (format "use '%s instead" initarg) "25.1")))) - ;; The customgroup should be a list of symbols - (cond ((null customg) + ;; The customgroup should be a list of symbols. + (cond ((and (null customg) custom) (setq customg '(default))) ((not (listp customg)) (setq customg (list customg)))) - ;; The customgroup better be a symbol, or list of symbols. - (mapc (lambda (cg) - (if (not (symbolp cg)) - (signal 'invalid-slot-type (list :group cg)))) - customg) + ;; The customgroup better be a list of symbols. + (dolist (cg customg) + (unless (symbolp cg) + (signal 'invalid-slot-type (list :group cg)))) ;; First up, add this slot into our new class. - (eieio--add-new-slot newc name init docstr type custom label customg printer - prot initarg alloc 'defaultoverride skip-nil) + (eieio--add-new-slot + newc (cl--make-slot-descriptor + name init type + `(,@(if docstr `((:documentation . ,docstr))) + ,@(if custom `((:custom . ,custom))) + ,@(if label `((:label . ,label))) + ,@(if customg `((:group . ,customg))) + ,@(if printer `((:printer . ,printer))) + ,@(if prot `((:protection . ,prot))))) + initarg alloc 'defaultoverride skip-nil) ;; We need to id the group, and store them in a group list attribute. (dolist (cg customg) - (cl-pushnew cg groups :test 'equal)) + (cl-pushnew cg groups :test #'equal)) )) ;; Now that everything has been loaded up, all our lists are backwards! - ;; Fix that up now. - (cl-callf nreverse (eieio--class-public-a newc)) - (cl-callf nreverse (eieio--class-public-d newc)) - (cl-callf nreverse (eieio--class-public-doc newc)) - (cl-callf (lambda (types) (apply #'vector (nreverse types))) - (eieio--class-public-type newc)) - (cl-callf nreverse (eieio--class-public-custom newc)) - (cl-callf nreverse (eieio--class-public-custom-label newc)) - (cl-callf nreverse (eieio--class-public-custom-group newc)) - (cl-callf nreverse (eieio--class-public-printer newc)) - (cl-callf nreverse (eieio--class-protection newc)) + ;; Fix that up now and then them into vectors. + (cl-callf (lambda (slots) (apply #'vector (nreverse slots))) + (eieio--class-slots newc)) (cl-callf nreverse (eieio--class-initarg-tuples newc)) ;; The storage for class-class-allocation-type needs to be turned into ;; a vector now. - (cl-callf (lambda (cat) (apply #'vector cat)) - (eieio--class-class-allocation-type newc)) - - ;; Also, take class allocated values, and vectorize them for speed. - (cl-callf (lambda (cavs) (apply #'vector cavs)) - (eieio--class-class-allocation-values newc)) + (cl-callf (lambda (slots) (apply #'vector slots)) + (eieio--class-class-slots newc)) + + ;; Also, setup the class allocated values. + (let* ((slots (eieio--class-class-slots newc)) + (n (length slots)) + (v (make-vector n nil))) + (dotimes (i n) + (setf (aref v i) (eieio-default-eval-maybe + (cl--slot-descriptor-initform (aref slots i))))) + (setf (eieio--class-class-allocation-values newc) v)) ;; Attach slot symbols into a hashtable, and store the index of ;; this slot as the value this table. - (let* ((cnt 0) - (pubsyms (eieio--class-public-a newc)) - (prots (eieio--class-protection newc)) + (let* ((slots (eieio--class-slots newc)) + ;; (cslots (eieio--class-class-slots newc)) (oa (make-hash-table :test #'eq))) - (while pubsyms - (let ((newsym (list cnt))) - (setf (gethash (car pubsyms) oa) newsym) - (setq cnt (1+ cnt)) - (if (car prots) (setcdr newsym (car prots)))) - (setq pubsyms (cdr pubsyms) - prots (cdr prots))) - (setf (eieio--class-symbol-hashtable newc) oa)) + ;; (dotimes (cnt (length cslots)) + ;; (setf (gethash (cl--slot-descriptor-name (aref cslots cnt)) oa) (- -1 cnt))) + (dotimes (cnt (length slots)) + (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa) cnt)) + (setf (eieio--class-index-table newc) oa)) ;; Set up a specialized doc string. ;; Use stored value since it is calculated in a non-trivial way - (put cname 'variable-documentation - (eieio--class-option-assoc options :documentation)) + (let ((docstring (eieio--class-option-assoc options :documentation))) + (setf (eieio--class-docstring newc) docstring) + (when eieio-backward-compatibility + (put cname 'variable-documentation docstring))) ;; Save the file location where this class is defined. (add-to-list 'current-load-list `(eieio-defclass . ,cname)) @@ -520,10 +504,10 @@ See `defclass' for more information." ;; if this is a superclass, clear out parent (which was set to the ;; default superclass eieio-default-superclass) - (if clearparent (setf (eieio--class-parent newc) nil)) + (if clearparent (setf (eieio--class-parents newc) nil)) ;; Create the cached default object. - (let ((cache (make-vector (+ (length (eieio--class-public-a newc)) + (let ((cache (make-vector (+ (length (eieio--class-slots newc)) (eval-when-compile eieio--object-num-slots)) nil)) ;; We don't strictly speaking need to use a symbol, but the old @@ -550,239 +534,133 @@ See `defclass' for more information." "Whether the default value VAL should be evaluated for use." (and (consp val) (symbolp (car val)) (fboundp (car val)))) -(defun eieio--perform-slot-validation-for-default (slot spec value skipnil) - "For SLOT, signal if SPEC does not match VALUE. -If SKIPNIL is non-nil, then if VALUE is nil return t instead." - (if (not (or (eieio-eval-default-p value) ;FIXME: Why? - eieio-skip-typecheck - (and skipnil (null value)) - (eieio--perform-slot-validation spec value))) - (signal 'invalid-slot-type (list slot spec value)))) - -(defun eieio--add-new-slot (newc a d doc type cust label custg print prot init alloc +(defun eieio--perform-slot-validation-for-default (slot skipnil) + "For SLOT, signal if its type does not match its default value. +If SKIPNIL is non-nil, then if default value is nil return t instead." + (let ((value (cl--slot-descriptor-initform slot)) + (spec (cl--slot-descriptor-type slot))) + (if (not (or (eieio-eval-default-p value) ;FIXME: Why? + eieio-skip-typecheck + (and skipnil (null value)) + (eieio--perform-slot-validation spec value))) + (signal 'invalid-slot-type (list (cl--slot-descriptor-name slot) spec value))))) + +(defun eieio--slot-override (old new skipnil) + (cl-assert (eq (cl--slot-descriptor-name old) (cl--slot-descriptor-name new))) + ;; There is a match, and we must override the old value. + (let* ((a (cl--slot-descriptor-name old)) + (tp (cl--slot-descriptor-type old)) + (d (cl--slot-descriptor-initform new)) + (type (cl--slot-descriptor-type new)) + (oprops (cl--slot-descriptor-props old)) + (nprops (cl--slot-descriptor-props new)) + (custg (alist-get :group nprops))) + ;; If type is passed in, is it the same? + (if (not (eq type t)) + (if (not (equal type tp)) + (error + "Child slot type `%s' does not match inherited type `%s' for `%s'" + type tp a)) + (setf (cl--slot-descriptor-type new) tp)) + ;; If we have a repeat, only update the initarg... + (unless (eq d eieio-unbound) + (eieio--perform-slot-validation-for-default new skipnil) + (setf (cl--slot-descriptor-initform old) d)) + + ;; PLN Tue Jun 26 11:57:06 2007 : The protection is + ;; checked and SHOULD match the superclass + ;; protection. Otherwise an error is thrown. However + ;; I wonder if a more flexible schedule might be + ;; implemented. + ;; + ;; EML - We used to have (if prot... here, + ;; but a prot of 'nil means public. + ;; + (let ((super-prot (alist-get :protection oprops)) + (prot (alist-get :protection nprops))) + (if (not (eq prot super-prot)) + (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" + prot super-prot a))) + ;; End original PLN + + ;; PLN Tue Jun 26 11:57:06 2007 : + ;; Do a non redundant combination of ancient custom + ;; groups and new ones. + (when custg + (let* ((list1 (alist-get :group oprops))) + (dolist (elt custg) + (unless (memq elt list1) + (push elt list1))) + (setf (alist-get :group (cl--slot-descriptor-props old)) list1))) + ;; End PLN + + ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is + ;; set, simply replaces the old one. + (dolist (prop '(:custom :label :documentation :printer)) + (when (alist-get prop (cl--slot-descriptor-props new)) + (setf (alist-get prop (cl--slot-descriptor-props old)) + (alist-get prop (cl--slot-descriptor-props new)))) + + ) )) + +(defun eieio--add-new-slot (newc slot init alloc &optional defaultoverride skipnil) - "Add into NEWC attribute A. -If A already exists in NEWC, then do nothing. If it doesn't exist, -then also add in D (default), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg. + "Add into NEWC attribute SLOT. +If a slot of that name already exists in NEWC, then do nothing. If it doesn't exist, +INIT is the initarg, if any. Argument ALLOC specifies if the slot is allocated per instance, or per class. If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC, we must override its value for a default. Optional argument SKIPNIL indicates if type checking should be skipped if default value is nil." ;; Make sure we duplicate those items that are sequences. + (let* ((a (cl--slot-descriptor-name slot)) + (d (cl--slot-descriptor-initform slot)) + (old (car (cl-member a (eieio--class-slots newc) + :key #'cl--slot-descriptor-name))) + (cold (car (cl-member a (eieio--class-class-slots newc) + :key #'cl--slot-descriptor-name)))) (condition-case nil (if (sequencep d) (setq d (copy-sequence d))) - ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's skip it if it doesn't work. + ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's + ;; skip it if it doesn't work. (error nil)) - (if (sequencep type) (setq type (copy-sequence type))) - (if (sequencep cust) (setq cust (copy-sequence cust))) - (if (sequencep custg) (setq custg (copy-sequence custg))) + ;; (if (sequencep type) (setq type (copy-sequence type))) + ;; (if (sequencep cust) (setq cust (copy-sequence cust))) + ;; (if (sequencep custg) (setq custg (copy-sequence custg))) ;; To prevent override information w/out specification of storage, ;; we need to do this little hack. - (if (member a (eieio--class-class-allocation-a newc)) (setq alloc :class)) + (if cold (setq alloc :class)) - (if (or (not alloc) (and (symbolp alloc) (eq alloc :instance))) + (if (memq alloc '(nil :instance)) ;; In this case, we modify the INSTANCE version of a given slot. - (progn - - ;; Only add this element if it is so-far unique - (if (not (member a (eieio--class-public-a newc))) - (progn - (eieio--perform-slot-validation-for-default a type d skipnil) - (push a (eieio--class-public-a newc)) - (push d (eieio--class-public-d newc)) - (push doc (eieio--class-public-doc newc)) - (push type (eieio--class-public-type newc)) - (push cust (eieio--class-public-custom newc)) - (push label (eieio--class-public-custom-label newc)) - (push custg (eieio--class-public-custom-group newc)) - (push print (eieio--class-public-printer newc)) - (push prot (eieio--class-protection newc)) - (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc))) - ) - ;; When defaultoverride is true, we are usually adding new local - ;; attributes which must override the default value of any slot - ;; passed in by one of the parent classes. - (when defaultoverride - ;; There is a match, and we must override the old value. - (let* ((ca (eieio--class-public-a newc)) - (np (member a ca)) - (num (- (length ca) (length np))) - (dp (if np (nthcdr num (eieio--class-public-d newc)) - nil)) - (tp (if np (nth num (eieio--class-public-type newc)))) - ) - (if (not np) - (error "EIEIO internal error overriding default value for %s" - a) - ;; If type is passed in, is it the same? - (if (not (eq type t)) - (if (not (equal type tp)) - (error - "Child slot type `%s' does not match inherited type `%s' for `%s'" - type tp a))) - ;; If we have a repeat, only update the initarg... - (unless (eq d eieio-unbound) - (eieio--perform-slot-validation-for-default a tp d skipnil) - (setcar dp d)) - ;; If we have a new initarg, check for it. - (when init - (let* ((inits (eieio--class-initarg-tuples newc)) - (inita (rassq a inits))) - ;; Replace the CAR of the associate INITA. - ;;(message "Initarg: %S replace %s" inita init) - (setcar inita init) - )) - - ;; PLN Tue Jun 26 11:57:06 2007 : The protection is - ;; checked and SHOULD match the superclass - ;; protection. Otherwise an error is thrown. However - ;; I wonder if a more flexible schedule might be - ;; implemented. - ;; - ;; EML - We used to have (if prot... here, - ;; but a prot of 'nil means public. - ;; - (let ((super-prot (nth num (eieio--class-protection newc))) - ) - (if (not (eq prot super-prot)) - (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" - prot super-prot a))) - ;; End original PLN - - ;; PLN Tue Jun 26 11:57:06 2007 : - ;; Do a non redundant combination of ancient custom - ;; groups and new ones. - (when custg - (let* ((groups - (nthcdr num (eieio--class-public-custom-group newc))) - (list1 (car groups)) - (list2 (if (listp custg) custg (list custg)))) - (if (< (length list1) (length list2)) - (setq list1 (prog1 list2 (setq list2 list1)))) - (dolist (elt list2) - (unless (memq elt list1) - (push elt list1))) - (setcar groups list1))) - ;; End PLN - - ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is - ;; set, simply replaces the old one. - (when cust - ;; (message "Custom type redefined to %s" cust) - (setcar (nthcdr num (eieio--class-public-custom newc)) cust)) - - ;; If a new label is specified, it simply replaces - ;; the old one. - (when label - ;; (message "Custom label redefined to %s" label) - (setcar (nthcdr num (eieio--class-public-custom-label newc)) label)) - ;; End PLN - - ;; PLN Sat Jun 30 17:24:42 2007 : when a new - ;; doc is specified, simply replaces the old one. - (when doc - ;;(message "Documentation redefined to %s" doc) - (setcar (nthcdr num (eieio--class-public-doc newc)) - doc)) - ;; End PLN - - ;; If a new printer is specified, it simply replaces - ;; the old one. - (when print - ;; (message "printer redefined to %s" print) - (setcar (nthcdr num (eieio--class-public-printer newc)) print)) - - ))) - )) + ;; Only add this element if it is so-far unique + (if (not old) + (progn + (eieio--perform-slot-validation-for-default slot skipnil) + (push slot (eieio--class-slots newc)) + ) + ;; When defaultoverride is true, we are usually adding new local + ;; attributes which must override the default value of any slot + ;; passed in by one of the parent classes. + (when defaultoverride + (eieio--slot-override old slot skipnil))) + (when init + (cl-pushnew (cons init a) (eieio--class-initarg-tuples newc) + :test #'equal))) ;; CLASS ALLOCATED SLOTS - (let ((value (eieio-default-eval-maybe d))) - (if (not (member a (eieio--class-class-allocation-a newc))) - (progn - (eieio--perform-slot-validation-for-default a type value skipnil) - ;; Here we have found a :class version of a slot. This - ;; requires a very different approach. - (push a (eieio--class-class-allocation-a newc)) - (push doc (eieio--class-class-allocation-doc newc)) - (push type (eieio--class-class-allocation-type newc)) - (push cust (eieio--class-class-allocation-custom newc)) - (push label (eieio--class-class-allocation-custom-label newc)) - (push custg (eieio--class-class-allocation-custom-group newc)) - (push prot (eieio--class-class-allocation-protection newc)) - ;; Default value is stored in the 'values section, since new objects - ;; can't initialize from this element. - (push value (eieio--class-class-allocation-values newc))) - (when defaultoverride - ;; There is a match, and we must override the old value. - (let* ((ca (eieio--class-class-allocation-a newc)) - (np (member a ca)) - (num (- (length ca) (length np))) - (dp (if np - (nthcdr num - (eieio--class-class-allocation-values newc)) - nil)) - (tp (if np (nth num (eieio--class-class-allocation-type newc)) - nil))) - (if (not np) - (error "EIEIO internal error overriding default value for %s" - a) - ;; If type is passed in, is it the same? - (if (not (eq type t)) - (if (not (equal type tp)) - (error - "Child slot type `%s' does not match inherited type `%s' for `%s'" - type tp a))) - ;; EML - Note: the only reason to override a class bound slot - ;; is to change the default, so allow unbound in. - - ;; If we have a repeat, only update the value... - (eieio--perform-slot-validation-for-default a tp value skipnil) - (setcar dp value)) - - ;; PLN Tue Jun 26 11:57:06 2007 : The protection is - ;; checked and SHOULD match the superclass - ;; protection. Otherwise an error is thrown. However - ;; I wonder if a more flexible schedule might be - ;; implemented. - (let ((super-prot - (car (nthcdr num (eieio--class-class-allocation-protection newc))))) - (if (not (eq prot super-prot)) - (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" - prot super-prot a))) - ;; Do a non redundant combination of ancient custom groups - ;; and new ones. - (when custg - (let* ((groups - (nthcdr num (eieio--class-class-allocation-custom-group newc))) - (list1 (car groups)) - (list2 (if (listp custg) custg (list custg)))) - (if (< (length list1) (length list2)) - (setq list1 (prog1 list2 (setq list2 list1)))) - (dolist (elt list2) - (unless (memq elt list1) - (push elt list1))) - (setcar groups list1))) - - ;; PLN Sat Jun 30 17:24:42 2007 : when a new - ;; doc is specified, simply replaces the old one. - (when doc - ;;(message "Documentation redefined to %s" doc) - (setcar (nthcdr num (eieio--class-class-allocation-doc newc)) - doc)) - ;; End PLN - - ;; If a new printer is specified, it simply replaces - ;; the old one. - (when print - ;; (message "printer redefined to %s" print) - (setcar (nthcdr num (eieio--class-class-allocation-printer newc)) print)) - - )) - )) - )) + (if (not cold) + (progn + (eieio--perform-slot-validation-for-default slot skipnil) + ;; Here we have found a :class version of a slot. This + ;; requires a very different approach. + (push slot (eieio--class-class-slots newc))) + (when defaultoverride + ;; There is a match, and we must override the old value. + (eieio--slot-override cold slot skipnil)))))) (defun eieio-copy-parents-into-subclass (newc) "Copy into NEWC the slots of PARENTS. @@ -790,63 +668,22 @@ Follow the rules of not overwriting early parents when applying to the new child class." (let ((sn (eieio--class-option-assoc (eieio--class-options newc) :allow-nil-initform))) - (dolist (pcv (eieio--class-parent newc)) + (dolist (pcv (eieio--class-parents newc)) ;; First, duplicate all the slots of the parent. - (let ((pa (eieio--class-public-a pcv)) - (pd (eieio--class-public-d pcv)) - (pdoc (eieio--class-public-doc pcv)) - (ptype (eieio--class-public-type pcv)) - (pcust (eieio--class-public-custom pcv)) - (plabel (eieio--class-public-custom-label pcv)) - (pcustg (eieio--class-public-custom-group pcv)) - (printer (eieio--class-public-printer pcv)) - (pprot (eieio--class-protection pcv)) - (pinit (eieio--class-initarg-tuples pcv)) - (i 0)) - (while pa - (eieio--add-new-slot newc - (car pa) (car pd) (car pdoc) (aref ptype i) - (car pcust) (car plabel) (car pcustg) - (car printer) - (car pprot) (car-safe (car pinit)) nil nil sn) + (let ((pslots (eieio--class-slots pcv)) + (pinit (eieio--class-initarg-tuples pcv))) + (dotimes (i (length pslots)) + (eieio--add-new-slot newc (cl--copy-slot-descriptor (aref pslots i)) + (car-safe (car pinit)) nil nil sn) ;; Increment each value. - (setq pa (cdr pa) - pd (cdr pd) - pdoc (cdr pdoc) - i (1+ i) - pcust (cdr pcust) - plabel (cdr plabel) - pcustg (cdr pcustg) - printer (cdr printer) - pprot (cdr pprot) - pinit (cdr pinit)) + (setq pinit (cdr pinit)) )) ;; while/let ;; Now duplicate all the class alloc slots. - (let ((pa (eieio--class-class-allocation-a pcv)) - (pdoc (eieio--class-class-allocation-doc pcv)) - (ptype (eieio--class-class-allocation-type pcv)) - (pcust (eieio--class-class-allocation-custom pcv)) - (plabel (eieio--class-class-allocation-custom-label pcv)) - (pcustg (eieio--class-class-allocation-custom-group pcv)) - (printer (eieio--class-class-allocation-printer pcv)) - (pprot (eieio--class-class-allocation-protection pcv)) - (pval (eieio--class-class-allocation-values pcv)) - (i 0)) - (while pa - (eieio--add-new-slot newc - (car pa) (aref pval i) (car pdoc) (aref ptype i) - (car pcust) (car plabel) (car pcustg) - (car printer) - (car pprot) nil :class sn) - ;; Increment each value. - (setq pa (cdr pa) - pdoc (cdr pdoc) - pcust (cdr pcust) - plabel (cdr plabel) - pcustg (cdr pcustg) - printer (cdr printer) - pprot (cdr pprot) - i (1+ i)) + (let ((pcslots (eieio--class-class-slots pcv))) + (dotimes (i (length pcslots)) + (eieio--add-new-slot newc (cl--copy-slot-descriptor + (aref pcslots i)) + nil :class sn) ))))) @@ -871,10 +708,11 @@ an error." nil ;; Trim off object IDX junk added in for the object index. (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) - (let ((st (aref (eieio--class-public-type class) slot-idx))) + (let ((st (cl--slot-descriptor-type (aref (eieio--class-slots class) + slot-idx)))) (if (not (eieio--perform-slot-validation st value)) (signal 'invalid-slot-type - (list (eieio--class-symbol class) slot st value)))))) + (list (eieio--class-name class) slot st value)))))) (defun eieio--validate-class-slot-value (class slot-idx value slot) "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. @@ -883,11 +721,11 @@ SLOT is the slot that is being checked, and is only used when throwing an error." (if eieio-skip-typecheck nil - (let ((st (aref (eieio--class-class-allocation-type class) - slot-idx))) + (let ((st (cl--slot-descriptor-type (aref (eieio--class-class-slots class) + slot-idx)))) (if (not (eieio--perform-slot-validation st value)) (signal 'invalid-slot-type - (list (eieio--class-symbol class) slot st value)))))) + (list (eieio--class-name class) slot st value)))))) (defun eieio-barf-if-slot-unbound (value instance slotname fn) "Throw a signal if VALUE is a representation of an UNBOUND slot. @@ -895,7 +733,7 @@ INSTANCE is the object being referenced. SLOTNAME is the offending slot. If the slot is ok, return VALUE. Argument FN is the function calling this verifier." (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) - (slot-unbound instance (eieio--object-class-name instance) slotname fn) + (slot-unbound instance (eieio--object-class instance) slotname fn) value)) @@ -910,7 +748,7 @@ Argument FN is the function calling this verifier." (let ((c (eieio--class-v obj))) (if (eieio--class-p c) (eieio-class-un-autoload obj)) c)) - (t (eieio--object-class-object obj)))) + (t (eieio--object-class obj)))) (c (eieio--slot-name-index class slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. @@ -934,7 +772,7 @@ Fills in OBJ's SLOT with its default value." (cl-check-type obj (or eieio-object class)) (cl-check-type slot symbol) (let* ((cl (cond ((symbolp obj) (eieio--class-v obj)) - (t (eieio--object-class-object obj)))) + (t (eieio--object-class obj)))) (c (eieio--slot-name-index cl slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. @@ -948,10 +786,11 @@ Fills in OBJ's SLOT with its default value." ;;(signal 'invalid-slot-name (list (class-name cl) slot)) ) (eieio-barf-if-slot-unbound - (let ((val (nth (- c (eval-when-compile eieio--object-num-slots)) - (eieio--class-public-d cl)))) + (let ((val (cl--slot-descriptor-initform + (aref (eieio--class-slots cl) + (- c (eval-when-compile eieio--object-num-slots)))))) (eieio-default-eval-maybe val)) - obj (eieio--class-symbol cl) 'oref-default)))) + obj (eieio--class-name cl) 'oref-default)))) (defun eieio-default-eval-maybe (val) "Check VAL, and return what `oref-default' would provide." @@ -972,7 +811,7 @@ Fills in OBJ's SLOT with its default value." Fills in OBJ's SLOT with VALUE." (cl-check-type obj eieio-object) (cl-check-type slot symbol) - (let* ((class (eieio--object-class-object obj)) + (let* ((class (eieio--object-class obj)) (c (eieio--slot-name-index class slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. @@ -1007,13 +846,24 @@ Fills in the default value in CLASS' in SLOT with VALUE." (eieio--validate-class-slot-value class c value slot) (aset (eieio--class-class-allocation-values class) c value)) - (signal 'invalid-slot-name (list (eieio--class-symbol class) slot))) + (signal 'invalid-slot-name (list (eieio--class-name class) slot))) + ;; `oset-default' on an instance-allocated slot is allowed by EIEIO but + ;; not by CLOS and is mildly inconsistent with the :initform thingy, so + ;; it'd be nice to get of it. This said, it is/was used at one place by + ;; gnus/registry.el, so it might be used elsewhere as well, so let's + ;; keep it for now. + ;; FIXME: Generate a compile-time warning for it! + ;; (error "Can't `oset-default' an instance-allocated slot: %S of %S" + ;; slot class) (eieio--validate-slot-value class c value slot) ;; Set this into the storage for defaults. (if (eieio-eval-default-p value) (error "Can't set default to a sexp that gets evaluated again")) - (setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots)) - (eieio--class-public-d class)) + (setf (cl--slot-descriptor-initform + ;; FIXME: Apparently we set it both in `slots' and in + ;; `object-cache', which seems redundant. + (aref (eieio--class-slots class) + (- c (eval-when-compile eieio--object-num-slots)))) value) ;; Take the value, and put it into our cache object. (eieio-oset (eieio--class-default-object-cache class) @@ -1029,12 +879,16 @@ The slot is a symbol which is installed in CLASS by the `defclass' call. If SLOT is the value created with :initarg instead, reverse-lookup that name, and recurse with the associated slot value." ;; Removed checks to outside this call - (let* ((fsym (gethash slot (eieio--class-symbol-hashtable class))) - (fsi (car fsym))) + (let* ((fsi (gethash slot (eieio--class-index-table class)))) (if (integerp fsi) (+ (eval-when-compile eieio--object-num-slots) fsi) (let ((fn (eieio--initarg-to-attribute class slot))) - (if fn (eieio--slot-name-index class fn) nil))))) + (if fn + ;; Accessing a slot via its :initarg is accepted by EIEIO + ;; (but not CLOS) but is a bad idea (for one: it's slower). + ;; FIXME: We should emit a compile-time warning when this happens! + (eieio--slot-name-index class fn) + nil))))) (defun eieio--class-slot-name-index (class slot) "In CLASS find the index of the named SLOT. @@ -1043,13 +897,12 @@ call. If SLOT is the value created with :initarg instead, reverse-lookup that name, and recurse with the associated slot value." ;; This will happen less often, and with fewer slots. Do this the ;; storage cheap way. - (let* ((a (eieio--class-class-allocation-a class)) - (l1 (length a)) - (af (memq slot a)) - (l2 (length af))) - ;; Slot # is length of the total list, minus the remaining list of - ;; the found slot. - (if af (- l1 l2)))) + (let ((index nil) + (slots (eieio--class-class-slots class))) + (dotimes (i (length slots)) + (if (eq slot (cl--slot-descriptor-name (aref slots i))) + (setq index i))) + index)) ;;; ;; Way to assign slots based on a list. Used for constructors, or @@ -1060,12 +913,12 @@ reverse-lookup that name, and recurse with the associated slot value." If SET-ALL is non-nil, then when a default is nil, that value is reset. If SET-ALL is nil, the slots are only reset if the default is not nil." - (let ((pub (eieio--class-public-a (eieio--object-class-object obj)))) - (while pub - (let ((df (eieio-oref-default obj (car pub)))) + (let ((slots (eieio--class-slots (eieio--object-class obj)))) + (dotimes (i (length slots)) + (let* ((name (cl--slot-descriptor-name (aref slots i))) + (df (eieio-oref-default obj name))) (if (or df set-all) - (eieio-oset obj (car pub) df))) - (setq pub (cdr pub))))) + (eieio-oset obj name df)))))) (defun eieio--initarg-to-attribute (class initarg) "For CLASS, convert INITARG to the actual attribute name. @@ -1092,11 +945,8 @@ need be... May remove that later...)" (defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs) "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. If a consistent order does not exist, signal an error." - (if (let ((tail remaining-inputs) - (found nil)) - (while (and tail (not found)) - (setq found (car tail) tail (cdr tail))) - (not found)) + (setq remaining-inputs (delq nil remaining-inputs)) + (if (null remaining-inputs) ;; If all remaining inputs are empty lists, we are done. (nreverse reversed-partial-result) ;; Otherwise, we try to find the next element of the result. This @@ -1107,9 +957,8 @@ If a consistent order does not exist, signal an error." (tail remaining-inputs) (next (progn (while (and tail (not found)) - (setq found (and (car tail) - (eieio--c3-candidate (caar tail) - remaining-inputs)) + (setq found (eieio--c3-candidate (caar tail) + remaining-inputs) tail (cdr tail))) found))) (if next @@ -1123,9 +972,13 @@ If a consistent order does not exist, signal an error." ;; The graph is inconsistent, give up (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) +(defsubst eieio--class/struct-parents (class) + (or (eieio--class-parents class) + `(,eieio-default-superclass))) + (defun eieio--class-precedence-c3 (class) "Return all parents of CLASS in c3 order." - (let ((parents (eieio--class-parent (eieio--class-v class)))) + (let ((parents (eieio--class-parents (eieio--class-v class)))) (eieio--c3-merge-lists (list class) (append @@ -1139,7 +992,7 @@ If a consistent order does not exist, signal an error." (defun eieio--class-precedence-dfs (class) "Return all parents of CLASS in depth-first order." - (let* ((parents (eieio--class-parent class)) + (let* ((parents (eieio--class-parents class)) (classes (copy-sequence (apply #'append (list class) @@ -1162,15 +1015,13 @@ If a consistent order does not exist, signal an error." (defun eieio--class-precedence-bfs (class) "Return all parents of CLASS in breadth-first order." (let* ((result) - (queue (or (eieio--class-parent class) - `(,eieio-default-superclass)))) + (queue (eieio--class/struct-parents class))) (while queue (let ((head (pop queue))) (unless (member head result) (push head result) (unless (eq head eieio-default-superclass) - (setq queue (append queue (or (eieio--class-parent head) - `(,eieio-default-superclass)))))))) + (setq queue (append queue (eieio--class/struct-parents head))))))) (cons class (nreverse result))) ) @@ -1184,7 +1035,7 @@ method invocation orders of the involved classes." (if (or (null class) (eq class eieio-default-superclass)) nil (unless (eieio--class-default-object-cache class) - (eieio-class-un-autoload (eieio--class-symbol class))) + (eieio-class-un-autoload (eieio--class-name class))) (cl-case (eieio--class-method-invocation-order class) (:depth-first (eieio--class-precedence-dfs class)) @@ -1210,25 +1061,26 @@ method invocation orders of the involved classes." ;;;; General support to dispatch based on the type of the argument. -(add-function :before-until cl-generic-tagcode-function - #'eieio--generic-tagcode) -(defun eieio--generic-tagcode (type name) +(defconst eieio--generic-generalizer + (cl-generic-make-generalizer + ;; Use the exact same tagcode as for cl-struct, so that methods + ;; that dispatch on both kinds of objects get to share this + ;; part of the dispatch code. + 50 #'cl--generic-struct-tag + (lambda (tag) + (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)) + (mapcar #'eieio--class-name + (eieio--class-precedence-list (symbol-value tag))))))) + +(cl-defmethod cl-generic-generalizers :extra "class" (specializer) ;; CLHS says: ;; A class must be defined before it can be used as a parameter ;; specializer in a defmethod form. ;; So we can ignore types that are not known to denote classes. - (and (eieio--class-p (eieio--class-object type)) - ;; Use the exact same code as for cl-struct, so that methods - ;; that dispatch on both kinds of objects get to share this - ;; part of the dispatch code. - `(50 . ,(cl--generic-struct-tag name)))) - -(add-function :before-until cl-generic-tag-types-function - #'eieio--generic-tag-types) -(defun eieio--generic-tag-types (tag) - (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)) - (mapcar #'eieio--class-symbol - (eieio--class-precedence-list (symbol-value tag))))) + (or + (and (eieio--class-p (eieio--class-object specializer)) + (list eieio--generic-generalizer)) + (cl-call-next-method))) ;;;; Dispatch for arguments which are classes. @@ -1238,23 +1090,22 @@ method invocation orders of the involved classes." ;; would not make much sense (e.g. to which argument should it apply?). ;; Instead, we add a new "subclass" specializer. -(add-function :before-until cl-generic-tagcode-function - #'eieio--generic-subclass-tagcode) -(defun eieio--generic-subclass-tagcode (type name) - (when (eq 'subclass (car-safe type)) - `(60 . (and (symbolp ,name) (eieio--class-v ,name))))) - -(add-function :before-until cl-generic-tag-types-function - #'eieio--generic-subclass-tag-types) -(defun eieio--generic-subclass-tag-types (tag) +(defun eieio--generic-subclass-specializers (tag) (when (eieio--class-p tag) (mapcar (lambda (class) - `(subclass - ,(if (symbolp class) class (eieio--class-symbol class)))) + `(subclass ,(eieio--class-name class))) (eieio--class-precedence-list tag)))) +(defconst eieio--generic-subclass-generalizer + (cl-generic-make-generalizer + 60 (lambda (name) `(and (symbolp ,name) (eieio--class-v ,name))) + #'eieio--generic-subclass-specializers)) + +(cl-defmethod cl-generic-generalizers ((_specializer (head subclass))) + (list eieio--generic-subclass-generalizer)) + -;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "5b04c9a8fff2bd3f3d3ac54aba0f65b7") +;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "0609a7bdcd6f38876b7f5647047ddca9") ;;; Generated autoloads from eieio-compat.el (autoload 'eieio--defalias "eieio-compat" "\ diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index 0e0b31e4e7e..26fc452f7b1 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -193,12 +193,8 @@ Optional argument IGNORE is an extraneous parameter." (let* ((chil nil) (obj (widget-get widget :value)) (master-group (widget-get widget :eieio-group)) - (cv (eieio--object-class-object obj)) - (slots (eieio--class-public-a cv)) - (flabel (eieio--class-public-custom-label cv)) - (fgroup (eieio--class-public-custom-group cv)) - (fdoc (eieio--class-public-doc cv)) - (fcust (eieio--class-public-custom cv))) + (cv (eieio--object-class obj)) + (slots (eieio--class-slots cv))) ;; First line describes the object, but may not editable. (if (widget-get widget :eieio-show-name) (setq chil (cons (widget-create-child-and-convert @@ -208,7 +204,7 @@ Optional argument IGNORE is an extraneous parameter." chil))) ;; Display information about the group being shown (when master-group - (let ((groups (eieio--class-option (eieio--object-class-object obj) + (let ((groups (eieio--class-option (eieio--object-class obj) :custom-groups))) (widget-insert "Groups:") (while groups @@ -225,63 +221,59 @@ Optional argument IGNORE is an extraneous parameter." (setq groups (cdr groups))) (widget-insert "\n\n"))) ;; Loop over all the slots, creating child widgets. - (while slots - ;; Output this slot if it has a customize flag associated with it. - (when (and (car fcust) - (or (not master-group) (member master-group (car fgroup))) - (slot-boundp obj (car slots))) - ;; In this case, this slot has a custom type. Create its - ;; children widgets. - (let ((type (eieio-filter-slot-type widget (car fcust))) - (stuff nil)) - ;; This next bit is an evil hack to get some EDE functions - ;; working the way I like. - (if (and (listp type) - (setq stuff (member :slotofchoices type))) - (let ((choices (eieio-oref obj (car (cdr stuff)))) - (newtype nil)) - (while (not (eq (car type) :slotofchoices)) - (setq newtype (cons (car type) newtype) - type (cdr type))) - (while choices - (setq newtype (cons (list 'const (car choices)) - newtype) - choices (cdr choices))) - (setq type (nreverse newtype)))) - (setq chil (cons (widget-create-child-and-convert - widget 'object-slot - :childtype type - :sample-face 'eieio-custom-slot-tag-face - :tag - (concat - (make-string - (or (widget-get widget :indent) 0) - ? ) - (if (car flabel) - (car flabel) - (let ((s (symbol-name - (or - (eieio--class-slot-initarg - (eieio--object-class-object obj) - (car slots)) - (car slots))))) - (capitalize - (if (string-match "^:" s) - (substring s (match-end 0)) - s))))) - :value (slot-value obj (car slots)) - :doc (if (car fdoc) (car fdoc) - "Slot not Documented.") - :eieio-custom-visibility 'visible - ) - chil)) - ) - ) - (setq slots (cdr slots) - fdoc (cdr fdoc) - fcust (cdr fcust) - flabel (cdr flabel) - fgroup (cdr fgroup))) + (dotimes (i (length slots)) + (let* ((slot (aref slots i)) + (props (cl--slot-descriptor-props slot))) + ;; Output this slot if it has a customize flag associated with it. + (when (and (alist-get :custom props) + (or (not master-group) + (member master-group (alist-get :group props))) + (slot-boundp obj (cl--slot-descriptor-name slot))) + ;; In this case, this slot has a custom type. Create its + ;; children widgets. + (let ((type (eieio-filter-slot-type widget (alist-get :custom props))) + (stuff nil)) + ;; This next bit is an evil hack to get some EDE functions + ;; working the way I like. + (if (and (listp type) + (setq stuff (member :slotofchoices type))) + (let ((choices (eieio-oref obj (car (cdr stuff)))) + (newtype nil)) + (while (not (eq (car type) :slotofchoices)) + (setq newtype (cons (car type) newtype) + type (cdr type))) + (while choices + (setq newtype (cons (list 'const (car choices)) + newtype) + choices (cdr choices))) + (setq type (nreverse newtype)))) + (setq chil (cons (widget-create-child-and-convert + widget 'object-slot + :childtype type + :sample-face 'eieio-custom-slot-tag-face + :tag + (concat + (make-string + (or (widget-get widget :indent) 0) + ?\s) + (or (alist-get :label props) + (let ((s (symbol-name + (or + (eieio--class-slot-initarg + (eieio--object-class obj) + (car slots)) + (car slots))))) + (capitalize + (if (string-match "^:" s) + (substring s (match-end 0)) + s))))) + :value (slot-value obj (car slots)) + :doc (or (alist-get :documentation props) + "Slot not Documented.") + :eieio-custom-visibility 'visible + ) + chil)) + )))) (widget-put widget :children (nreverse chil)) )) @@ -289,34 +281,33 @@ Optional argument IGNORE is an extraneous parameter." "Get the value of WIDGET." (let* ((obj (widget-get widget :value)) (master-group eieio-cog) - (cv (eieio--object-class-object obj)) - (fgroup (eieio--class-public-custom-group cv)) (wids (widget-get widget :children)) (name (if (widget-get widget :eieio-show-name) (car (widget-apply (car wids) :value-inline)) nil)) (chil (if (widget-get widget :eieio-show-name) (nthcdr 1 wids) wids)) - (cv (eieio--object-class-object obj)) - (slots (eieio--class-public-a cv)) - (fcust (eieio--class-public-custom cv))) + (cv (eieio--object-class obj)) + (i 0) + (slots (eieio--class-slots cv))) ;; If there are any prefix widgets, clear them. ;; -- None yet ;; Create a batch of initargs for each slot. - (while (and slots chil) - (if (and (car fcust) - (or eieio-custom-ignore-eieio-co - (not master-group) (member master-group (car fgroup))) - (slot-boundp obj (car slots))) - (progn - ;; Only customized slots have widgets - (let ((eieio-custom-ignore-eieio-co t)) - (eieio-oset obj (car slots) - (car (widget-apply (car chil) :value-inline)))) - (setq chil (cdr chil)))) - (setq slots (cdr slots) - fgroup (cdr fgroup) - fcust (cdr fcust))) + (while (and (< i (length slots)) chil) + (let* ((slot (aref slots i)) + (props (cl--slot-descriptor-props slot)) + (cust (alist-get :custom props))) + (if (and cust + (or eieio-custom-ignore-eieio-co + (not master-group) + (member master-group (alist-get :group props))) + (slot-boundp obj (cl--slot-descriptor-name slot))) + (progn + ;; Only customized slots have widgets + (let ((eieio-custom-ignore-eieio-co t)) + (eieio-oset obj (cl--slot-descriptor-name slot) + (car (widget-apply (car chil) :value-inline)))) + (setq chil (cdr chil)))))) ;; Set any name updates on it. (if name (eieio-object-set-name-string obj name)) ;; This is the same object we had before. @@ -452,7 +443,7 @@ Must return the created widget." (vector (concat "Group " (symbol-name group)) (list 'customize-object obj (list 'quote group)) t)) - (eieio--class-option (eieio--object-class-object obj) :custom-groups))) + (eieio--class-option (eieio--object-class obj) :custom-groups))) (defvar eieio-read-custom-group-history nil "History for the custom group reader.") @@ -460,7 +451,7 @@ Must return the created widget." (cl-defmethod eieio-read-customization-group ((obj eieio-default-superclass)) "Do a completing read on the name of a customization group in OBJ. Return the symbol for the group, or nil" - (let ((g (eieio--class-option (eieio--object-class-object obj) + (let ((g (eieio--class-option (eieio--object-class obj) :custom-groups))) (if (= (length g) 1) (car g) diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 82349192e5e..c820180359b 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el @@ -31,6 +31,9 @@ ;;; Code: +(declare-function data-debug/eieio-insert-slots "eieio-datadebug" + (obj eieio-default-superclass)) + (defun data-debug-insert-object-slots (object prefix) "Insert all the slots of OBJECT. PREFIX specifies what to insert at the start of each line." @@ -54,16 +57,17 @@ PREFIX specifies what to insert at the start of each line." "Insert a button representing OBJECT. PREFIX is the text that precedes the button. PREBUTTONTEXT is some text between PREFIX and the object button." - (let ((start (point)) - (end nil) - (str (object-print object)) - (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots" - (eieio-object-name-string object) - (eieio-object-class object) - (eieio-class-parents (eieio-object-class object)) - (length (object-slots object)) - )) - ) + (let* ((start (point)) + (end nil) + (str (object-print object)) + (class (eieio-object-class object)) + (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots" + (eieio-object-name-string object) + class + (eieio-class-parents class) + (length (eieio-class-slots class)) + )) + ) (insert prefix prebuttontext str) (setq end (point)) (put-text-property (- end (length str)) end 'face 'font-lock-keyword-face) @@ -80,41 +84,31 @@ PREBUTTONTEXT is some text between PREFIX and the object button." ;; Each object should have an opportunity to show stuff about itself. (cl-defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass) - prefix) + prefix) "Insert the slots of OBJ into the current DDEBUG buffer." (let ((inhibit-read-only t)) (data-debug-insert-thing (eieio-object-name-string obj) prefix "Name: ") - (let* ((cl (eieio-object-class obj)) - (cv (eieio--class-v cl))) - (data-debug-insert-thing (eieio--class-constructor cl) + (let* ((cv (eieio--object-class obj))) + (data-debug-insert-thing (eieio--class-name cv) prefix "Class: ") ;; Loop over all the public slots - (let ((publa (eieio--class-public-a cv)) - ) - (while publa - (if (slot-boundp obj (car publa)) - (let* ((i (eieio--class-slot-initarg (eieio--class-v cl) - (car publa))) - (v (eieio-oref obj (car publa)))) - (data-debug-insert-thing - v prefix (concat - (if i (symbol-name i) - (symbol-name (car publa))) - " "))) - ;; Unbound case - (let ((i (eieio--class-slot-initarg (eieio--class-v cl) - (car publa)))) - (data-debug-insert-custom - "#unbound" prefix - (concat (if i (symbol-name i) - (symbol-name (car publa))) - " ") - 'font-lock-keyword-face)) - ) - (setq publa (cdr publa))))))) + (let ((slots (eieio--class-slots cv))) + (dotimes (i (length slots)) + (let* ((slot (aref slots i)) + (sname (cl--slot-descriptor-name slot)) + (i (eieio--class-slot-initarg cv sname)) + (sstr (concat (symbol-name (or i sname)) " "))) + (if (slot-boundp obj sname) + (let* ((v (eieio-oref obj sname))) + (data-debug-insert-thing v prefix sstr)) + ;; Unbound case + (data-debug-insert-custom + "#unbound" prefix sstr + 'font-lock-keyword-face) + ))))))) ;;; Augment the Data debug thing display list. (data-debug-add-specialized-thing (lambda (thing) (eieio-object-p thing)) diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 304ee364dc8..7f98730340d 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -99,6 +99,7 @@ If CLASS is actually an object, then also display current values of that object. (when pl (insert " Inherits from ") (while (setq cur (pop pl)) + (setq cur (eieio--class-name cur)) (insert "`") (help-insert-xref-button (symbol-name cur) 'help-function cur) @@ -135,74 +136,40 @@ If CLASS is actually an object, then also display current values of that object. (or doc ""))) (insert "\n\n"))))) +(defun eieio--help-print-slot (slot) + (insert + (concat + (propertize "Slot: " 'face 'bold) + (prin1-to-string (cl--slot-descriptor-name slot)) + (unless (eq (cl--slot-descriptor-type slot) t) + (concat " type = " + (prin1-to-string (cl--slot-descriptor-type slot)))) + (unless (eq (cl--slot-descriptor-initform slot) eieio-unbound) + (concat " default = " + (prin1-to-string (cl--slot-descriptor-initform slot)))) + (when (alist-get :printer (cl--slot-descriptor-props slot)) + (concat " printer = " + (prin1-to-string + (alist-get :printer (cl--slot-descriptor-props slot))))) + (when (alist-get :documentation (cl--slot-descriptor-props slot)) + (concat "\n " (alist-get :documentation (cl--slot-descriptor-props slot)) + "\n"))) + "\n")) + (defun eieio-help-class-slots (class) "Print help description for the slots in CLASS. Outputs to the current buffer." (let* ((cv (eieio--class-v class)) - (docs (eieio--class-public-doc cv)) - (names (eieio--class-public-a cv)) - (deflt (eieio--class-public-d cv)) - (types (eieio--class-public-type cv)) - (publp (eieio--class-public-printer cv)) - (i 0) - (prot (eieio--class-protection cv)) - ) + (slots (eieio--class-slots cv)) + (cslots (eieio--class-class-slots cv))) (insert (propertize "Instance Allocated Slots:\n\n" 'face 'bold)) - (while names - (insert - (concat - (when (car prot) - (propertize "Private " 'face 'bold)) - (propertize "Slot: " 'face 'bold) - (prin1-to-string (car names)) - (unless (eq (aref types i) t) - (concat " type = " - (prin1-to-string (aref types i)))) - (unless (eq (car deflt) eieio-unbound) - (concat " default = " - (prin1-to-string (car deflt)))) - (when (car publp) - (concat " printer = " - (prin1-to-string (car publp)))) - (when (car docs) - (concat "\n " (car docs) "\n")) - "\n")) - (setq names (cdr names) - docs (cdr docs) - deflt (cdr deflt) - publp (cdr publp) - prot (cdr prot) - i (1+ i))) - (setq docs (eieio--class-class-allocation-doc cv) - names (eieio--class-class-allocation-a cv) - types (eieio--class-class-allocation-type cv) - i 0 - prot (eieio--class-class-allocation-protection cv)) - (when names + (dotimes (i (length slots)) + (eieio--help-print-slot (aref slots i))) + (when (> (length cslots) 0) (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))) - (while names - (insert - (concat - (when (car prot) - "Private ") - "Slot: " - (prin1-to-string (car names)) - (unless (eq (aref types i) t) - (concat " type = " - (prin1-to-string (aref types i)))) - (condition-case nil - (let ((value (eieio-oref class (car names)))) - (concat " value = " - (prin1-to-string value))) - (error nil)) - (when (car docs) - (concat "\n\n " (car docs) "\n")) - "\n")) - (setq names (cdr names) - docs (cdr docs) - prot (cdr prot) - i (1+ i))))) + (dotimes (i (length cslots)) + (eieio--help-print-slot (aref cslots i))))) (defun eieio-build-class-alist (&optional class instantiable-only buildlist) "Return an alist of all currently active classes for completion purposes. diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 526090954a9..bca53c0c892 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -130,7 +130,7 @@ and reference them using the function `class-option'." (error "Method invocation order %s is not allowed" io))) (let ((testsym1 (intern (concat (symbol-name name) "-p"))) - (testsym2 (intern (format "eieio--childp--%s" name))) + (testsym2 (intern (format "%s--eieio-childp" name))) (accessors ())) ;; Collect the accessors we need to define. @@ -272,34 +272,9 @@ This method is obsolete." ;; but hide it so we don't trigger indefinitely. `(,(car whole) (identity ,(car slots)) ,@(cdr slots))))))) - (apply #'eieio-constructor ',name slots)))))) + (apply #'make-instance ',name slots)))))) -;;; CLOS style implementation of object creators. -;; -(defun make-instance (class &rest initargs) - "Make a new instance of CLASS based on INITARGS. -CLASS is a class symbol. For example: - - (make-instance 'foo) - - INITARGS is a property list with keywords based on the :initarg -for each slot. For example: - - (make-instance 'foo :slot1 value1 :slotN valueN) - -Compatibility note: - -If the first element of INITARGS is a string, it is used as the -name of the class. - -In EIEIO, the class' constructor requires a name for use when printing. -`make-instance' in CLOS doesn't use names the way Emacs does, so the -class is used as the name slot instead when INITARGS doesn't start with -a string." - (apply (eieio--class-constructor class) initargs)) - - ;;; Get/Set slots in an object. ;; (defmacro oref (obj slot) @@ -311,6 +286,7 @@ created by the :initarg tag." (defalias 'slot-value 'eieio-oref) (defalias 'set-slot-value 'eieio-oset) +(make-obsolete 'set-slot-value "use (setf (slot-value ..) ..) instead" "25.1") (defmacro oref-default (obj slot) "Get the default value of OBJ (maybe a class) for SLOT. @@ -344,29 +320,69 @@ variable name of the same name as the slot." (declare (indent 2) (debug (sexp sexp def-body))) (require 'cl-lib) ;; Transform the spec-list into a cl-symbol-macrolet spec-list. - (let ((mappings (mapcar (lambda (entry) - (let ((var (if (listp entry) (car entry) entry)) - (slot (if (listp entry) (cadr entry) entry))) - (list var `(slot-value ,object ',slot)))) - spec-list))) - (append (list 'cl-symbol-macrolet mappings) - body))) + (macroexp-let2 nil object object + `(cl-symbol-macrolet + ,(mapcar (lambda (entry) + (let ((var (if (listp entry) (car entry) entry)) + (slot (if (listp entry) (cadr entry) entry))) + (list var `(slot-value ,object ',slot)))) + spec-list) + ,@body))) + +;; Keep it as a non-inlined function, so the internals of object don't get +;; hard-coded in random .elc files. +(defun eieio-pcase-slot-index-table (obj) + "Return some data structure from which can be extracted the slot offset." + (eieio--class-index-table + (symbol-value (eieio--object-class-tag obj)))) + +(defun eieio-pcase-slot-index-from-index-table (index-table slot) + "Find the index to pass to `aref' to access SLOT." + (let ((index (gethash slot index-table))) + (if index (+ (eval-when-compile + (length (cl-struct-slot-info 'eieio--object))) + index)))) + +(pcase-defmacro eieio (&rest fields) + "Pcase patterns to match EIEIO objects. +Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of +field NAME is matched against UPAT, or they can be of the form NAME which +is a shorthand for (NAME NAME)." + (let ((is (make-symbol "table"))) + ;; FIXME: This generates a horrendous mess of redundant let bindings. + ;; `pcase' needs to be improved somehow to introduce let-bindings more + ;; sparingly, or the byte-compiler needs to be taught to optimize + ;; them away. + ;; FIXME: `pcase' does not do a good job here of sharing tests&code among + ;; various branches. + `(and (pred eieio-object-p) + (app eieio-pcase-slot-index-table ,is) + ,@(mapcar (lambda (field) + (let* ((name (if (consp field) (car field) field)) + (pat (if (consp field) (cadr field) field)) + (i (make-symbol "index"))) + `(and (let (and ,i (pred natnump)) + (eieio-pcase-slot-index-from-index-table + ,is ',name)) + (app (pcase--flip aref ,i) ,pat)))) + fields)))) ;;; Simple generators, and query functions. None of these would do ;; well embedded into an object. ;; + (define-obsolete-function-alias - 'object-class-fast #'eieio--object-class-name "24.4") + 'object-class-fast #'eieio-object-class "24.4") (cl-defgeneric eieio-object-name-string (obj) "Return a string which is OBJ's name." (declare (obsolete eieio-named "25.1"))) (defun eieio-object-name (obj &optional extra) - "Return a Lisp like symbol string for object OBJ. + "Return a printed representation for object OBJ. If EXTRA, include that in the string returned to represent the symbol." (cl-check-type obj eieio-object) - (format "#<%s %s%s>" (eieio--object-class-name obj) + (format "#<%s %s%s>" (eieio-object-class obj) (eieio-object-name-string obj) (or extra ""))) (define-obsolete-function-alias 'object-name #'eieio-object-name "24.4") @@ -394,7 +410,7 @@ If EXTRA, include that in the string returned to represent the symbol." "Return the class struct defining OBJ." ;; FIXME: We say we return a "struct" but we return a symbol instead! (cl-check-type obj eieio-object) - (eieio--object-class-name obj)) + (eieio--class-name (eieio--object-class obj))) (define-obsolete-function-alias 'object-class #'eieio-object-class "24.4") ;; CLOS name, maybe? (define-obsolete-function-alias 'class-of #'eieio-object-class "24.4") @@ -402,7 +418,7 @@ If EXTRA, include that in the string returned to represent the symbol." (defun eieio-object-class-name (obj) "Return a Lisp like symbol name for OBJ's class." (cl-check-type obj eieio-object) - (eieio-class-name (eieio--object-class-name obj))) + (eieio-class-name (eieio--object-class obj))) (define-obsolete-function-alias 'object-class-name 'eieio-object-class-name "24.4") @@ -410,7 +426,7 @@ If EXTRA, include that in the string returned to represent the symbol." "Return parent classes to CLASS. (overload of variable). The CLOS function `class-direct-superclasses' is aliased to this function." - (eieio--class-parent (eieio--class-object class))) + (eieio--class-parents (eieio--class-object class))) (define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") @@ -438,13 +454,13 @@ The CLOS function `class-direct-subclasses' is aliased to this function." (setq class (eieio--class-object class)) (cl-check-type class eieio--class) (cl-check-type obj eieio-object) - (eq (eieio--object-class-object obj) class)) + (eq (eieio--object-class obj) class)) (defun object-of-class-p (obj class) "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." (cl-check-type obj eieio-object) ;; class will be checked one layer down - (child-of-class-p (eieio--object-class-object obj) class)) + (child-of-class-p (eieio--object-class obj) class)) ;; Backwards compatibility (defalias 'obj-of-class-p 'object-of-class-p) @@ -452,23 +468,37 @@ The CLOS function `class-direct-subclasses' is aliased to this function." "Return non-nil if CHILD class is a subclass of CLASS." (setq child (eieio--class-object child)) (cl-check-type child eieio--class) - ;; `eieio-default-superclass' is never mentioned in eieio--class-parent, + ;; `eieio-default-superclass' is never mentioned in eieio--class-parents, ;; so we have to special case it here. (or (eq class 'eieio-default-superclass) (let ((p nil)) (setq class (eieio--class-object class)) (cl-check-type class eieio--class) (while (and child (not (eq child class))) - (setq p (append p (eieio--class-parent child)) + (setq p (append p (eieio--class-parents child)) child (pop p))) (if child t)))) +(defun eieio-slot-descriptor-name (slot) + (cl--slot-descriptor-name slot)) + +(defun eieio-class-slots (class) + "Return list of slots available in instances of CLASS." + ;; FIXME: This only gives the instance slots and ignores the + ;; class-allocated slots. + (setq class (eieio--class-object class)) + (cl-check-type class eieio--class) + (mapcar #'identity (eieio--class-slots class))) + (defun object-slots (obj) - "Return list of slots available in OBJ." + "Return list of slot names available in OBJ." + (declare (obsolete eieio-class-slots "25.1")) (cl-check-type obj eieio-object) - (eieio--class-public-a (eieio--object-class-object obj))) + (mapcar #'cl--slot-descriptor-name + (eieio-class-slots (eieio--object-class obj)))) -(defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." +(defun eieio--class-slot-initarg (class slot) + "Fetch from CLASS, SLOT's :initarg." (cl-check-type class eieio--class) (let ((ia (eieio--class-initarg-tuples class)) (f nil)) @@ -518,12 +548,18 @@ OBJECT can be an instance or a class." (defun slot-exists-p (object-or-class slot) "Return non-nil if OBJECT-OR-CLASS has SLOT." (let ((cv (cond ((eieio-object-p object-or-class) - (eieio--object-class-object object-or-class)) + (eieio--object-class object-or-class)) ((eieio--class-p object-or-class) object-or-class) (t (find-class object-or-class 'error))))) - (or (memq slot (eieio--class-public-a cv)) - (memq slot (eieio--class-class-allocation-a cv))) - )) + (or (gethash slot (eieio--class-index-table cv)) + ;; FIXME: We could speed this up by adding class slots into the + ;; index-table (e.g. with a negative index?). + (let ((cs (eieio--class-class-slots cv)) + found) + (dotimes (i (length cs)) + (if (eq slot (cl--slot-descriptor-name (aref cs i))) + (setq found t))) + found)))) (defun find-class (symbol &optional errorp) "Return the class that SYMBOL represents. @@ -613,6 +649,9 @@ If SLOT is unbound, do nothing." ;;; Here are some CLOS items that need the CL package ;; +;; FIXME: Shouldn't this be a more complex gv-expander which extracts the +;; common code between oref and oset, so as to reduce the redundant work done +;; in (push foo (oref bar baz)), like we do for the `nth' expander? (gv-define-simple-setter eieio-oref eieio-oset) @@ -636,20 +675,28 @@ This class is not stored in the `parent' slot of a class vector." (defalias 'standard-class 'eieio-default-superclass) -(cl-defgeneric eieio-constructor (class &rest slots) - "Default constructor for CLASS `eieio-default-superclass'.") +(cl-defgeneric make-instance (class &rest initargs) + "Make a new instance of CLASS based on INITARGS. +For example: + + (make-instance 'foo) + +INITARGS is a property list with keywords based on the `:initarg' +for each slot. For example: + + (make-instance 'foo :slot1 value1 :slotN valueN)") -(define-obsolete-function-alias 'constructor #'eieio-constructor "25.1") +(define-obsolete-function-alias 'constructor #'make-instance "25.1") -(cl-defmethod eieio-constructor - ((class (subclass eieio-default-superclass)) &rest slots) +(cl-defmethod make-instance + ((class (subclass eieio-default-superclass)) &rest slots) "Default constructor for CLASS `eieio-default-superclass'. -SLOTS are the initialization slots used by `shared-initialize'. +SLOTS are the initialization slots used by `initialize-instance'. This static method is called when an object is constructed. It allocates the vector used to represent an EIEIO object, and then -calls `shared-initialize' on that object." +calls `initialize-instance' on that object." (let* ((new-object (copy-sequence (eieio--class-default-object-cache - (eieio--class-v class))))) + (eieio--class-object class))))) (if (and slots (let ((x (car slots))) (or (stringp x) (null x)))) @@ -662,6 +709,7 @@ calls `shared-initialize' on that object." ;; Return the created object. new-object)) +;; FIXME: CLOS uses "&rest INITARGS" instead. (cl-defgeneric shared-initialize (obj slots) "Set slots of OBJ with SLOTS which is a list of name/value pairs. Called from the constructor routine.") @@ -670,13 +718,14 @@ Called from the constructor routine.") "Set slots of OBJ with SLOTS which is a list of name/value pairs. Called from the constructor routine." (while slots - (let ((rn (eieio--initarg-to-attribute (eieio--object-class-object obj) + (let ((rn (eieio--initarg-to-attribute (eieio--object-class obj) (car slots)))) (if (not rn) (slot-missing obj (car slots) 'oset (car (cdr slots))) (eieio-oset obj rn (car (cdr slots))))) (setq slots (cdr (cdr slots))))) +;; FIXME: CLOS uses "&rest INITARGS" instead. (cl-defgeneric initialize-instance (this &optional slots) "Construct the new object THIS based on SLOTS.") @@ -692,10 +741,9 @@ not taken, then new objects of your class will not have their values dynamically set from SLOTS." ;; First, see if any of our defaults are `lambda', and ;; re-evaluate them and apply the value to our slots. - (let* ((this-class (eieio--object-class-object this)) - (slot (eieio--class-public-a this-class)) - (defaults (eieio--class-public-d this-class))) - (while slot + (let* ((this-class (eieio--object-class this)) + (slots (eieio--class-slots this-class))) + (dotimes (i (length slots)) ;; For each slot, see if we need to evaluate it. ;; ;; Paul Landes said in an email: @@ -703,12 +751,12 @@ dynamically set from SLOTS." ;; > the quoted thing as you already have. This is by the ;; > Sonya E. Keene book and other things I've look at on the ;; > web. - (let ((dflt (eieio-default-eval-maybe (car defaults)))) - (when (not (eq dflt (car defaults))) - (eieio-oset this (car slot) dflt) )) - ;; Next. - (setq slot (cdr slot) - defaults (cdr defaults)))) + (let* ((slot (aref slots i)) + (initform (cl--slot-descriptor-initform slot)) + (dflt (eieio-default-eval-maybe initform))) + (when (not (eq dflt initform)) + ;; FIXME: We should be able to just do (aset this (+ i <cst>) dflt)! + (eieio-oset this (cl--slot-descriptor-name slot) dflt))))) ;; Shared initialize will parse our slots for us. (shared-initialize this slots)) @@ -742,7 +790,8 @@ Use `slot-boundp' to determine if a slot is bound or not. In CLOS, the argument list is (CLASS OBJECT SLOT-NAME), but EIEIO can only dispatch on the first argument, so the first two are swapped." - (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object) + (signal 'unbound-slot (list (eieio-class-name class) + (eieio-object-name object) slot-name fn))) (cl-defgeneric clone (obj &rest params) @@ -824,32 +873,31 @@ this object." (prin1 (eieio-object-name-string this)) (princ "\n") ;; Loop over all the public slots - (let ((publa (eieio--class-public-a cv)) - (publd (eieio--class-public-d cv)) - (publp (eieio--class-public-printer cv)) + (let ((slots (eieio--class-slots cv)) (eieio-print-depth (1+ eieio-print-depth))) - (while publa - (when (slot-boundp this (car publa)) - (let ((i (eieio--class-slot-initarg cv (car publa))) - (v (eieio-oref this (car publa))) - ) - (unless (or (not i) (equal v (car publd))) - (unless (bolp) - (princ "\n")) - (princ (make-string (* eieio-print-depth 2) ? )) - (princ (symbol-name i)) - (if (car publp) - ;; Use our public printer - (progn - (princ " ") - (funcall (car publp) v)) - ;; Use our generic override prin1 function. - (princ (if (or (eieio-object-p v) - (eieio-object-p (car-safe v))) - "\n" " ")) - (eieio-override-prin1 v))))) - (setq publa (cdr publa) publd (cdr publd) - publp (cdr publp)))) + (dotimes (i (length slots)) + (let ((slot (aref slots i))) + (when (slot-boundp this (cl--slot-descriptor-name slot)) + (let ((i (eieio--class-slot-initarg + cv (cl--slot-descriptor-name slot))) + (v (eieio-oref this (cl--slot-descriptor-name slot)))) + (unless (or (not i) (equal v (cl--slot-descriptor-initform slot))) + (unless (bolp) + (princ "\n")) + (princ (make-string (* eieio-print-depth 2) ? )) + (princ (symbol-name i)) + (if (alist-get :printer (cl--slot-descriptor-props slot)) + ;; Use our public printer + (progn + (princ " ") + (funcall (alist-get :printer + (cl--slot-descriptor-props slot)) + v)) + ;; Use our generic override prin1 function. + (princ (if (or (eieio-object-p v) + (eieio-object-p (car-safe v))) + "\n" " ")) + (eieio-override-prin1 v)))))))) (princ ")") (when (= eieio-print-depth 0) (princ "\n")))) @@ -861,7 +909,7 @@ this object." ((consp thing) (eieio-list-prin1 thing)) ((eieio--class-p thing) - (princ (eieio-class-name thing))) + (princ (eieio--class-print-name thing))) (t (prin1 thing)))) (defun eieio-list-prin1 (list) @@ -902,7 +950,7 @@ of `eq'." Used as advice around `edebug-prin1-to-string', held in the variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate." - (cond ((eieio--class-p object) (eieio-class-name object)) + (cond ((eieio--class-p object) (eieio--class-print-name object)) ((eieio-object-p object) (object-print object)) ((and (listp object) (or (eieio--class-p (car object)) (eieio-object-p (car object)))) @@ -918,7 +966,7 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to ;;; Start of automatically extracted autoloads. -;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "2ec91e473fcad1ff20cd76edc4aab706") +;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "813d32fbf76d4248fc6b4dc97ebcd720") ;;; Generated autoloads from eieio-custom.el (autoload 'customize-object "eieio-custom" "\ @@ -929,7 +977,7 @@ Optional argument GROUP is the sub-group of slots to display. ;;;*** -;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "ff1097f185bc2c253276a7d19fe2f54a") +;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "3005b815c6b30eccbf0642170b3f82a5") ;;; Generated autoloads from eieio-opt.el (autoload 'eieio-browse "eieio-opt" "\ diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el new file mode 100644 index 00000000000..8251682590e --- /dev/null +++ b/lisp/emacs-lisp/generator.el @@ -0,0 +1,796 @@ +;;; generator.el --- generators -*- lexical-binding: t -*- + +;;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Daniel Colascione <dancol@dancol.org> +;; Keywords: extensions, elisp +;; Package: emacs + +;; 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 implements generators for Emacs Lisp through a +;; continuation-passing transformation. It provides essentially the +;; same generator API and iterator facilities that Python and +;; JavaScript ES6 provide. +;; +;; `iter-lambda' and `iter-defun' work like `lambda' and `defun', +;; except that they evaluate to or define, respectively, generator +;; functions. These functions, when called, return an iterator. +;; An iterator is an opaque object that generates a sequence of +;; values. Callers use `iter-next' to retrieve the next value from +;; the sequence; when the sequence is exhausted, `iter-next' will +;; raise the `iter-end-of-sequence' condition. +;; +;; Generator functions are written like normal functions, except that +;; they can invoke `iter-yield' to suspend themselves and return a +;; value to callers; this value becomes the return value of +;; `iter-next'. On the next call to `iter-next', execution of the +;; generator function resumes where it left off. When a generator +;; function returns normally, the `iter-next' raises +;; `iter-end-of-sequence' with the value the function returned. +;; +;; `iter-yield-from' yields all the values from another iterator; it +;; then evaluates to the value the sub-iterator returned normally. +;; This facility is useful for functional composition of generators +;; and for implementing coroutines. +;; +;; `iter-yield' is illegal inside the UNWINDFORMS of an +;; `unwind-protect' for various sordid internal reasons documented in +;; the code. +;; +;; N.B. Each call to a generator function generates a *new* iterator, +;; and each iterator maintains its own internal state. +;; +;; This raw form of iteration is general, but a bit awkward to use, so +;; this library also provides some convenience functions: +;; +;; `iter-do' is like `cl-do', except that instead of walking a list, +;; it walks an iterator. `cl-loop' is also extended with a new +;; keyword, `iter-by', that iterates over an iterator. +;; + +;;; Implementation: + +;; +;; The internal cps transformation code uses the cps- namespace. +;; Iteration functions use the `iter-' namespace. Generator functions +;; are somewhat less efficient than conventional elisp routines, +;; although we try to avoid CPS transformation on forms that do not +;; invoke `iter-yield'. +;; + +;;; Code: + +(require 'cl-lib) +(require 'pcase) + +(defvar cps--bindings nil) +(defvar cps--states nil) +(defvar cps--value-symbol nil) +(defvar cps--state-symbol nil) +(defvar cps--cleanup-table-symbol nil) +(defvar cps--cleanup-function nil) + +(defmacro cps--gensym (fmt &rest args) + ;; Change this function to use `cl-gensym' if you want the generated + ;; code to be easier to read and debug. + ;; (cl-gensym (apply #'format fmt args)) + `(make-symbol ,fmt)) + +(defvar cps--dynamic-wrappers '(identity) + "List of transformer functions to apply to atomic forms we +evaluate in CPS context.") + +(defconst cps-standard-special-forms + '(setq setq-default throw interactive) + "List of special forms that we treat just like ordinary + function applications." ) + +(defun cps--trace-funcall (func &rest args) + (message "%S: args=%S" func args) + (let ((result (apply func args))) + (message "%S: result=%S" func result) + result)) + +(defun cps--trace (fmt &rest args) + (princ (apply #'format (concat fmt "\n") args))) + +(defun cps--special-form-p (definition) + "Non-nil if and only if DEFINITION is a special form." + ;; Copied from ad-special-form-p + (if (and (symbolp definition) (fboundp definition)) + (setf definition (indirect-function definition))) + (and (subrp definition) (eq (cdr (subr-arity definition)) 'unevalled))) + +(defmacro cps--define-unsupported (function) + `(defun ,(intern (format "cps--transform-%s" function)) + (error "%s not supported in generators" ,function))) + +(defmacro cps--with-value-wrapper (wrapper &rest body) + "Continue generating CPS code with an atomic-form wrapper +to the current stack of such wrappers. WRAPPER is a function that +takes a form and returns a wrapped form. + +Whenever we generate an atomic form (i.e., a form that can't +iter-yield), we first (before actually inserting that form in our +generated code) pass that form through all the transformer +functions. We use this facility to wrap forms that can transfer +control flow non-locally in goo that diverts this control flow to +the CPS state machinery. +" + (declare (indent 1)) + `(let ((cps--dynamic-wrappers + (cons + ,wrapper + cps--dynamic-wrappers))) + ,@body)) + +(defun cps--make-dynamic-binding-wrapper (dynamic-var static-var) + (cl-assert lexical-binding) + (lambda (form) + `(let ((,dynamic-var ,static-var)) + (unwind-protect ; Update the static shadow after evaluation is done + ,form + (setf ,static-var ,dynamic-var)) + ,form))) + +(defmacro cps--with-dynamic-binding (dynamic-var static-var &rest body) + "Evaluate BODY such that generated atomic evaluations run with +DYNAMIC-VAR bound to STATIC-VAR." + (declare (indent 2)) + `(cps--with-value-wrapper + (cps--make-dynamic-binding-wrapper ,dynamic-var ,static-var) + ,@body)) + +(defun cps--add-state (kind body) + "Create a new CPS state with body BODY and return the state's name." + (declare (indent 1)) + (let* ((state (cps--gensym "cps-state-%s-" kind))) + (push (list state body cps--cleanup-function) cps--states) + (push state cps--bindings) + state)) + +(defun cps--add-binding (original-name) + (car (push (cps--gensym (format "cps-binding-%s-" original-name)) + cps--bindings))) + +(defun cps--find-special-form-handler (form) + (let* ((handler-name (format "cps--transform-%s" (car-safe form))) + (handler (intern-soft handler-name))) + (and (fboundp handler) handler))) + +(defvar cps-inhibit-atomic-optimization nil + "When t, always rewrite forms into cps even when they +don't yield.") + +(defvar cps--yield-seen) + +(defun cps--atomic-p (form) + "Return whether the given form never yields." + + (and (not cps-inhibit-atomic-optimization) + (let* ((cps--yield-seen)) + (ignore (macroexpand-all + `(cl-macrolet ((cps-internal-yield + (_val) + (setf cps--yield-seen t))) + ,form) + macroexpand-all-environment)) + (not cps--yield-seen)))) + +(defun cps--make-atomic-state (form next-state) + (let ((tform `(prog1 ,form (setf ,cps--state-symbol ,next-state)))) + (cl-loop for wrapper in cps--dynamic-wrappers + do (setf tform (funcall wrapper tform))) + ;; Bind cps--cleanup-function to nil here because the wrapper + ;; function mechanism is responsible for cleanup here, not the + ;; generic cleanup mechanism. If we didn't make this binding, + ;; we'd run cleanup handlers twice on anything that made it out + ;; to toplevel. + (let ((cps--cleanup-function nil)) + (cps--add-state "atom" + `(setf ,cps--value-symbol ,tform))))) + +(defun cps--transform-1 (form next-state) + (pcase form + + ;; If we're looking at an "atomic" form (i.e., one that does not + ;; iter-yield), just evaluate the form as a whole instead of rewriting + ;; it into CPS. + + ((guard (cps--atomic-p form)) + (cps--make-atomic-state form next-state)) + + ;; Process `and'. + + (`(and) ; (and) -> t + (cps--transform-1 t next-state)) + (`(and ,condition) ; (and CONDITION) -> CONDITION + (cps--transform-1 condition next-state)) + (`(and ,condition . ,rest) + ;; Evaluate CONDITION; if it's true, go on to evaluate the rest + ;; of the `and'. + (cps--transform-1 + condition + (cps--add-state "and" + `(setf ,cps--state-symbol + (if ,cps--value-symbol + ,(cps--transform-1 `(and ,@rest) + next-state) + ,next-state))))) + + ;; Process `catch'. + + (`(catch ,tag . ,body) + (let ((tag-binding (cps--add-binding "catch-tag"))) + (cps--transform-1 tag + (cps--add-state "cps-update-tag" + `(setf ,tag-binding ,cps--value-symbol + ,cps--state-symbol + ,(cps--with-value-wrapper + (cps--make-catch-wrapper + tag-binding next-state) + (cps--transform-1 `(progn ,@body) + next-state))))))) + + ;; Process `cond': transform into `if' or `or' depending on the + ;; precise kind of the condition we're looking at. + + (`(cond) ; (cond) -> nil + (cps--transform-1 nil next-state)) + (`(cond (,condition) . ,rest) + (cps--transform-1 `(or ,condition (cond ,@rest)) + next-state)) + (`(cond (,condition . ,body) . ,rest) + (cps--transform-1 `(if ,condition + (progn ,@body) + (cond ,@rest)) + next-state)) + + ;; Process `condition-case': do the heavy lifting in a helper + ;; function. + + (`(condition-case ,var ,bodyform . ,handlers) + (cps--with-value-wrapper + (cps--make-condition-wrapper var next-state handlers) + (cps--transform-1 bodyform + next-state))) + + ;; Process `if'. + + (`(if ,cond ,then . ,else) + (cps--transform-1 cond + (cps--add-state "if" + `(setf ,cps--state-symbol + (if ,cps--value-symbol + ,(cps--transform-1 then + next-state) + ,(cps--transform-1 `(progn ,@else) + next-state)))))) + + ;; Process `progn' and `inline': they are identical except for the + ;; name, which has some significance to the byte compiler. + + (`(inline) (cps--transform-1 nil next-state)) + (`(inline ,form) (cps--transform-1 form next-state)) + (`(inline ,form . ,rest) + (cps--transform-1 form + (cps--transform-1 `(inline ,@rest) + next-state))) + + (`(progn) (cps--transform-1 nil next-state)) + (`(progn ,form) (cps--transform-1 form next-state)) + (`(progn ,form . ,rest) + (cps--transform-1 form + (cps--transform-1 `(progn ,@rest) + next-state))) + + ;; Process `let' in a helper function that transforms it into a + ;; let* with temporaries. + + (`(let ,bindings . ,body) + (let* ((bindings (cl-loop for binding in bindings + collect (if (symbolp binding) + (list binding nil) + binding))) + (temps (cl-loop for (var value-form) in bindings + collect (cps--add-binding var)))) + (cps--transform-1 + `(let* ,(append + (cl-loop for (var value-form) in bindings + for temp in temps + collect (list temp value-form)) + (cl-loop for (var binding) in bindings + for temp in temps + collect (list var temp))) + ,@body) + next-state))) + + ;; Process `let*' binding: process one binding at a time. Flatten + ;; lexical bindings. + + (`(let* () . ,body) + (cps--transform-1 `(progn ,@body) next-state)) + + (`(let* (,binding . ,more-bindings) . ,body) + (let* ((var (if (symbolp binding) binding (car binding))) + (value-form (car (cdr-safe binding))) + (new-var (cps--add-binding var))) + + (cps--transform-1 + value-form + (cps--add-state "let*" + `(setf ,new-var ,cps--value-symbol + ,cps--state-symbol + ,(if (or (not lexical-binding) (special-variable-p var)) + (cps--with-dynamic-binding var new-var + (cps--transform-1 + `(let* ,more-bindings ,@body) + next-state)) + (cps--transform-1 + (cps--replace-variable-references + var new-var + `(let* ,more-bindings ,@body)) + next-state))))))) + + ;; Process `or'. + + (`(or) (cps--transform-1 nil next-state)) + (`(or ,condition) (cps--transform-1 condition next-state)) + (`(or ,condition . ,rest) + (cps--transform-1 + condition + (cps--add-state "or" + `(setf ,cps--state-symbol + (if ,cps--value-symbol + ,next-state + ,(cps--transform-1 + `(or ,@rest) next-state)))))) + + ;; Process `prog1'. + + (`(prog1 ,first) (cps--transform-1 first next-state)) + (`(prog1 ,first . ,body) + (cps--transform-1 + first + (let ((temp-var-symbol (cps--add-binding "prog1-temp"))) + (cps--add-state "prog1" + `(setf ,temp-var-symbol + ,cps--value-symbol + ,cps--state-symbol + ,(cps--transform-1 + `(progn ,@body) + (cps--add-state "prog1inner" + `(setf ,cps--value-symbol ,temp-var-symbol + ,cps--state-symbol ,next-state)))))))) + + ;; Process `prog2'. + + (`(prog2 ,form1 ,form2 . ,body) + (cps--transform-1 + `(progn ,form1 (prog1 ,form2 ,@body)) + next-state)) + + ;; Process `unwind-protect': If we're inside an unwind-protect, we + ;; have a block of code UNWINDFORMS which we would like to run + ;; whenever control flows away from the main piece of code, + ;; BODYFORM. We deal with the local control flow case by + ;; generating BODYFORM such that it yields to a continuation that + ;; executes UNWINDFORMS, which then yields to NEXT-STATE. + ;; + ;; Non-local control flow is trickier: we need to ensure that we + ;; execute UNWINDFORMS even when control bypasses our normal + ;; continuation. To make this guarantee, we wrap every external + ;; application (i.e., every piece of elisp that can transfer + ;; control non-locally) in an unwind-protect that runs UNWINDFORMS + ;; before allowing the non-local control transfer to proceed. + ;; + ;; Unfortunately, because elisp lacks a mechanism for generically + ;; capturing the reason for an arbitrary non-local control + ;; transfer and restarting the transfer at a later point, we + ;; cannot reify non-local transfers and cannot allow + ;; continuation-passing code inside UNWINDFORMS. + + (`(unwind-protect ,bodyform . ,unwindforms) + ;; Signal the evaluator-generator that it needs to generate code + ;; to handle cleanup forms. + (unless cps--cleanup-table-symbol + (setf cps--cleanup-table-symbol (cps--gensym "cps-cleanup-table-"))) + (let* ((unwind-state + (cps--add-state + "unwind" + ;; N.B. It's safe to just substitute unwindforms by + ;; sexp-splicing: we've already replaced all variable + ;; references inside it with lifted equivalents. + `(progn + ,@unwindforms + (setf ,cps--state-symbol ,next-state)))) + (old-cleanup cps--cleanup-function) + (cps--cleanup-function + (let ((cps--cleanup-function nil)) + (cps--add-state "cleanup" + `(progn + ,(when old-cleanup `(funcall ,old-cleanup)) + ,@unwindforms))))) + (cps--with-value-wrapper + (cps--make-unwind-wrapper unwindforms) + (cps--transform-1 bodyform unwind-state)))) + + ;; Process `while'. + + (`(while ,test . ,body) + ;; Open-code state addition instead of using cps--add-state: we + ;; need our states to be self-referential. (That's what makes the + ;; state a loop.) + (let* ((loop-state + (cps--gensym "cps-state-while-")) + (eval-loop-condition-state + (cps--transform-1 test loop-state)) + (loop-state-body + `(progn + (setf ,cps--state-symbol + (if ,cps--value-symbol + ,(cps--transform-1 + `(progn ,@body) + eval-loop-condition-state) + ,next-state))))) + (push (list loop-state loop-state-body cps--cleanup-function) + cps--states) + (push loop-state cps--bindings) + eval-loop-condition-state)) + + ;; Process various kinds of `quote'. + + (`(quote ,arg) (cps--add-state "quote" + `(setf ,cps--value-symbol (quote ,arg) + ,cps--state-symbol ,next-state))) + (`(function ,arg) (cps--add-state "function" + `(setf ,cps--value-symbol (function ,arg) + ,cps--state-symbol ,next-state))) + + ;; Deal with `iter-yield'. + + (`(cps-internal-yield ,value) + (cps--transform-1 + value + (cps--add-state "iter-yield" + `(progn + (setf ,cps--state-symbol + ,(if cps--cleanup-function + (cps--add-state "after-yield" + `(setf ,cps--state-symbol ,next-state)) + next-state)) + (throw 'cps--yield ,cps--value-symbol))))) + + ;; Catch any unhandled special forms. + + ((and `(,name . ,_) + (guard (cps--special-form-p name)) + (guard (not (memq name cps-standard-special-forms)))) + name ; Shut up byte compiler + (error "special form %S incorrect or not supported" form)) + + ;; Process regular function applications with nontrivial + ;; parameters, converting them to applications of trivial + ;; let-bound parameters. + + ((and `(,function . ,arguments) + (guard (not (cl-loop for argument in arguments + always (atom argument))))) + (let ((argument-symbols + (cl-loop for argument in arguments + collect (if (atom argument) + argument + (cps--gensym "cps-argument-"))))) + + (cps--transform-1 + `(let* ,(cl-loop for argument in arguments + for argument-symbol in argument-symbols + unless (eq argument argument-symbol) + collect (list argument-symbol argument)) + ,(cons function argument-symbols)) + next-state))) + + ;; Process everything else by just evaluating the form normally. + (t (cps--make-atomic-state form next-state)))) + +(defun cps--make-catch-wrapper (tag-binding next-state) + (lambda (form) + (let ((normal-exit-symbol + (cps--gensym "cps-normal-exit-from-catch-"))) + `(let (,normal-exit-symbol) + (prog1 + (catch ,tag-binding + (prog1 + ,form + (setf ,normal-exit-symbol t))) + (unless ,normal-exit-symbol + (setf ,cps--state-symbol ,next-state))))))) + +(defun cps--make-condition-wrapper (var next-state handlers) + ;; Each handler is both one of the transformers with which we wrap + ;; evaluated atomic forms and a state to which we jump when we + ;; encounter the given error. + + (let* ((error-symbol (cps--add-binding "condition-case-error")) + (lexical-error-symbol (cps--gensym "cps-lexical-error-")) + (processed-handlers + (cl-loop for (condition . body) in handlers + collect (cons condition + (cps--transform-1 + (cps--replace-variable-references + var error-symbol + `(progn ,@body)) + next-state))))) + + (lambda (form) + `(condition-case + ,lexical-error-symbol + ,form + ,@(cl-loop + for (condition . error-state) in processed-handlers + collect + `(,condition + (setf ,error-symbol + ,lexical-error-symbol + ,cps--state-symbol + ,error-state))))))) + +(defun cps--replace-variable-references (var new-var form) + "Replace all non-shadowed references to VAR with NEW-VAR in FORM. +This routine does not modify FORM. Instead, it returns a +modified copy." + (macroexpand-all + `(cl-symbol-macrolet ((,var ,new-var)) ,form) + macroexpand-all-environment)) + +(defun cps--make-unwind-wrapper (unwind-forms) + (cl-assert lexical-binding) + (lambda (form) + (let ((normal-exit-symbol + (cps--gensym "cps-normal-exit-from-unwind-"))) + `(let (,normal-exit-symbol) + (unwind-protect + (prog1 + ,form + (setf ,normal-exit-symbol t)) + (unless ,normal-exit-symbol + ,@unwind-forms)))))) + +(put 'iter-end-of-sequence 'error-conditions '(iter-end-of-sequence)) +(put 'iter-end-of-sequence 'error-message "iteration terminated") + +(defun cps--make-close-iterator-form (terminal-state) + (if cps--cleanup-table-symbol + `(let ((cleanup (cdr (assq ,cps--state-symbol ,cps--cleanup-table-symbol)))) + (setf ,cps--state-symbol ,terminal-state + ,cps--value-symbol nil) + (when cleanup (funcall cleanup))) + `(setf ,cps--state-symbol ,terminal-state + ,cps--value-symbol nil))) + +(defun cps-generate-evaluator (body) + (let* (cps--states + cps--bindings + cps--cleanup-function + (cps--value-symbol (cps--gensym "cps-current-value-")) + (cps--state-symbol (cps--gensym "cps-current-state-")) + ;; We make *cps-cleanup-table-symbol** non-nil when we notice + ;; that we have cleanup processing to perform. + (cps--cleanup-table-symbol nil) + (terminal-state (cps--add-state "terminal" + `(signal 'iter-end-of-sequence + ,cps--value-symbol))) + (initial-state (cps--transform-1 + (macroexpand-all + `(cl-macrolet + ((iter-yield (value) + `(cps-internal-yield ,value))) + ,@body) + macroexpand-all-environment) + terminal-state)) + (finalizer-symbol + (when cps--cleanup-table-symbol + (when cps--cleanup-table-symbol + (cps--gensym "cps-iterator-finalizer-"))))) + `(let ,(append (list cps--state-symbol cps--value-symbol) + (when cps--cleanup-table-symbol + (list cps--cleanup-table-symbol)) + (when finalizer-symbol + (list finalizer-symbol)) + (nreverse cps--bindings)) + ;; Order state list so that cleanup states are always defined + ;; before they're referenced. + ,@(cl-loop for (state body cleanup) in (nreverse cps--states) + collect `(setf ,state (lambda () ,body)) + when cleanup + do (cl-assert cps--cleanup-table-symbol) + and collect `(push (cons ,state ,cleanup) ,cps--cleanup-table-symbol)) + (setf ,cps--state-symbol ,initial-state) + + (let ((iterator + (lambda (op value) + (cond + ,@(when finalizer-symbol + `(((eq op :stash-finalizer) + (setf ,finalizer-symbol value)) + ((eq op :get-finalizer) + ,finalizer-symbol))) + ((eq op :close) + ,(cps--make-close-iterator-form terminal-state)) + ((eq op :next) + (setf ,cps--value-symbol value) + (let ((yielded nil)) + (unwind-protect + (prog1 + (catch 'cps--yield + (while t + (funcall ,cps--state-symbol))) + (setf yielded t)) + (unless yielded + ;; If we're exiting non-locally (error, quit, + ;; etc.) close the iterator. + ,(cps--make-close-iterator-form terminal-state))))) + (t (error "unknown iterator operation %S" op)))))) + ,(when finalizer-symbol + `(funcall iterator + :stash-finalizer + (make-finalizer + (lambda () + (iter-close iterator))))) + iterator)))) + +(defun iter-yield (value) + "When used inside a generator, yield control to caller. +The caller of `iter-next' receives VALUE, and the next call to +`iter-next' resumes execution at the previous +`iter-yield' point." + (identity value) + (error "`iter-yield' used outside a generator")) + +(defmacro iter-yield-from (value) + "When used inside a generator function, delegate to a sub-iterator. +The values that the sub-iterator yields are passed directly to +the caller, and values supplied to `iter-next' are sent to the +sub-iterator. `iter-yield-from' evaluates to the value that the +sub-iterator function returns via `iter-end-of-sequence'." + (let ((errsym (cps--gensym "yield-from-result")) + (valsym (cps--gensym "yield-from-value"))) + `(let ((,valsym ,value)) + (unwind-protect + (condition-case ,errsym + (let ((vs nil)) + (while t + (setf vs (iter-yield (iter-next ,valsym vs))))) + (iter-end-of-sequence (cdr ,errsym))) + (iter-close ,valsym))))) + +(defmacro iter-defun (name arglist &rest body) + "Creates a generator NAME. +When called as a function, NAME returns an iterator value that +encapsulates the state of a computation that produces a sequence +of values. Callers can retrieve each value using `iter-next'." + (declare (indent defun)) + (cl-assert lexical-binding) + (let* ((parsed-body (macroexp-parse-body body)) + (declarations (car parsed-body)) + (exps (cdr parsed-body))) + `(defun ,name ,arglist + ,@declarations + ,(cps-generate-evaluator exps)))) + +(defmacro iter-lambda (arglist &rest body) + "Return a lambda generator. +`iter-lambda' is to `iter-defun' as `lambda' is to `defun'." + (declare (indent defun)) + (cl-assert lexical-binding) + `(lambda ,arglist + ,(cps-generate-evaluator body))) + +(defun iter-next (iterator &optional yield-result) + "Extract a value from an iterator. +YIELD-RESULT becomes the return value of `iter-yield` in the +context of the generator. + +This routine raises the `iter-end-of-sequence' condition if the +iterator cannot supply more values." + (funcall iterator :next yield-result)) + +(defun iter-close (iterator) + "Terminate an iterator early. +Run any unwind-protect handlers in scope at the point ITERATOR +is blocked." + (funcall iterator :close nil)) + +(cl-defmacro iter-do ((var iterator) &rest body) + "Loop over values from an iterator. +Evaluate BODY with VAR bound to each value from ITERATOR. +Return the value with which ITERATOR finished iteration." + (declare (indent 1)) + (let ((done-symbol (cps--gensym "iter-do-iterator-done")) + (condition-symbol (cps--gensym "iter-do-condition")) + (it-symbol (cps--gensym "iter-do-iterator")) + (result-symbol (cps--gensym "iter-do-result"))) + `(let (,var + ,result-symbol + (,done-symbol nil) + (,it-symbol ,iterator)) + (while (not ,done-symbol) + (condition-case ,condition-symbol + (setf ,var (iter-next ,it-symbol)) + (iter-end-of-sequence + (setf ,result-symbol (cdr ,condition-symbol)) + (setf ,done-symbol t))) + (unless ,done-symbol ,@body)) + ,result-symbol))) + +(defvar cl--loop-args) + +(defmacro cps--advance-for (conscell) + ;; See cps--handle-loop-for + `(condition-case nil + (progn + (setcar ,conscell (iter-next (cdr ,conscell))) + ,conscell) + (iter-end-of-sequence + nil))) + +(defmacro cps--initialize-for (iterator) + ;; See cps--handle-loop-for + (let ((cs (cps--gensym "cps--loop-temp"))) + `(let ((,cs (cons nil ,iterator))) + (cps--advance-for ,cs)))) + +(defun cps--handle-loop-for (var) + "Support `iter-by' in `loop'. " + ;; N.B. While the cl-loop-for-handler is a documented interface, + ;; there's no documented way for cl-loop-for-handler callbacks to do + ;; anything useful! Additionally, cl-loop currently lexbinds useful + ;; internal variables, so our only option is to modify + ;; cl--loop-args. If we substitute a general-purpose for-clause for + ;; our iterating clause, however, we can't preserve the + ;; parallel-versus-sequential `loop' semantics for for clauses --- + ;; we need a terminating condition as well, which requires us to use + ;; while, and inserting a while would break and-sequencing. + ;; + ;; To work around this problem, we actually use the "for var in LIST + ;; by FUNCTION" syntax, creating a new fake list each time through + ;; the loop, this "list" being a cons cell (val . it). + (let ((it-form (pop cl--loop-args))) + (setf cl--loop-args + (append + `(for ,var + in (cps--initialize-for ,it-form) + by 'cps--advance-for) + cl--loop-args)))) + +(put 'iter-by 'cl-loop-for-handler 'cps--handle-loop-for) + +(eval-after-load 'elisp-mode + (lambda () + (font-lock-add-keywords + 'emacs-lisp-mode + '(("(\\(iter-defun\\)\\_>\\s *\\(\\(?:\\sw\\|\\s_\\)+\\)?" + (1 font-lock-keyword-face nil t) + (2 font-lock-function-name-face nil t)) + ("(\\(iter-\\(?:next\\|lambda\\|yield\\|yield-from\\)\\)\\_>" + (1 font-lock-keyword-face nil t)))))) + +(provide 'generator) + +;;; generator.el ends here diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 5d6e6e1b372..fae3bcb86f6 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -493,9 +493,20 @@ This is like the `&' operator of the C language. Note: this only works reliably with lexical binding mode, except for very simple PLACEs such as (function-symbol 'foo) which will also work in dynamic binding mode." - (gv-letplace (getter setter) place - `(cons (lambda () ,getter) - (lambda (gv--val) ,(funcall setter 'gv--val))))) + (let ((code + (gv-letplace (getter setter) place + `(cons (lambda () ,getter) + (lambda (gv--val) ,(funcall setter 'gv--val)))))) + (if (or lexical-binding + ;; If `code' still starts with `cons' then presumably gv-letplace + ;; did not add any new let-bindings, so the `lambda's don't capture + ;; any new variables. As a consequence, the code probably works in + ;; dynamic binding mode as well. + (eq (car-safe code) 'cons)) + code + (macroexp--warn-and-return + "Use of gv-ref probably requires lexical-binding" + code)))) (defsubst gv-deref (ref) "Dereference REF, returning the referenced value. diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index f9874d83bb3..fec172d05ca 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -436,8 +436,10 @@ This can be found in an RCS or SCCS header." ;; Look for an SCCS header ((re-search-forward (concat - (regexp-quote "@(#)") - (regexp-quote (file-name-nondirectory (buffer-file-name))) + "@(#)" + (if buffer-file-name + (regexp-quote (file-name-nondirectory buffer-file-name)) + "[^\t\n]*") "\t\\([012345679.]*\\)") header-max t) (match-string-no-properties 1))))))) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 5d912097838..4c9a39fe174 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -181,6 +181,63 @@ nil))) res)) +(defun lisp--el-non-funcall-position-p (&optional pos) + "Heuristically determine whether POS is an evaluated position." + (setf pos (or pos (point))) + (save-match-data + (save-excursion + (ignore-errors + (goto-char pos) + (or (eql (char-before) ?\') + (let ((parent + (progn + (up-list -1) + (cond + ((ignore-errors + (and (eql (char-after) ?\() + (progn + (up-list -1) + (looking-at "(\\_<let\\*?\\_>")))) + (goto-char (match-end 0)) + 'let) + ((looking-at + (rx "(" + (group-n 1 (+ (or (syntax w) (syntax _)))) + symbol-end)) + (prog1 (intern-soft (match-string-no-properties 1)) + (goto-char (match-end 1)))))))) + (or (eq parent 'declare) + (and (eq parent 'let) + (progn + (forward-sexp 1) + (< pos (point)))) + (and (eq parent 'condition-case) + (progn + (forward-sexp 2) + (< (point) pos)))))))))) + +(defun lisp--el-match-keyword (limit) + (catch 'found + (while (re-search-forward "(\\(\\(?:\\sw\\|\\s_\\)+\\)\\_>" limit t) + (let ((sym (intern-soft (match-string 1)))) + (when (or (special-form-p sym) + (and (macrop sym) + (not (get sym 'no-font-lock-keyword)) + (not (lisp--el-non-funcall-position-p + (match-beginning 0))))) + (throw 'found t)))))) + +(defun lisp--el-font-lock-flush-elisp-buffers (&optional file) + ;; Don't flush during load unless called from after-load-functions. + ;; In that case, FILE is non-nil. It's somehow strange that + ;; load-in-progress is t when an after-load-function is called since + ;; that should run *after* the load... + (when (or (not load-in-progress) file) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (derived-mode-p 'emacs-lisp-mode) + (font-lock-flush)))))) + (pcase-let ((`(,vdefs ,tdefs ,el-defs-re ,cl-defs-re @@ -194,7 +251,9 @@ "when" "unless" "with-output-to-string" "ignore-errors" "dotimes" "dolist" "declare")) (lisp-errs '("warn" "error" "signal")) - ;; Elisp constructs. FIXME: update dynamically from obarray. + ;; Elisp constructs. Now they are update dynamically + ;; from obarray but they are also used for setting up + ;; the keywords for Common Lisp. (el-fdefs '("define-advice" "defadvice" "defalias" "define-derived-mode" "define-minor-mode" "define-generic-mode" "define-global-minor-mode" @@ -227,7 +286,7 @@ (eieio-tdefs '("defclass")) (eieio-kw '("with-slots")) ;; Common-Lisp constructs supported by cl-lib. - (cl-lib-fdefs '("defmacro" "defsubst" "defun")) + (cl-lib-fdefs '("defmacro" "defsubst" "defun" "defmethod")) (cl-lib-tdefs '("defstruct" "deftype")) (cl-lib-kw '("progv" "eval-when" "case" "ecase" "typecase" "etypecase" "ccase" "ctypecase" "loop" "do" "do*" @@ -298,14 +357,21 @@ `( ;; Definitions. (,(concat "(" el-defs-re "\\_>" ;; Any whitespace and defined object. - "[ \t'\(]*" - "\\(\\(?:\\sw\\|\\s_\\)+\\)?") + "[ \t']*" + "\\(([ \t']*\\)?" ;; An opening paren. + "\\(\\(setf\\)[ \t]+\\(?:\\sw\\|\\s_\\)+\\|\\(?:\\sw\\|\\s_\\)+\\)?") (1 font-lock-keyword-face) - (2 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) - (cond ((eq type 'var) font-lock-variable-name-face) - ((eq type 'type) font-lock-type-face) - (t font-lock-function-name-face))) - nil t)) + (3 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) + (cond ((eq type 'var) font-lock-variable-name-face) + ((eq type 'type) font-lock-type-face) + ;; If match-string 2 is non-nil, we encountered a + ;; form like (defalias (intern (concat s "-p"))), + ;; unless match-string 4 is also there. Then its a + ;; defmethod with (setf foo) as name. + ((or (not (match-string 2)) ;; Normal defun. + (and (match-string 2) ;; Setf method. + (match-string 4))) font-lock-function-name-face))) + nil t)) ;; Emacs Lisp autoload cookies. Supports the slightly different ;; forms used by mh-e, calendar, etc. ("^;;;###\\([-a-z]*autoload\\)" 1 font-lock-warning-face prepend)) @@ -315,13 +381,16 @@ `( ;; Definitions. (,(concat "(" cl-defs-re "\\_>" ;; Any whitespace and defined object. - "[ \t'\(]*" - "\\(setf[ \t]+\\(?:\\sw\\|\\s_\\)+\\|\\(?:\\sw\\|\\s_\\)+\\)?") + "[ \t']*" + "\\(([ \t']*\\)?" ;; An opening paren. + "\\(\\(setf\\)[ \t]+\\(?:\\sw\\|\\s_\\)+\\|\\(?:\\sw\\|\\s_\\)+\\)?") (1 font-lock-keyword-face) - (2 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) + (3 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) (cond ((eq type 'var) font-lock-variable-name-face) ((eq type 'type) font-lock-type-face) - (t font-lock-function-name-face))) + ((or (not (match-string 2)) ;; Normal defun. + (and (match-string 2) ;; Setf function. + (match-string 4))) font-lock-function-name-face))) nil t))) "Subdued level highlighting for Lisp modes.") @@ -333,7 +402,7 @@ `( ;; Regexp negated char group. ("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend) ;; Control structures. Common Lisp forms. - (,(concat "(" el-kws-re "\\_>") . 1) + (lisp--el-match-keyword . 1) ;; Exit/Feature symbols as constants. (,(concat "(\\(catch\\|throw\\|featurep\\|provide\\|require\\)\\_>" "[ \t']*\\(\\(?:\\sw\\|\\s_\\)+\\)?") @@ -514,6 +583,7 @@ font-lock keywords will not be case sensitive." . lisp-font-lock-syntactic-face-function))) (setq-local prettify-symbols-alist lisp--prettify-symbols-alist) (when elisp + (add-hook 'after-load-functions #'lisp--el-font-lock-flush-elisp-buffers) (setq-local electric-pair-text-pairs (cons '(?\` . ?\') electric-pair-text-pairs))) (setq-local electric-pair-skip-whitespace 'chomp) diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 214bed7622d..67d14872b3a 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -263,7 +263,7 @@ This command assumes point is not in a string or comment." (backward-up-list arg) (kill-sexp) (insert current-sexp)) - (error "Not at a sexp")))) + (user-error "Not at a sexp")))) (defvar beginning-of-defun-function nil "If non-nil, function for `beginning-of-defun-raw' to call. @@ -714,7 +714,8 @@ character." (condition-case data ;; Buffer can't have more than (point-max) sexps. (scan-sexps (point-min) (point-max)) - (scan-error (goto-char (nth 2 data)) + (scan-error (push-mark) + (goto-char (nth 2 data)) ;; Could print (nth 1 data), which is either ;; "Containing expression ends prematurely" or ;; "Unbalanced parentheses", but those may not be so diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index b75c8cc50a7..f0410f87447 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -297,15 +297,16 @@ definitions to shadow the loaded ones for use in file byte-compilation." ;;; Handy functions to use in macros. -(defun macroexp-parse-body (exps) - "Parse EXPS into ((DOC DECLARE-FORM INTERACTIVE-FORM) . BODY)." - `((,(and (stringp (car exps)) - (pop exps)) - ,(and (eq (car-safe (car exps)) 'declare) - (pop exps)) - ,(and (eq (car-safe (car exps)) 'interactive) - (pop exps))) - ,@exps)) +(defun macroexp-parse-body (body) + "Parse a function BODY into (DECLARATIONS . EXPS)." + (let ((decls ())) + (while (and (cdr body) + (let ((e (car body))) + (or (stringp e) + (memq (car-safe e) + '(:documentation declare interactive cl-declare))))) + (push (pop body) decls)) + (cons (nreverse decls) body))) (defun macroexp-progn (exps) "Return an expression equivalent to `(progn ,@EXPS)." @@ -464,6 +465,8 @@ itself or not." (defvar macroexp--pending-eager-loads nil "Stack of files currently undergoing eager macro-expansion.") +(defvar macroexp--debug-eager nil) + (defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. (cond @@ -479,8 +482,10 @@ itself or not." (tail (member elem (cdr (member elem bt))))) (if tail (setcdr tail (list '…))) (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) - (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" - (mapconcat #'prin1-to-string (nreverse bt) " => ")) + (if macroexp--debug-eager + (debug 'eager-macroexp-cycle) + (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" + (mapconcat #'prin1-to-string (nreverse bt) " => "))) (push 'skip macroexp--pending-eager-loads) form)) (t diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index e0945d47a45..6955ce8f5a6 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -247,7 +247,7 @@ if it exists." (concat (symbol-name pkg-name) "-readme.txt") package-archive-upload-base))) - (set-buffer pkg-buffer) + (set-buffer (if (eq file-type 'tar) tar-data-buffer pkg-buffer)) (write-region (point-min) (point-max) (expand-file-name (format "%s-%s.%s" pkg-name pkg-version extension) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index c3a2061aae2..583598ee10c 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -173,6 +173,8 @@ :group 'applications :version "24.1") + +;;; Customization options ;;;###autoload (defcustom package-enable-at-startup t "Whether to activate installed packages when Emacs starts. @@ -204,12 +206,6 @@ If VERSION is nil, the package is not loaded (it is \"disabled\")." :group 'package :version "24.1") -(defvar Info-directory-list) -(declare-function info-initialize "info" ()) -(declare-function url-http-file-exists-p "url-http" (url)) -(declare-function lm-header "lisp-mnt" (header)) -(declare-function lm-commentary "lisp-mnt" (&optional file)) - (defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/")) "An alist of archives from which to fetch. The default value points to the GNU Emacs package repository. @@ -270,17 +266,6 @@ the package will be unavailable." :group 'package :version "24.4") -(defconst package-archive-version 1 - "Version number of the package archive understood by this file. -Lower version numbers than this will probably be understood as well.") - -;; We don't prime the cache since it tends to get out of date. -(defvar package-archive-contents nil - "Cache of the contents of the Emacs Lisp Package Archive. -This is an alist mapping package names (symbols) to -non-empty lists of `package-desc' structures.") -(put 'package-archive-contents 'risky-local-variable t) - (defcustom package-user-dir (locate-user-emacs-file "elpa") "Directory containing the user's Emacs Lisp packages. The directory name should be absolute. @@ -335,11 +320,10 @@ contents of the archive." :version "24.4") (defcustom package-selected-packages nil - "Store here packages installed explicitely by user. -This variable will be feeded automatically by emacs, -when installing a new package. -This variable will be used by `package-autoremove' to decide -which packages are no more needed. + "Store here packages installed explicitly by user. +This variable is fed automatically by Emacs when installing a new package. +This variable is used by `package-autoremove' to decide +which packages are no longer needed. You can use it to (re)install packages on other machines by running `package-user-selected-packages-install'. @@ -349,6 +333,14 @@ a sane initial value." :group 'package :type '(repeat symbol)) + +;;; `package-desc' object definition +;; This is the struct used internally to represent packages. +;; Functions that deal with packages should generally take this object +;; as an argument. In some situations (e.g. commands that query the +;; user) it makes sense to take the package name as a symbol instead, +;; but keep in mind there could be multiple `package-desc's with the +;; same name. (defvar package--default-summary "No description available.") (cl-defstruct (package-desc @@ -420,7 +412,43 @@ Slots: extras signed) +(defun package--from-builtin (bi-desc) + (package-desc-create :name (pop bi-desc) + :version (package--bi-desc-version bi-desc) + :summary (package--bi-desc-summary bi-desc) + :dir 'builtin)) + ;; Pseudo fields. +(defun package-version-join (vlist) + "Return the version string corresponding to the list VLIST. +This is, approximately, the inverse of `version-to-list'. +\(Actually, it returns only one of the possible inverses, since +`version-to-list' is a many-to-one operation.)" + (if (null vlist) + "" + (let ((str-list (list "." (int-to-string (car vlist))))) + (dolist (num (cdr vlist)) + (cond + ((>= num 0) + (push (int-to-string num) str-list) + (push "." str-list)) + ((< num -4) + (error "Invalid version list `%s'" vlist)) + (t + ;; pre, or beta, or alpha + (cond ((equal "." (car str-list)) + (pop str-list)) + ((not (string-match "[0-9]+" (car str-list))) + (error "Invalid version list `%s'" vlist))) + (push (cond ((= num -1) "pre") + ((= num -2) "beta") + ((= num -3) "alpha") + ((= num -4) "snapshot")) + str-list)))) + (if (equal "." (car str-list)) + (pop str-list)) + (apply 'concat (nreverse str-list))))) + (defun package-desc-full-name (pkg-desc) (format "%s-%s" (package-desc-name pkg-desc) @@ -447,6 +475,13 @@ Slots: reqs summary) + +;;; Installed packages +;; The following variables store information about packages present in +;; the system. The most important of these is `package-alist'. The +;; command `package-initialize' is also closely related to this +;; section, but it is left for a later section because it also affects +;; other stuff. (defvar package--builtins nil "Alist of built-in packages. The actual value is initialized by loading the library @@ -473,35 +508,28 @@ loaded and/or activated, customize `package-load-list'.") "List of the names of currently activated packages.") (put 'package-activated-list 'risky-local-variable t) -(defun package-version-join (vlist) - "Return the version string corresponding to the list VLIST. -This is, approximately, the inverse of `version-to-list'. -\(Actually, it returns only one of the possible inverses, since -`version-to-list' is a many-to-one operation.)" - (if (null vlist) - "" - (let ((str-list (list "." (int-to-string (car vlist))))) - (dolist (num (cdr vlist)) - (cond - ((>= num 0) - (push (int-to-string num) str-list) - (push "." str-list)) - ((< num -4) - (error "Invalid version list `%s'" vlist)) - (t - ;; pre, or beta, or alpha - (cond ((equal "." (car str-list)) - (pop str-list)) - ((not (string-match "[0-9]+" (car str-list))) - (error "Invalid version list `%s'" vlist))) - (push (cond ((= num -1) "pre") - ((= num -2) "beta") - ((= num -3) "alpha") - ((= num -4) "snapshot")) - str-list)))) - (if (equal "." (car str-list)) - (pop str-list)) - (apply 'concat (nreverse str-list))))) +;;;; Populating `package-alist'. +;; The following functions are called on each installed package by +;; `package-load-all-descriptors', which ultimately populates the +;; `package-alist' variable. +(defun package-process-define-package (exp) + (when (eq (car-safe exp) 'define-package) + (let* ((new-pkg-desc (apply #'package-desc-from-define (cdr exp))) + (name (package-desc-name new-pkg-desc)) + (version (package-desc-version new-pkg-desc)) + (old-pkgs (assq name package-alist))) + (if (null old-pkgs) + ;; If there's no old package, just add this to `package-alist'. + (push (list name new-pkg-desc) package-alist) + ;; If there is, insert the new package at the right place in the list. + (while + (if (and (cdr old-pkgs) + (version-list-< version + (package-desc-version (cadr old-pkgs)))) + (setq old-pkgs (cdr old-pkgs)) + (push new-pkg-desc (cdr old-pkgs)) + nil))) + new-pkg-desc))) (defun package-load-descriptor (pkg-dir) "Load the description file in directory PKG-DIR." @@ -512,8 +540,9 @@ This is, approximately, the inverse of `version-to-list'. (with-temp-buffer (insert-file-contents pkg-file) (goto-char (point-min)) - (let ((pkg-desc (package-process-define-package - (read (current-buffer)) pkg-file))) + (let ((pkg-desc (or (package-process-define-package + (read (current-buffer))) + (error "Can't find define-package in %s" pkg-file)))) (setf (package-desc-dir pkg-desc) pkg-dir) (if (file-exists-p signed-file) (setf (package-desc-signed pkg-desc) t)) @@ -535,6 +564,24 @@ updates `package-alist'." (when (file-directory-p pkg-dir) (package-load-descriptor pkg-dir))))))) +(defun define-package (_name-string _version-string + &optional _docstring _requirements + &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. +DOCSTRING is a short description of the package, a string. +REQUIREMENTS is a list of dependencies on other packages. + Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION), + where OTHER-VERSION is a string. + +EXTRA-PROPERTIES is currently unused." + ;; FIXME: Placeholder! Should we keep it? + (error "Don't call me!")) + + +;;; Package activation +;; Section for functions used by `package-activate', which see. (defun package-disabled-p (pkg-name version) "Return whether PKG-NAME at VERSION can be activated. The decision is made according to `package-load-list'. @@ -550,6 +597,23 @@ Return the max version (as a string) if the package is held at a lower version." force)) (t (error "Invalid element in `package-load-list'"))))) +(defun package-built-in-p (package &optional min-version) + "Return true if PACKAGE is built-in to Emacs. +Optional arg MIN-VERSION, if non-nil, should be a version list +specifying the minimum acceptable version." + (if (package-desc-p package) ;; was built-in and then was converted + (eq 'builtin (package-desc-dir package)) + (let ((bi (assq package package--builtin-versions))) + (cond + (bi (version-list-<= min-version (cdr bi))) + ((remove 0 min-version) nil) + (t + (require 'finder-inf nil t) ; For `package--builtins'. + (assq package package--builtins)))))) + +(defvar Info-directory-list) +(declare-function info-initialize "info" ()) + (defun package-activate-1 (pkg-desc &optional reload) "Activate package given by PKG-DESC, even if it was already active. If RELOAD is non-nil, also `load' any files inside the package which @@ -594,6 +658,7 @@ correspond to previously loaded files (those returned by t)) (declare-function find-library-name "find-func" (library)) + (defun package--list-loaded-files (dir) "Recursively list all files in DIR which correspond to loaded features. Returns the `file-name-sans-extension' of each file, relative to @@ -628,33 +693,14 @@ DIR, sorted by most recently loaded last." ;; Sort the files by ascending HISTORY-POSITION. (lambda (x y) (< (cdr x) (cdr y)))))))) -(defun package-built-in-p (package &optional min-version) - "Return true if PACKAGE is built-in to Emacs. -Optional arg MIN-VERSION, if non-nil, should be a version list -specifying the minimum acceptable version." - (if (package-desc-p package) ;; was built-in and then was converted - (eq 'builtin (package-desc-dir package)) - (let ((bi (assq package package--builtin-versions))) - (cond - (bi (version-list-<= min-version (cdr bi))) - ((remove 0 min-version) nil) - (t - (require 'finder-inf nil t) ; For `package--builtins'. - (assq package package--builtins)))))) - -(defun package--from-builtin (bi-desc) - (package-desc-create :name (pop bi-desc) - :version (package--bi-desc-version bi-desc) - :summary (package--bi-desc-summary bi-desc) - :dir 'builtin)) - -;; This function goes ahead and activates a newer version of a package -;; if an older one was already activated. This is not ideal; we'd at -;; least need to check to see if the package has actually been loaded, -;; and not merely activated. +;;;; `package-activate' +;; This function activates a newer version of a package if an older +;; one was already activated. It also loads a features of this +;; package which were already loaded. (defun package-activate (package &optional force) "Activate package PACKAGE. -If FORCE is true, (re-)activate it if it's already activated." +If FORCE is true, (re-)activate it if it's already activated. +Newer versions are always activated, regardless of FORCE." (let ((pkg-descs (cdr (assq package package-alist)))) ;; Check if PACKAGE is available in `package-alist'. (while @@ -686,76 +732,14 @@ Required package `%s-%s' is unavailable" ;; If all goes well, activate the package itself. (package-activate-1 pkg-vec force))))))) -(defun define-package (_name-string _version-string - &optional _docstring _requirements - &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. -DOCSTRING is a short description of the package, a string. -REQUIREMENTS is a list of dependencies on other packages. - Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION), - where OTHER-VERSION is a string. - -EXTRA-PROPERTIES is currently unused." - ;; FIXME: Placeholder! Should we keep it? - (error "Don't call me!")) - -(defun package-process-define-package (exp origin) - (unless (eq (car-safe exp) 'define-package) - (error "Can't find define-package in %s" origin)) - (let* ((new-pkg-desc (apply #'package-desc-from-define (cdr exp))) - (name (package-desc-name new-pkg-desc)) - (version (package-desc-version new-pkg-desc)) - (old-pkgs (assq name package-alist))) - (if (null old-pkgs) - ;; If there's no old package, just add this to `package-alist'. - (push (list name new-pkg-desc) package-alist) - ;; If there is, insert the new package at the right place in the list. - (while - (if (and (cdr old-pkgs) - (version-list-< version - (package-desc-version (cadr old-pkgs)))) - (setq old-pkgs (cdr old-pkgs)) - (push new-pkg-desc (cdr old-pkgs)) - nil))) - new-pkg-desc)) - -;; From Emacs 22, but changed so it adds to load-path. -(defun package-autoload-ensure-default-file (file) - "Make sure that the autoload file FILE exists and if not create it." - (unless (file-exists-p file) - (write-region - (concat ";;; " (file-name-nondirectory file) - " --- automatically extracted autoloads\n" - ";;\n" - ";;; Code:\n" - "(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))\n" - " \n;; Local Variables:\n" - ";; version-control: never\n" - ";; no-byte-compile: t\n" - ";; no-update-autoloads: t\n" - ";; End:\n" - ";;; " (file-name-nondirectory file) - " ends here\n") - nil file nil 'silent)) - file) - -(defvar generated-autoload-file) -(defvar version-control) - -(defun package-generate-autoloads (name pkg-dir) - (let* ((auto-name (format "%s-autoloads.el" name)) - ;;(ignore-name (concat name "-pkg.el")) - (generated-autoload-file (expand-file-name auto-name pkg-dir)) - (backup-inhibited t) - (version-control 'never)) - (package-autoload-ensure-default-file generated-autoload-file) - (update-directory-autoloads pkg-dir) - (let ((buf (find-buffer-visiting generated-autoload-file))) - (when buf (kill-buffer buf))) - auto-name)) + +;;; Installation -- Local operations +;; This section contains a variety of features regarding installing a +;; package to/from disk. This includes autoload generation, +;; unpacking, compiling, as well as defining a package from the +;; current buffer. +;;;; Unpacking (defvar tar-parse-info) (declare-function tar-untar-buffer "tar-mode" ()) (declare-function tar-header-name "tar-mode" (tar-header) t) @@ -780,34 +764,6 @@ untar into a directory named DIR; otherwise, signal an error." (error "Package does not untar cleanly into directory %s/" dir))))) (tar-untar-buffer)) -(defun package-generate-description-file (pkg-desc pkg-file) - "Create the foo-pkg.el file for single-file packages." - (let* ((name (package-desc-name pkg-desc))) - (let ((print-level nil) - (print-quoted t) - (print-length nil)) - (write-region - (concat - ";;; -*- no-byte-compile: t -*-\n" - (prin1-to-string - (nconc - (list 'define-package - (symbol-name name) - (package-version-join (package-desc-version pkg-desc)) - (package-desc-summary pkg-desc) - (let ((requires (package-desc-reqs pkg-desc))) - (list 'quote - ;; Turn version lists into string form. - (mapcar - (lambda (elt) - (list (car elt) - (package-version-join (cadr elt)))) - requires)))) - (package--alist-to-plist-args - (package-desc-extras pkg-desc)))) - "\n") - nil pkg-file nil 'silent)))) - (defun package--alist-to-plist-args (alist) (mapcar 'macroexp-quote (apply #'nconc @@ -854,6 +810,70 @@ untar into a directory named DIR; otherwise, signal an error." (package-activate name 'force) pkg-dir)) +(defun package-generate-description-file (pkg-desc pkg-file) + "Create the foo-pkg.el file for single-file packages." + (let* ((name (package-desc-name pkg-desc))) + (let ((print-level nil) + (print-quoted t) + (print-length nil)) + (write-region + (concat + ";;; -*- no-byte-compile: t -*-\n" + (prin1-to-string + (nconc + (list 'define-package + (symbol-name name) + (package-version-join (package-desc-version pkg-desc)) + (package-desc-summary pkg-desc) + (let ((requires (package-desc-reqs pkg-desc))) + (list 'quote + ;; Turn version lists into string form. + (mapcar + (lambda (elt) + (list (car elt) + (package-version-join (cadr elt)))) + requires)))) + (package--alist-to-plist-args + (package-desc-extras pkg-desc)))) + "\n") + nil pkg-file nil 'silent)))) + +;;;; Autoload +;; From Emacs 22, but changed so it adds to load-path. +(defun package-autoload-ensure-default-file (file) + "Make sure that the autoload file FILE exists and if not create it." + (unless (file-exists-p file) + (write-region + (concat ";;; " (file-name-nondirectory file) + " --- automatically extracted autoloads\n" + ";;\n" + ";;; Code:\n" + "(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))\n" + " \n;; Local Variables:\n" + ";; version-control: never\n" + ";; no-byte-compile: t\n" + ";; no-update-autoloads: t\n" + ";; End:\n" + ";;; " (file-name-nondirectory file) + " ends here\n") + nil file nil 'silent)) + file) + +(defvar generated-autoload-file) +(defvar version-control) + +(defun package-generate-autoloads (name pkg-dir) + (let* ((auto-name (format "%s-autoloads.el" name)) + ;;(ignore-name (concat name "-pkg.el")) + (generated-autoload-file (expand-file-name auto-name pkg-dir)) + (backup-inhibited t) + (version-control 'never)) + (package-autoload-ensure-default-file generated-autoload-file) + (update-directory-autoloads pkg-dir) + (let ((buf (find-buffer-visiting generated-autoload-file))) + (when buf (kill-buffer buf))) + auto-name)) + (defun package--make-autoloads-and-stuff (pkg-desc pkg-dir) "Generate autoloads, description file, etc.. for PKG-DESC installed at PKG-DIR." (package-generate-autoloads (package-desc-name pkg-desc) pkg-dir) @@ -864,33 +884,153 @@ untar into a directory named DIR; otherwise, signal an error." ;; FIXME: Create foo.info and dir file from foo.texi? ) +;;;; Compilation (defun package--compile (pkg-desc) "Byte-compile installed package PKG-DESC." (package-activate-1 pkg-desc) (byte-recompile-directory (package-desc-dir pkg-desc) 0 t)) +;;;; Inferring package from current buffer +(defun package-read-from-string (str) + "Read a Lisp expression from STR. +Signal an error if the entire string was not used." + (let* ((read-data (read-from-string str)) + (more-left + (condition-case nil + ;; The call to `ignore' suppresses a compiler warning. + (progn (ignore (read-from-string + (substring str (cdr read-data)))) + t) + (end-of-file nil)))) + (if more-left + (error "Can't read whole string") + (car read-data)))) + +(defun package--prepare-dependencies (deps) + "Turn DEPS into an acceptable list of dependencies. + +Any parts missing a version string get a default version string +of \"0\" (meaning any version) and an appropriate level of lists +is wrapped around any parts requiring it." + (cond + ((not (listp deps)) + (error "Invalid requirement specifier: %S" deps)) + (t (mapcar (lambda (dep) + (cond + ((symbolp dep) `(,dep "0")) + ((stringp dep) + (error "Invalid requirement specifier: %S" dep)) + ((and (listp dep) (null (cdr dep))) + (list (car dep) "0")) + (t dep))) + deps)))) + +(declare-function lm-header "lisp-mnt" (header)) +(declare-function lm-homepage "lisp-mnt" ()) + +(defun package-buffer-info () + "Return a `package-desc' describing the package in the current buffer. + +If the buffer does not contain a conforming package, signal an +error. If there is a package, narrow the buffer to the file's +boundaries." + (goto-char (point-min)) + (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t) + (error "Package lacks a file header")) + (let ((file-name (match-string-no-properties 1)) + (desc (match-string-no-properties 2)) + (start (line-beginning-position))) + (unless (search-forward (concat ";;; " file-name ".el ends here")) + (error "Package lacks a terminating comment")) + ;; Try to include a trailing newline. + (forward-line) + (narrow-to-region start (point)) + (require 'lisp-mnt) + ;; Use some headers we've invented to drive the process. + (let* ((requires-str (lm-header "package-requires")) + ;; Prefer Package-Version; if defined, the package author + ;; probably wants us to use it. Otherwise try Version. + (pkg-version + (or (package-strip-rcs-id (lm-header "package-version")) + (package-strip-rcs-id (lm-header "version")))) + (homepage (lm-homepage))) + (unless pkg-version + (error + "Package lacks a \"Version\" or \"Package-Version\" header")) + (package-desc-from-define + file-name pkg-version desc + (if requires-str + (package--prepare-dependencies + (package-read-from-string requires-str))) + :kind 'single + :url homepage)))) + +(defun package--read-pkg-desc (kind) + "Read a `define-package' form in current buffer. +Return the pkg-desc, with desc-kind set to KIND." + (goto-char (point-min)) + (unwind-protect + (let* ((pkg-def-parsed (read (current-buffer))) + (pkg-desc + (when (eq (car pkg-def-parsed) 'define-package) + (apply #'package-desc-from-define + (append (cdr pkg-def-parsed)))))) + (when pkg-desc + (setf (package-desc-kind pkg-desc) kind) + pkg-desc)))) + +(declare-function tar-get-file-descriptor "tar-mode" (file)) +(declare-function tar--extract "tar-mode" (descriptor)) + +(defun package-tar-file-info () + "Find package information for a tar file. +The return result is a `package-desc'." + (cl-assert (derived-mode-p 'tar-mode)) + (let* ((dir-name (file-name-directory + (tar-header-name (car tar-parse-info)))) + (desc-file (package--description-file dir-name)) + (tar-desc (tar-get-file-descriptor (concat dir-name desc-file)))) + (unless tar-desc + (error "No package descriptor file found")) + (with-current-buffer (tar--extract tar-desc) + (unwind-protect + (or (package--read-pkg-desc 'tar) + (error "Can't find define-package in %s" + (tar-header-name tar-desc))) + (kill-buffer (current-buffer)))))) + +(defun package-dir-info () + "Find package information for a directory. +The return result is a `package-desc'." + (cl-assert (derived-mode-p 'dired-mode)) + (let* ((desc-file (package--description-file default-directory))) + (if (file-readable-p desc-file) + (with-temp-buffer + (insert-file-contents desc-file) + (package--read-pkg-desc 'dir)) + (let ((files (directory-files default-directory t "\\.el\\'" t)) + info) + (while files + (with-temp-buffer + (insert-file-contents (pop files)) + ;; When we find the file with the data, + (when (setq info (ignore-errors (package-buffer-info))) + ;; stop looping, + (setq files nil) + ;; set the 'dir kind, + (setf (package-desc-kind info) 'dir)))) + ;; and return the info. + info)))) + + +;;; Communicating with Archives +;; Set of low-level functions for communicating with archives and +;; signature checking. (defun package--write-file-no-coding (file-name) (let ((buffer-file-coding-system 'no-conversion)) (write-region (point-min) (point-max) file-name nil 'silent))) -(defmacro package--with-work-buffer (location file &rest body) - "Run BODY in a buffer containing the contents of FILE at LOCATION. -LOCATION is the base location of a package archive, and should be -one of the URLs (or file names) specified in `package-archives'. -FILE is the name of a file relative to that base location. - -This macro retrieves FILE from LOCATION into a temporary buffer, -and evaluates BODY while that buffer is current. This work -buffer is killed afterwards. Return the last value in BODY." - (declare (indent 2) (debug t)) - `(with-temp-buffer - (if (string-match-p "\\`https?:" ,location) - (url-insert-file-contents (concat ,location ,file)) - (unless (file-name-absolute-p ,location) - (error "Archive location %s is not an absolute file name" - ,location)) - (insert-file-contents (expand-file-name ,file ,location))) - ,@body)) +(declare-function url-http-file-exists-p "url-http" (url)) (defun package--archive-file-exists-p (location file) (let ((http (string-match "\\`https?:" location))) @@ -923,20 +1063,62 @@ buffer is killed afterwards. Return the last value in BODY." (insert (format "Error while verifying signature %s:\n" sig-file))) (insert "\nCommand output:\n" (epg-context-error-output context)))))) -(defun package--check-signature (location file) - "Check signature of the current buffer. -GnuPG keyring is located under \"gnupg\" in `package-user-dir'." +(defmacro package--with-work-buffer (location file &rest body) + "Run BODY in a buffer containing the contents of FILE at LOCATION. +LOCATION is the base location of a package archive, and should be +one of the URLs (or file names) specified in `package-archives'. +FILE is the name of a file relative to that base location. + +This macro retrieves FILE from LOCATION into a temporary buffer, +and evaluates BODY while that buffer is current. This work +buffer is killed afterwards. Return the last value in BODY." + (declare (indent 2) (debug t)) + `(with-temp-buffer + (if (string-match-p "\\`https?:" ,location) + (url-insert-file-contents (concat ,location ,file)) + (unless (file-name-absolute-p ,location) + (error "Archive location %s is not an absolute file name" + ,location)) + (insert-file-contents (expand-file-name ,file ,location))) + ,@body)) + +(defmacro package--with-work-buffer-async (location file async &rest body) + "Run BODY in a buffer containing the contents of FILE at LOCATION. +If ASYNC is non-nil, and if it is possible, run BODY +asynchronously. If an error is encountered and ASYNC is a +function, call it with no arguments (instead of executing BODY), +otherwise propagate the error. For description of the other +arguments see `package--with-work-buffer'." + (declare (indent 3) (debug t)) + `(if (or (not ,async) + (not (string-match-p "\\`https?:" ,location))) + (package--with-work-buffer ,location ,file ,@body) + (url-retrieve (concat ,location ,file) + (lambda (status) + (if (eq (car status) :error) + (if (functionp ,async) + (funcall ,async) + (signal (cdar status) (cddr status))) + (goto-char (point-min)) + (unless (search-forward "\n\n" nil 'noerror) + (error "Invalid url response")) + (delete-region (point-min) (point)) + ,@body) + (kill-buffer (current-buffer))) + nil + 'silent))) + +(defun package--check-signature-content (content string &optional sig-file) + "Check signature CONTENT against STRING. +SIG-FILE is the name of the signature file, used when signaling +errors." (let* ((context (epg-make-context 'OpenPGP)) - (homedir (expand-file-name "gnupg" package-user-dir)) - (sig-file (concat file ".sig")) - (sig-content (package--with-work-buffer location sig-file - (buffer-string)))) + (homedir (expand-file-name "gnupg" package-user-dir))) (setf (epg-context-home-directory context) homedir) (condition-case error - (epg-verify-string context sig-content (buffer-string)) - (error - (package--display-verify-error context sig-file) - (signal (car error) (cdr error)))) + (epg-verify-string context content string) + (error (package--display-verify-error context sig-file) + (signal (car error) (cdr error)))) (let (good-signatures had-fatal-error) ;; The .sig file may contain multiple signatures. Success if one ;; of the signatures is good. @@ -955,65 +1137,314 @@ GnuPG keyring is located under \"gnupg\" in `package-user-dir'." (error "Failed to verify signature %s" sig-file)) good-signatures))) -(defun package-install-from-archive (pkg-desc) - "Download and install a tar package." - ;; This won't happen, unless the archive is doing something wrong. - (when (eq (package-desc-kind pkg-desc) 'dir) - (error "Can't install directory package from archive")) - (let* ((location (package-archive-base pkg-desc)) - (file (concat (package-desc-full-name pkg-desc) - (package-desc-suffix pkg-desc))) - (sig-file (concat file ".sig")) - good-signatures pkg-descs) - (package--with-work-buffer location file - (if (and package-check-signature - (not (member (package-desc-archive pkg-desc) - package-unsigned-archives))) - (if (package--archive-file-exists-p location sig-file) - (setq good-signatures (package--check-signature location file)) - (unless (eq package-check-signature 'allow-unsigned) - (error "Unsigned package: `%s'" - (package-desc-name pkg-desc))))) - (package-unpack pkg-desc)) - ;; Here the package has been installed successfully, mark it as - ;; signed if appropriate. - (when good-signatures - ;; Write out good signatures into NAME-VERSION.signed file. - (write-region (mapconcat #'epg-signature-to-string good-signatures "\n") - nil - (expand-file-name - (concat (package-desc-full-name pkg-desc) - ".signed") - package-user-dir) - nil 'silent) - ;; Update the old pkg-desc which will be shown on the description buffer. - (setf (package-desc-signed pkg-desc) t) - ;; Update the new (activated) pkg-desc as well. - (setq pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist))) - (if pkg-descs - (setf (package-desc-signed (car pkg-descs)) t))))) +(defun package--check-signature (location file &optional string async callback) + "Check signature of the current buffer. +Download the signature file from LOCATION by appending \".sig\" +to FILE. +GnuPG keyring is located under \"gnupg\" in `package-user-dir'. +STRING is the string to verify, it defaults to `buffer-string'. +If ASYNC is non-nil, the download of the signature file is +done asynchronously. + +If the signature is verified and CALLBACK was provided, CALLBACK +is `funcall'ed with the list of good signatures as argument (the +list can be empty). If the signatures file is not found, +CALLBACK is called with no arguments." + (let ((sig-file (concat file ".sig")) + (string (or string (buffer-string)))) + (condition-case nil + (package--with-work-buffer-async + location sig-file (when async (or callback t)) + (let ((sig (package--check-signature-content + (buffer-string) string sig-file))) + (when callback (funcall callback sig)) + sig)) + (file-error (funcall callback))))) + + +;;; Packages on Archives +;; The following variables store information about packages available +;; from archives. The most important of these is +;; `package-archive-contents' which is initially populated by the +;; function `package-read-all-archive-contents' from a cache on disk. +;; The `package-initialize' command is also closely related to this +;; section, but it has its own section. +(defconst package-archive-version 1 + "Version number of the package archive understood by this file. +Lower version numbers than this will probably be understood as well.") + +;; We don't prime the cache since it tends to get out of date. +(defvar package-archive-contents nil + "Cache of the contents of the Emacs Lisp Package Archive. +This is an alist mapping package names (symbols) to +non-empty lists of `package-desc' structures.") +(put 'package-archive-contents 'risky-local-variable t) + +(defvar package--compatibility-table nil + "Hash table connecting package names to their compatibility. +Each key is a symbol, the name of a package. + +The value is either nil, representing an incompatible package, or +a version list, representing the highest compatible version of +that package which is available. + +A package is considered incompatible if it requires an Emacs +version higher than the one being used. To check for package +\(in)compatibility, don't read this table directly, use +`package--incompatible-p' which also checks dependencies.") + +(defun package--build-compatibility-table () + "Build `package--compatibility-table' with `package--mapc'." + ;; Build compat table. + (setq package--compatibility-table (make-hash-table :test 'eq)) + (package--mapc #'package--add-to-compatibility-table)) + +(defun package--add-to-compatibility-table (pkg) + "If PKG is compatible (without dependencies), add to the compatibility table. +PKG is a package-desc object. +Only adds if its version is higher than what's already stored in +the table." + (unless (package--incompatible-p pkg 'shallow) + (let* ((name (package-desc-name pkg)) + (version (or (package-desc-version pkg) '(0))) + (table-version (gethash name package--compatibility-table))) + (when (or (not table-version) + (version-list-< table-version version)) + (puthash name version package--compatibility-table))))) + +;; Package descriptor objects used inside the "archive-contents" file. +;; Changing this defstruct implies changing the format of the +;; "archive-contents" files. +(cl-defstruct (package--ac-desc + (:constructor package-make-ac-desc (version reqs summary kind extras)) + (:copier nil) + (:type vector)) + version reqs summary kind extras) + +(defun package--append-to-alist (pkg-desc alist) + "Append an entry for PKG-DESC to the start of ALIST and return it. +This entry takes the form (`package-desc-name' PKG-DESC). + +If ALIST already has an entry with this name, destructively add +PKG-DESC to the cdr of this entry instead, sorted by version +number." + (let* ((name (package-desc-name pkg-desc)) + (priority-version (package-desc-priority-version pkg-desc)) + (existing-packages (assq name alist))) + (if (not existing-packages) + (cons (list name pkg-desc) + alist) + (while (if (and (cdr existing-packages) + (version-list-< priority-version + (package-desc-priority-version + (cadr existing-packages)))) + (setq existing-packages (cdr existing-packages)) + (push pkg-desc (cdr existing-packages)) + nil)) + alist))) + +(defun package--add-to-archive-contents (package archive) + "Add the PACKAGE from the given ARCHIVE if necessary. +PACKAGE should have the form (NAME . PACKAGE--AC-DESC). +Also, add the originating archive to the `package-desc' structure." + (let* ((name (car package)) + (version (package--ac-desc-version (cdr package))) + (pkg-desc + (package-desc-create + :name name + :version version + :reqs (package--ac-desc-reqs (cdr package)) + :summary (package--ac-desc-summary (cdr package)) + :kind (package--ac-desc-kind (cdr package)) + :archive archive + :extras (and (> (length (cdr package)) 4) + ;; Older archive-contents files have only 4 + ;; elements here. + (package--ac-desc-extras (cdr package))))) + (pinned-to-archive (assoc name package-pinned-packages))) + ;; Skip entirely if pinned to another archive. + (when (not (and pinned-to-archive + (not (equal (cdr pinned-to-archive) archive)))) + (setq package-archive-contents + (package--append-to-alist pkg-desc package-archive-contents))))) + +(defun package--read-archive-file (file) + "Re-read archive file FILE, if it exists. +Will return the data from the file, or nil if the file does not exist. +Will throw an error if the archive version is too new." + (let ((filename (expand-file-name file package-user-dir))) + (when (file-exists-p filename) + (with-temp-buffer + (insert-file-contents-literally filename) + (let ((contents (read (current-buffer)))) + (if (> (car contents) package-archive-version) + (error "Package archive version %d is higher than %d" + (car contents) package-archive-version)) + (cdr contents)))))) + +(defun package-read-archive-contents (archive) + "Re-read archive contents for ARCHIVE. +If successful, set the variable `package-archive-contents'. +If the archive version is too new, signal an error." + ;; Version 1 of 'archive-contents' is identical to our internal + ;; representation. + (let* ((contents-file (format "archives/%s/archive-contents" archive)) + (contents (package--read-archive-file contents-file))) + (when contents + (dolist (package contents) + (package--add-to-archive-contents package archive))))) + +(defun package-read-all-archive-contents () + "Re-read `archive-contents', if it exists. +If successful, set `package-archive-contents'." + (setq package-archive-contents nil) + (dolist (archive package-archives) + (package-read-archive-contents (car archive)))) +;;;; Package Initialize +;; A bit of a milestone. This brings together some of the above +;; sections and populates all relevant lists of packages from contents +;; available on disk. (defvar package--initialized nil) -(defun package-installed-p (package &optional min-version) - "Return true if PACKAGE, of MIN-VERSION or newer, is installed. -If PACKAGE is a symbol, it is the package name and MIN-VERSION -should be a version list. +;;;###autoload +(defun package-initialize (&optional no-activate) + "Load Emacs Lisp packages, and activate them. +The variable `package-load-list' controls which packages to load. +If optional arg NO-ACTIVATE is non-nil, don't activate packages." + (interactive) + (setq package-alist nil) + (package-load-all-descriptors) + (package-read-all-archive-contents) + (unless no-activate + (dolist (elt package-alist) + (package-activate (car elt)))) + (setq package--initialized t) + ;; This uses `package--mapc' so it must be called after + ;; `package--initialized' is t. + (package--build-compatibility-table)) -If PACKAGE is a package-desc object, MIN-VERSION is ignored." - (unless package--initialized (error "package.el is not yet initialized!")) - (if (package-desc-p package) - (let ((dir (package-desc-dir package))) - (and (stringp dir) - (file-exists-p dir))) - (or - (let ((pkg-descs (cdr (assq package package-alist)))) - (and pkg-descs - (version-list-<= min-version - (package-desc-version (car pkg-descs))))) - ;; Also check built-in packages. - (package-built-in-p package min-version)))) + +;;;; Populating `package-archive-contents' from archives +;; This subsection populates the variables listed above from the +;; actual archives, instead of from a local cache. +(defvar package--downloads-in-progress nil + "List of in-progress asynchronous downloads.") +(declare-function epg-check-configuration "epg-config" + (config &optional minimum-version)) +(declare-function epg-configuration "epg-config" ()) +(declare-function epg-import-keys-from-file "epg" (context keys)) + +;;;###autoload +(defun package-import-keyring (&optional file) + "Import keys from FILE." + (interactive "fFile: ") + (setq file (expand-file-name file)) + (let ((context (epg-make-context 'OpenPGP)) + (homedir (expand-file-name "gnupg" package-user-dir))) + (with-file-modes 448 + (make-directory homedir t)) + (setf (epg-context-home-directory context) homedir) + (message "Importing %s..." (file-name-nondirectory file)) + (epg-import-keys-from-file context file) + (message "Importing %s...done" (file-name-nondirectory file)))) + +(defvar package--post-download-archives-hook nil + "Hook run after the archive contents are downloaded. +Don't run this hook directly. It is meant to be run as part of +`package--update-downloads-in-progress'.") +(put 'package--post-download-archives-hook 'risky-local-variable t) + +(defun package--update-downloads-in-progress (entry) + "Remove ENTRY from `package--downloads-in-progress'. +Once it's empty, run `package--post-download-archives-hook'." + ;; Keep track of the downloading progress. + (setq package--downloads-in-progress + (remove entry package--downloads-in-progress)) + ;; If this was the last download, run the hook. + (unless package--downloads-in-progress + (package--build-compatibility-table) + (package-read-all-archive-contents) + ;; We message before running the hook, so the hook can give + ;; messages as well. + (message "Package refresh done") + (run-hooks 'package--post-download-archives-hook))) + +(defun package--download-one-archive (archive file &optional async) + "Retrieve an archive file FILE from ARCHIVE, and cache it. +ARCHIVE should be a cons cell of the form (NAME . LOCATION), +similar to an entry in `package-alist'. Save the cached copy to +\"archives/NAME/FILE\" in `package-user-dir'." + (package--with-work-buffer-async (cdr archive) file async + (let* ((location (cdr archive)) + (name (car archive)) + (content (buffer-string)) + (dir (expand-file-name (format "archives/%s" name) package-user-dir)) + (local-file (expand-file-name file dir))) + (when (listp (read-from-string content)) + (make-directory dir t) + (if (or (not package-check-signature) + (member archive package-unsigned-archives)) + ;; If we don't care about the signature, save the file and + ;; we're done. + (progn (write-region content nil local-file nil 'silent) + (package--update-downloads-in-progress archive)) + ;; If we care, check it (perhaps async) and *then* write the file. + (package--check-signature + location file content async + (lambda (&optional good-sigs) + (unless (or good-sigs (eq package-check-signature 'allow-unsigned)) + (error "Unsigned archive `%s'" name)) + ;; Write out the archives file. + (write-region content nil local-file nil 'silent) + ;; Write out good signatures into archive-contents.signed file. + (when good-sigs + (write-region (mapconcat #'epg-signature-to-string good-sigs "\n") + nil (concat local-file ".signed") nil 'silent)) + (package--update-downloads-in-progress archive)))))))) + +(defun package--download-and-read-archives (&optional async) + "Download descriptions of all `package-archives' and read them. +This populates `package-archive-contents'. If ASYNC is non-nil, +perform the downloads asynchronously." + ;; The downloaded archive contents will be read as part of + ;; `package--update-downloads-in-progress'. + (setq package--downloads-in-progress package-archives) + (dolist (archive package-archives) + (condition-case-unless-debug nil + (package--download-one-archive archive "archive-contents" async) + (error (message "Failed to download `%s' archive." + (car archive)))))) + +;;;###autoload +(defun package-refresh-contents (&optional async) + "Download descriptions of all configured ELPA packages. +For each archive configured in the variable `package-archives', +inform Emacs about the latest versions of all packages it offers, +and make them available for download. +Optional argument ASYNC specifies whether to perform the +downloads in the background." + (interactive) + ;; FIXME: Do it asynchronously. + (unless (file-exists-p package-user-dir) + (make-directory package-user-dir t)) + (let ((default-keyring (expand-file-name "package-keyring.gpg" + data-directory))) + (when (and package-check-signature (file-exists-p default-keyring)) + (condition-case-unless-debug error + (progn + (epg-check-configuration (epg-configuration)) + (package-import-keyring default-keyring)) + (error (message "Cannot import default keyring: %S" (cdr error)))))) + (package--download-and-read-archives async)) + + +;;; Dependency Management +;; Calculating the full transaction necessary for an installation, +;; keeping track of which packages were installed strictly as +;; dependencies, and determining which packages cannot be removed +;; because they are dependencies. (defun package-compute-transaction (packages requirements &optional seen) "Return a list of packages to be installed, including PACKAGES. PACKAGES should be a list of `package-desc'. @@ -1097,109 +1528,20 @@ but version %s required" (cons found seen)))))))) packages) -(defun package-read-from-string (str) - "Read a Lisp expression from STR. -Signal an error if the entire string was not used." - (let* ((read-data (read-from-string str)) - (more-left - (condition-case nil - ;; The call to `ignore' suppresses a compiler warning. - (progn (ignore (read-from-string - (substring str (cdr read-data)))) - t) - (end-of-file nil)))) - (if more-left - (error "Can't read whole string") - (car read-data)))) - -(defun package--read-archive-file (file) - "Re-read archive file FILE, if it exists. -Will return the data from the file, or nil if the file does not exist. -Will throw an error if the archive version is too new." - (let ((filename (expand-file-name file package-user-dir))) - (when (file-exists-p filename) - (with-temp-buffer - (insert-file-contents-literally filename) - (let ((contents (read (current-buffer)))) - (if (> (car contents) package-archive-version) - (error "Package archive version %d is higher than %d" - (car contents) package-archive-version)) - (cdr contents)))))) - -(defun package-read-all-archive-contents () - "Re-read `archive-contents', if it exists. -If successful, set `package-archive-contents'." - (setq package-archive-contents nil) - (dolist (archive package-archives) - (package-read-archive-contents (car archive)))) - -(defun package-read-archive-contents (archive) - "Re-read archive contents for ARCHIVE. -If successful, set the variable `package-archive-contents'. -If the archive version is too new, signal an error." - ;; Version 1 of 'archive-contents' is identical to our internal - ;; representation. - (let* ((contents-file (format "archives/%s/archive-contents" archive)) - (contents (package--read-archive-file contents-file))) - (when contents - (dolist (package contents) - (package--add-to-archive-contents package archive))))) - -;; Package descriptor objects used inside the "archive-contents" file. -;; Changing this defstruct implies changing the format of the -;; "archive-contents" files. -(cl-defstruct (package--ac-desc - (:constructor package-make-ac-desc (version reqs summary kind extras)) - (:copier nil) - (:type vector)) - version reqs summary kind extras) - -(defun package--add-to-archive-contents (package archive) - "Add the PACKAGE from the given ARCHIVE if necessary. -PACKAGE should have the form (NAME . PACKAGE--AC-DESC). -Also, add the originating archive to the `package-desc' structure." - (let* ((name (car package)) - (version (package--ac-desc-version (cdr package))) - (pkg-desc - (package-desc-create - :name name - :version version - :reqs (package--ac-desc-reqs (cdr package)) - :summary (package--ac-desc-summary (cdr package)) - :kind (package--ac-desc-kind (cdr package)) - :archive archive - :extras (and (> (length (cdr package)) 4) - ;; Older archive-contents files have only 4 - ;; elements here. - (package--ac-desc-extras (cdr package))))) - (pinned-to-archive (assoc name package-pinned-packages))) - ;; Skip entirely if pinned to another archive. - (when (not (and pinned-to-archive - (not (equal (cdr pinned-to-archive) archive)))) - (setq package-archive-contents - (package--append-to-alist pkg-desc package-archive-contents))))) - -(defun package--append-to-alist (pkg-desc alist) - "Append an entry for PKG-DESC to the start of ALIST and return it. -This entry takes the form (`package-desc-name' PKG-DESC). - -If ALIST already has an entry with this name, destructively add -PKG-DESC to the cdr of this entry instead, sorted by version -number." - (let* ((name (package-desc-name pkg-desc)) - (priority-version (package-desc-priority-version pkg-desc)) - (existing-packages (assq name alist))) - (if (not existing-packages) - (cons (list name pkg-desc) - alist) - (while (if (and (cdr existing-packages) - (version-list-< priority-version - (package-desc-priority-version - (cadr existing-packages)))) - (setq existing-packages (cdr existing-packages)) - (push pkg-desc (cdr existing-packages)) - nil)) - alist))) +(defun package--find-non-dependencies () + "Return a list of installed packages which are not dependencies. +Finds all packages in `package-alist' which are not dependencies +of any other packages. +Used to populate `package-selected-packages'." + (let ((dep-list + (delete-dups + (apply #'append + (mapcar (lambda (p) (mapcar #'car (package-desc-reqs (cadr p)))) + package-alist))))) + (cl-loop for p in package-alist + for name = (car p) + unless (memq name dep-list) + collect name))) (defun package--user-selected-p (pkg) "Return non-nil if PKG is a package was installed by the user. @@ -1212,6 +1554,153 @@ if it is still empty." (setq package-selected-packages (package--find-non-dependencies)))) (memq pkg package-selected-packages)) +(defun package--get-deps (pkg &optional only) + (let* ((pkg-desc (cadr (assq pkg package-alist))) + (direct-deps (cl-loop for p in (package-desc-reqs pkg-desc) + for name = (car p) + when (assq name package-alist) + collect name)) + (indirect-deps (unless (eq only 'direct) + (delete-dups + (cl-loop for p in direct-deps + append (package--get-deps p)))))) + (cl-case only + (direct direct-deps) + (separate (list direct-deps indirect-deps)) + (indirect indirect-deps) + (t (delete-dups (append direct-deps indirect-deps)))))) + +(defun package--removable-packages () + "Return a list of names of packages no longer needed. +These are packages which are neither contained in +`package-selected-packages' nor a dependency of one that is." + (let ((needed (cl-loop for p in package-selected-packages + if (assq p package-alist) + ;; `p' and its dependencies are needed. + append (cons p (package--get-deps p))))) + (cl-loop for p in (mapcar #'car package-alist) + unless (memq p needed) + collect p))) + +(defun package--used-elsewhere-p (pkg-desc &optional pkg-list) + "Non-nil if PKG-DESC is a dependency of a package in PKG-LIST. +Return the first package found in PKG-LIST of which PKG is a +dependency. + +When not specified, PKG-LIST defaults to `package-alist' +with PKG-DESC entry removed." + (unless (string= (package-desc-status pkg-desc) "obsolete") + (let ((pkg (package-desc-name pkg-desc))) + (cl-loop with alist = (or pkg-list + (remove (assq pkg package-alist) + package-alist)) + for p in alist thereis + (and (memq pkg (mapcar #'car (package-desc-reqs (cadr p)))) + (car p)))))) + +(defun package--sort-deps-in-alist (package only) + "Return a list of dependencies for PACKAGE sorted by dependency. +PACKAGE is included as the first element of the returned list. +ONLY is an alist associating package names to package objects. +Only these packages will be in the return value an their cdrs are +destructively set to nil in ONLY." + (let ((out)) + (dolist (dep (package-desc-reqs package)) + (when-let ((cell (assq (car dep) only)) + (dep-package (cdr-safe cell))) + (setcdr cell nil) + (setq out (append (package--sort-deps-in-alist dep-package only) + out)))) + (cons package out))) + +(defun package--sort-by-dependence (package-list) + "Return PACKAGE-LIST sorted by dependence. +That is, any element of the returned list is guaranteed to not +directly depend on any elements that come before it. + +PACKAGE-LIST is a list of package-desc objects. +Indirect dependencies are guaranteed to be returned in order only +if all the in-between dependencies are also in PACKAGE-LIST." + (let ((alist (mapcar (lambda (p) (cons (package-desc-name p) p)) package-list)) + out-list) + (dolist (cell alist out-list) + ;; `package--sort-deps-in-alist' destructively changes alist, so + ;; some cells might already be empty. We check this here. + (when-let ((pkg-desc (cdr cell))) + (setcdr cell nil) + (setq out-list + (append (package--sort-deps-in-alist pkg-desc alist) + out-list)))))) + + +;;; Installation Functions +;; As opposed to the previous section (which listed some underlying +;; functions necessary for installation), this one contains the actual +;; functions that install packages. The package itself can be +;; installed in a variety of ways (archives, buffer, file), but +;; requirements (dependencies) are always satisfied by looking in +;; `package-archive-contents'. +(defun package-archive-base (desc) + "Return the archive containing the package NAME." + (cdr (assoc (package-desc-archive desc) package-archives))) + +(defun package-install-from-archive (pkg-desc) + "Download and install a tar package." + ;; This won't happen, unless the archive is doing something wrong. + (when (eq (package-desc-kind pkg-desc) 'dir) + (error "Can't install directory package from archive")) + (let* ((location (package-archive-base pkg-desc)) + (file (concat (package-desc-full-name pkg-desc) + (package-desc-suffix pkg-desc))) + (sig-file (concat file ".sig")) + good-signatures pkg-descs) + (package--with-work-buffer location file + (if (and package-check-signature + (not (member (package-desc-archive pkg-desc) + package-unsigned-archives))) + (if (package--archive-file-exists-p location sig-file) + (setq good-signatures (package--check-signature location file)) + (unless (eq package-check-signature 'allow-unsigned) + (error "Unsigned package: `%s'" + (package-desc-name pkg-desc))))) + (package-unpack pkg-desc)) + ;; Here the package has been installed successfully, mark it as + ;; signed if appropriate. + (when good-signatures + ;; Write out good signatures into NAME-VERSION.signed file. + (write-region (mapconcat #'epg-signature-to-string good-signatures "\n") + nil + (expand-file-name + (concat (package-desc-full-name pkg-desc) + ".signed") + package-user-dir) + nil 'silent) + ;; Update the old pkg-desc which will be shown on the description buffer. + (setf (package-desc-signed pkg-desc) t) + ;; Update the new (activated) pkg-desc as well. + (setq pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist))) + (if pkg-descs + (setf (package-desc-signed (car pkg-descs)) t))))) + +(defun package-installed-p (package &optional min-version) + "Return true if PACKAGE, of MIN-VERSION or newer, is installed. +If PACKAGE is a symbol, it is the package name and MIN-VERSION +should be a version list. + +If PACKAGE is a package-desc object, MIN-VERSION is ignored." + (unless package--initialized (error "package.el is not yet initialized!")) + (if (package-desc-p package) + (let ((dir (package-desc-dir package))) + (and (stringp dir) + (file-exists-p dir))) + (or + (let ((pkg-descs (cdr (assq package package-alist)))) + (and pkg-descs + (version-list-<= min-version + (package-desc-version (car pkg-descs))))) + ;; Also check built-in packages. + (package-built-in-p package min-version)))) + (defun package-download-transaction (packages) "Download and install all the packages in PACKAGES. PACKAGES should be a list of package-desc. @@ -1221,15 +1710,15 @@ using `package-compute-transaction'." (mapc #'package-install-from-archive packages)) ;;;###autoload -(defun package-install (pkg &optional mark-selected) +(defun package-install (pkg &optional dont-select) "Install the package PKG. PKG can be a package-desc or the package name of one the available packages in an archive in `package-archives'. Interactively, prompt for its name. -If called interactively or if MARK-SELECTED is non-nil, add PKG -to `package-selected-packages'. +If called interactively or if DONT-SELECT nil, add PKG to +`package-selected-packages'. -if PKG is a package-desc and it is already installed, don't try +If PKG is a package-desc and it is already installed, don't try to install it but still mark it as selected." (interactive (progn @@ -1247,11 +1736,11 @@ to install it but still mark it as selected." (symbol-name (car elt)))) package-archive-contents)) nil t)) - t))) + nil))) (let ((name (if (package-desc-p pkg) (package-desc-name pkg) pkg))) - (when (and mark-selected (not (package--user-selected-p name))) + (unless (or dont-select (package--user-selected-p name)) (customize-save-variable 'package-selected-packages (cons name package-selected-packages)))) (if (package-desc-p pkg) @@ -1264,20 +1753,6 @@ to install it but still mark it as selected." (package-compute-transaction () (list (list pkg)))))) -;;;###autoload -(defun package-reinstall (pkg) - "Reinstall package PKG. -PKG shoul be either a symbol, the package name, or a package-desc -object." - (interactive (list (intern (completing-read - "Reinstall package: " - (mapcar #'symbol-name - (mapcar #'car package-alist)))))) - (package-delete - (if (package-desc-p pkg) pkg (cadr (assq pkg package-alist))) - 'force 'nosave) - (package-install pkg)) - (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. If the result looks like a dotted numeric version, return it. @@ -1292,120 +1767,6 @@ Otherwise return nil." (declare-function lm-homepage "lisp-mnt" (&optional file)) -(defun package--prepare-dependencies (deps) - "Turn DEPS into an acceptable list of dependencies. - -Any parts missing a version string get a default version string -of \"0\" (meaning any version) and an appropriate level of lists -is wrapped around any parts requiring it." - (cond - ((not (listp deps)) - (error "Invalid requirement specifier: %S" deps)) - (t (mapcar (lambda (dep) - (cond - ((symbolp dep) `(,dep "0")) - ((stringp dep) - (error "Invalid requirement specifier: %S" dep)) - ((and (listp dep) (null (cdr dep))) - (list (car dep) "0")) - (t dep))) - deps)))) - -(defun package-buffer-info () - "Return a `package-desc' describing the package in the current buffer. - -If the buffer does not contain a conforming package, signal an -error. If there is a package, narrow the buffer to the file's -boundaries." - (goto-char (point-min)) - (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t) - (error "Package lacks a file header")) - (let ((file-name (match-string-no-properties 1)) - (desc (match-string-no-properties 2)) - (start (line-beginning-position))) - (unless (search-forward (concat ";;; " file-name ".el ends here")) - (error "Package lacks a terminating comment")) - ;; Try to include a trailing newline. - (forward-line) - (narrow-to-region start (point)) - (require 'lisp-mnt) - ;; Use some headers we've invented to drive the process. - (let* ((requires-str (lm-header "package-requires")) - ;; Prefer Package-Version; if defined, the package author - ;; probably wants us to use it. Otherwise try Version. - (pkg-version - (or (package-strip-rcs-id (lm-header "package-version")) - (package-strip-rcs-id (lm-header "version")))) - (homepage (lm-homepage))) - (unless pkg-version - (error - "Package lacks a \"Version\" or \"Package-Version\" header")) - (package-desc-from-define - file-name pkg-version desc - (if requires-str - (package--prepare-dependencies - (package-read-from-string requires-str))) - :kind 'single - :url homepage)))) - -(declare-function tar-get-file-descriptor "tar-mode" (file)) -(declare-function tar--extract "tar-mode" (descriptor)) - -(defun package-tar-file-info () - "Find package information for a tar file. -The return result is a `package-desc'." - (cl-assert (derived-mode-p 'tar-mode)) - (let* ((dir-name (file-name-directory - (tar-header-name (car tar-parse-info)))) - (desc-file (package--description-file dir-name)) - (tar-desc (tar-get-file-descriptor (concat dir-name desc-file)))) - (unless tar-desc - (error "No package descriptor file found")) - (with-current-buffer (tar--extract tar-desc) - (unwind-protect - (or (package--read-pkg-desc 'tar) - (error "Can't find define-package in %s" - (tar-header-name tar-desc))) - (kill-buffer (current-buffer)))))) - -(defun package-dir-info () - "Find package information for a directory. -The return result is a `package-desc'." - (cl-assert (derived-mode-p 'dired-mode)) - (let* ((desc-file (package--description-file default-directory))) - (if (file-readable-p desc-file) - (with-temp-buffer - (insert-file-contents desc-file) - (package--read-pkg-desc 'dir)) - (let ((files (directory-files default-directory t "\\.el\\'" t)) - info) - (while files - (with-temp-buffer - (insert-file-contents (pop files)) - ;; When we find the file with the data, - (when (setq info (ignore-errors (package-buffer-info))) - ;; stop looping, - (setq files nil) - ;; set the 'dir kind, - (setf (package-desc-kind info) 'dir)))) - ;; and return the info. - info)))) - -(defun package--read-pkg-desc (kind) - "Read a `define-package' form in current buffer. -Return the pkg-desc, with desc-kind set to KIND." - (goto-char (point-min)) - (unwind-protect - (let* ((pkg-def-parsed (read (current-buffer))) - (pkg-desc - (when (eq (car pkg-def-parsed) 'define-package) - (apply #'package-desc-from-define - (append (cdr pkg-def-parsed)))))) - (when pkg-desc - (setf (package-desc-kind pkg-desc) kind) - pkg-desc)))) - - ;;;###autoload (defun package-install-from-buffer () "Install a package from the current buffer. @@ -1457,22 +1818,6 @@ The file can either be a tar file or an Emacs Lisp file." (when (string-match "\\.tar\\'" file) (tar-mode))) (package-install-from-buffer))) -(defun package--get-deps (pkg &optional only) - (let* ((pkg-desc (cadr (assq pkg package-alist))) - (direct-deps (cl-loop for p in (package-desc-reqs pkg-desc) - for name = (car p) - when (assq name package-alist) - collect name)) - (indirect-deps (unless (eq only 'direct) - (delete-dups - (cl-loop for p in direct-deps - append (package--get-deps p)))))) - (cl-case only - (direct direct-deps) - (separate (list direct-deps indirect-deps)) - (indirect indirect-deps) - (t (delete-dups (append direct-deps indirect-deps)))))) - ;;;###autoload (defun package-install-user-selected-packages () "Ensure packages in `package-selected-packages' are installed. @@ -1495,22 +1840,8 @@ If some packages are not installed propose to install them." (mapc #'package-install lst)) (message "All your packages are already installed"))))) -(defun package--used-elsewhere-p (pkg-desc &optional pkg-list) - "Non-nil if PKG-DESC is a dependency of a package in PKG-LIST. -Return the first package found in PKG-LIST of which PKG is a -dependency. - -When not specified, PKG-LIST defaults to `package-alist' -with PKG-DESC entry removed." - (unless (string= (package-desc-status pkg-desc) "obsolete") - (let ((pkg (package-desc-name pkg-desc))) - (cl-loop with alist = (or pkg-list - (remove (assq pkg package-alist) - package-alist)) - for p in alist thereis - (and (memq pkg (mapcar #'car (package-desc-reqs (cadr p)))) - (car p)))))) - + +;;; Package Deletion (defun package--newest-p (pkg) "Return t if PKG is the newest package with its name." (equal (cadr (assq (package-desc-name pkg) package-alist)) @@ -1534,7 +1865,7 @@ If NOSAVE is non-nil, the package is not removed from ;; `package-selected-packages' even if it can't be deleted. (when (and (null nosave) (package--user-selected-p name) - ;; Don't delesect if this is an older version of an + ;; Don't deselect if this is an older version of an ;; upgraded package. (package--newest-p pkg-desc)) (customize-save-variable @@ -1565,17 +1896,19 @@ If NOSAVE is non-nil, the package is not removed from (setq package-alist (delq pkgs package-alist)))) (message "Package `%s' deleted." (package-desc-full-name pkg-desc)))))) -(defun package--removable-packages () - "Return a list of names of packages no longer needed. -These are packages which are neither contained in -`package-selected-packages' nor a dependency of one that is." - (let ((needed (cl-loop for p in package-selected-packages - if (assq p package-alist) - ;; `p' and its dependencies are needed. - append (cons p (package--get-deps p))))) - (cl-loop for p in (mapcar #'car package-alist) - unless (memq p needed) - collect p))) +;;;###autoload +(defun package-reinstall (pkg) + "Reinstall package PKG. +PKG should be either a symbol, the package name, or a package-desc +object." + (interactive (list (intern (completing-read + "Reinstall package: " + (mapcar #'symbol-name + (mapcar #'car package-alist)))))) + (package-delete + (if (package-desc-p pkg) pkg (cadr (assq pkg package-alist))) + 'force 'nosave) + (package-install pkg 'dont-select)) ;;;###autoload (defun package-autoremove () @@ -1599,134 +1932,8 @@ will be deleted." (mapconcat #'symbol-name removable ", "))) (mapc (lambda (p) (package-delete (cadr (assq p package-alist)) t)) - removable) - (message "Nothing to autoremove")))))) - -(defun package-archive-base (desc) - "Return the archive containing the package NAME." - (cdr (assoc (package-desc-archive desc) package-archives))) - -(defun package-archive-priority (archive) - "Return the priority of ARCHIVE. - -The archive priorities are specified in -`package-archive-priorities'. If not given there, the priority -defaults to 0." - (or (cdr (assoc archive package-archive-priorities)) - 0)) - -(defun package-desc-priority-version (pkg-desc) - "Return the version PKG-DESC with the archive priority prepended. - -This allows for easy comparison of package versions from -different archives if archive priorities are meant to be taken in -consideration." - (cons (package-archive-priority - (package-desc-archive pkg-desc)) - (package-desc-version pkg-desc))) - -(defun package--download-one-archive (archive file) - "Retrieve an archive file FILE from ARCHIVE, and cache it. -ARCHIVE should be a cons cell of the form (NAME . LOCATION), -similar to an entry in `package-alist'. Save the cached copy to -\"archives/NAME/archive-contents\" in `package-user-dir'." - (let ((dir (expand-file-name (format "archives/%s" (car archive)) - package-user-dir)) - (sig-file (concat file ".sig")) - good-signatures) - (package--with-work-buffer (cdr archive) file - ;; Check signature of archive-contents, if desired. - (if (and package-check-signature - (not (member archive package-unsigned-archives))) - (if (package--archive-file-exists-p (cdr archive) sig-file) - (setq good-signatures (package--check-signature (cdr archive) - file)) - (unless (eq package-check-signature 'allow-unsigned) - (error "Unsigned archive `%s'" - (car archive))))) - ;; Read the retrieved buffer to make sure it is valid (e.g. it - ;; may fetch a URL redirect page). - (when (listp (read (current-buffer))) - (make-directory dir t) - (write-region nil nil (expand-file-name file dir) nil 'silent))) - (when good-signatures - ;; Write out good signatures into archive-contents.signed file. - (write-region (mapconcat #'epg-signature-to-string good-signatures "\n") - nil - (expand-file-name (concat file ".signed") dir) - nil 'silent)))) - -(declare-function epg-check-configuration "epg-config" - (config &optional minimum-version)) -(declare-function epg-configuration "epg-config" ()) -(declare-function epg-import-keys-from-file "epg" (context keys)) - -;;;###autoload -(defun package-import-keyring (&optional file) - "Import keys from FILE." - (interactive "fFile: ") - (setq file (expand-file-name file)) - (let ((context (epg-make-context 'OpenPGP)) - (homedir (expand-file-name "gnupg" package-user-dir))) - (with-file-modes 448 - (make-directory homedir t)) - (setf (epg-context-home-directory context) homedir) - (message "Importing %s..." (file-name-nondirectory file)) - (epg-import-keys-from-file context file) - (message "Importing %s...done" (file-name-nondirectory file)))) - -;;;###autoload -(defun package-refresh-contents () - "Download the ELPA archive description if needed. -This informs Emacs about the latest versions of all packages, and -makes them available for download." - (interactive) - ;; FIXME: Do it asynchronously. - (unless (file-exists-p package-user-dir) - (make-directory package-user-dir t)) - (let ((default-keyring (expand-file-name "package-keyring.gpg" - data-directory))) - (when (and package-check-signature (file-exists-p default-keyring)) - (condition-case-unless-debug error - (progn - (epg-check-configuration (epg-configuration)) - (package-import-keyring default-keyring)) - (error (message "Cannot import default keyring: %S" (cdr error)))))) - (dolist (archive package-archives) - (condition-case-unless-debug nil - (package--download-one-archive archive "archive-contents") - (error (message "Failed to download `%s' archive." - (car archive))))) - (package-read-all-archive-contents)) - -(defun package--find-non-dependencies () - "Return a list of installed packages which are not dependencies. -Finds all packages in `package-alist' which are not dependencies -of any other packages. -Used to populate `package-selected-packages'." - (let ((dep-list - (delete-dups - (apply #'append - (mapcar (lambda (p) (mapcar #'car (package-desc-reqs (cadr p)))) - package-alist))))) - (cl-loop for p in package-alist - for name = (car p) - unless (memq name dep-list) - collect name))) - -;;;###autoload -(defun package-initialize (&optional no-activate) - "Load Emacs Lisp packages, and activate them. -The variable `package-load-list' controls which packages to load. -If optional arg NO-ACTIVATE is non-nil, don't activate packages." - (interactive) - (setq package-alist nil) - (package-load-all-descriptors) - (package-read-all-archive-contents) - (unless no-activate - (dolist (elt package-alist) - (package-activate (car elt)))) - (setq package--initialized t)) + removable)) + (message "Nothing to autoremove"))))) ;;;; Package description buffer. @@ -1761,6 +1968,8 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (with-current-buffer standard-output (describe-package-1 package))))) +(declare-function lm-commentary "lisp-mnt" (&optional file)) + (defun describe-package-1 (pkg) (require 'lisp-mnt) (let* ((desc (or @@ -1781,7 +1990,10 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (built-in (eq pkg-dir 'builtin)) (installable (and archive (not built-in))) (status (if desc (package-desc-status desc) "orphan")) + (incompatible-reason (package--incompatible-p desc)) (signed (if desc (package-desc-signed desc)))) + (when incompatible-reason + (setq status "incompatible")) (prin1 name) (princ " is ") (princ (if (memq (aref status 0) '(?a ?e ?i ?o ?u)) "an " "a ")) @@ -1812,6 +2024,12 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (if signed (insert ".") (insert " (unsigned)."))) + (incompatible-reason + (insert (propertize "Incompatible" 'face font-lock-warning-face) + " because it depends on ") + (if (stringp incompatible-reason) + (insert "Emacs " incompatible-reason ".") + (insert "uninstallable packages."))) (installable (insert (capitalize status)) (insert " from " (format "%s" archive)) @@ -1832,19 +2050,22 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (setq reqs (if desc (package-desc-reqs desc))) (when reqs (insert " " (propertize "Requires" 'font-lock-face 'bold) ": ") - (let ((first t) - name vers text) + (let ((first t)) (dolist (req reqs) - (setq name (car req) - vers (cadr req) - text (format "%s-%s" (symbol-name name) - (package-version-join vers))) - (cond (first (setq first nil)) - ((>= (+ 2 (current-column) (length text)) - (window-width)) - (insert ",\n ")) - (t (insert ", "))) - (help-insert-xref-button text 'help-package name)) + (let* ((name (car req)) + (vers (cadr req)) + (text (format "%s-%s" (symbol-name name) + (package-version-join vers))) + (reason (if (and (listp incompatible-reason) + (assq name incompatible-reason)) + " (not available)" ""))) + (cond (first (setq first nil)) + ((>= (+ 2 (current-column) (length text) (length reason)) + (window-width)) + (insert ",\n ")) + (t (insert ", "))) + (help-insert-xref-button text 'help-package name) + (insert reason))) (insert "\n"))) (insert " " (propertize "Summary" 'font-lock-face 'bold) ": " (if desc (package-desc-summary desc)) "\n") @@ -1929,7 +2150,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (let ((pkg-desc (button-get button 'package-desc))) (when (y-or-n-p (format "Install package `%s'? " (package-desc-full-name pkg-desc))) - (package-install pkg-desc 1) + (package-install pkg-desc nil) (revert-buffer nil t) (goto-char (point-min))))) @@ -2020,7 +2241,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." map) "Local keymap for `package-menu-mode' buffers.") -(defvar package-menu--new-package-list nil +(defvar-local package-menu--new-package-list nil "List of newly-available packages since `list-packages' was last called.") (define-derived-mode package-menu-mode tabulated-list-mode "Package Menu" @@ -2054,6 +2275,36 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." (defvar package-list-unsigned nil "If non-nil, mention in the list which packages were installed w/o signature.") +(defvar package--emacs-version-list (version-to-list emacs-version) + "`emacs-version', as a list.") + +(defun package--incompatible-p (pkg &optional shallow) + "Return non-nil if PKG has no chance of being installable. +PKG is a package-desc object. + +If SHALLOW is non-nil, this only checks if PKG depends on a +higher `emacs-version' than the one being used. Otherwise, also +checks the viability of dependencies, according to +`package--compatibility-table'. + +If PKG requires an incompatible Emacs version, the return value +is this version (as a string). +If PKG requires incompatible packages, the return value is a list +of these dependencies, similar to the list returned by +`package-desc-reqs'." + (let* ((reqs (package-desc-reqs pkg)) + (version (cadr (assq 'emacs reqs)))) + (if (and version (version-list-< package--emacs-version-list version)) + (package-version-join version) + (unless shallow + (let (out) + (dolist (dep (package-desc-reqs pkg) out) + (let ((dep-name (car dep))) + (unless (eq 'emacs dep-name) + (let ((cv (gethash dep-name package--compatibility-table))) + (when (version-list-< (or cv '(0)) (or (cadr dep) '(0))) + (push dep out))))))))))) + (defun package-desc-status (pkg-desc) (let* ((name (package-desc-name pkg-desc)) (dir (package-desc-dir pkg-desc)) @@ -2072,6 +2323,7 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." ((version-list-< version hv) "obsolete") (t "disabled")))) ((package-built-in-p name version) "obsolete") + ((package--incompatible-p pkg-desc) "incompat") (dir ;One of the installed packages. (cond ((not (file-exists-p (package-desc-dir pkg-desc))) "deleted") @@ -2222,6 +2474,7 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." (`"installed" 'font-lock-comment-face) (`"dependency" 'font-lock-comment-face) (`"unsigned" 'font-lock-warning-face) + (`"incompat" 'font-lock-comment-face) (_ 'font-lock-warning-face)))) ; obsolete. (list pkg-desc `[,(list (symbol-name (package-desc-name pkg-desc)) @@ -2311,6 +2564,25 @@ If optional arg BUTTON is non-nil, describe its associated package." (aref (cadr entry) 2) ""))) +(defun package-archive-priority (archive) + "Return the priority of ARCHIVE. + +The archive priorities are specified in +`package-archive-priorities'. If not given there, the priority +defaults to 0." + (or (cdr (assoc archive package-archive-priorities)) + 0)) + +(defun package-desc-priority-version (pkg-desc) + "Return the version PKG-DESC with the archive priority prepended. + +This allows for easy comparison of package versions from +different archives if archive priorities are meant to be taken in +consideration." + (cons (package-archive-priority + (package-desc-archive pkg-desc)) + (package-desc-version pkg-desc))) + (defun package-menu--find-upgrades () (let (installed available upgrades) ;; Build list of installed/available packages in this buffer. @@ -2360,40 +2632,6 @@ call will upgrade the package." (length upgrades) (if (= (length upgrades) 1) "" "s"))))) -(defun package--sort-deps-in-alist (package only) - "Return a list of dependencies for PACKAGE sorted by dependency. -PACKAGE is included as the first element of the returned list. -ONLY is an alist associating package names to package objects. -Only these packages will be in the return value an their cdrs are -destructively set to nil in ONLY." - (let ((out)) - (dolist (dep (package-desc-reqs package)) - (when-let ((cell (assq (car dep) only)) - (dep-package (cdr-safe cell))) - (setcdr cell nil) - (setq out (append (package--sort-deps-in-alist dep-package only) - out)))) - (cons package out))) - -(defun package--sort-by-dependence (package-list) - "Return PACKAGE-LIST sorted by dependence. -That is, any element of the returned list is guaranteed to not -directly depend on any elements that come before it. - -PACKAGE-LIST is a list of package-desc objects. -Indirect dependencies are guaranteed to be returned in order only -if all the in-between dependencies are also in PACKAGE-LIST." - (let ((alist (mapcar (lambda (p) (cons (package-desc-name p) p)) package-list)) - out-list) - (dolist (cell alist out-list) - ;; `package--sort-deps-in-alist' destructively changes alist, so - ;; some cells might already be empty. We check this here. - (when-let ((pkg-desc (cdr cell))) - (setcdr cell nil) - (setq out-list - (append (package--sort-deps-in-alist pkg-desc alist) - out-list)))))) - (defun package-menu-execute (&optional noquery) "Perform marked Package Menu actions. Packages marked for installation are downloaded and installed; @@ -2427,13 +2665,11 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (mapconcat #'package-desc-full-name install-list ", "))))) (mapc (lambda (p) - ;; Mark as selected if it's the exact version of a - ;; package that's already installed, or if it's not - ;; installed at all. Don't mark if it's a new - ;; version of an installed package. - (package-install p (or (package-installed-p p) - (not (package-installed-p - (package-desc-name p)))))) + ;; Don't mark as selected if it's a new version of + ;; an installed package. + (package-install p (and (not (package-installed-p p)) + (package-installed-p + (package-desc-name p))))) install-list))) ;; Delete packages, prompting if necessary. (when delete-list @@ -2494,6 +2730,8 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." ((string= sB "built-in") nil) ((string= sA "obsolete") t) ((string= sB "obsolete") nil) + ((string= sA "incompat") t) + ((string= sB "incompat") nil) (t (string< sA sB))))) (defun package-menu--description-predicate (A B) @@ -2511,6 +2749,48 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (string< (or (package-desc-archive (car A)) "") (or (package-desc-archive (car B)) ""))) +(defvar-local package-menu--old-archive-contents nil + "`package-archive-contents' before the latest refresh.") + +(defun package-menu--populate-new-package-list () + "Decide which packages are new in `package-archives-contents'. +Store this list in `package-menu--new-package-list'." + ;; Find which packages are new. + (when package-menu--old-archive-contents + (dolist (elt package-archive-contents) + (unless (assq (car elt) package-menu--old-archive-contents) + (push (car elt) package-menu--new-package-list))) + (setq package-menu--old-archive-contents nil))) + +(defun package-menu--find-and-notify-upgrades () + "Notify the user of upgradable packages." + (when-let ((upgrades (package-menu--find-upgrades))) + (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading." + (length upgrades) + (if (= (length upgrades) 1) "" "s") + (substitute-command-keys "\\[package-menu-mark-upgrades]") + (if (= (length upgrades) 1) "it" "them")))) + +(defun package-menu--post-refresh () + "Check for new packages, revert the *Packages* buffer, and check for upgrades. +This function is called after `package-refresh-contents' is done. +It goes in `package--post-download-archives-hook', so that it +works with async refresh as well." + (package-menu--populate-new-package-list) + (let ((buf (get-buffer "*Packages*"))) + (when (buffer-live-p buf) + (with-current-buffer buf + (revert-buffer nil 'noconfirm)))) + (package-menu--find-and-notify-upgrades)) + +(defcustom package-menu-async t + "If non-nil, package-menu will use async operations when possible. +Currently, only the refreshing of archive contents supports +asynchronous operations. Package transactions are still done +synchronously." + :type 'boolean + :group 'package) + ;;;###autoload (defun list-packages (&optional no-fetch) "Display a list of packages. @@ -2522,36 +2802,24 @@ The list is displayed in a buffer named `*Packages*'." ;; Initialize the package system if necessary. (unless package--initialized (package-initialize t)) - (let (old-archives new-packages) - (unless no-fetch - ;; Read the locally-cached archive-contents. - (package-read-all-archive-contents) - (setq old-archives package-archive-contents) - ;; Fetch the remote list of packages. - (package-refresh-contents) - ;; Find which packages are new. - (dolist (elt package-archive-contents) - (unless (assq (car elt) old-archives) - (push (car elt) new-packages)))) - - ;; Generate the Package Menu. - (let ((buf (get-buffer-create "*Packages*"))) - (with-current-buffer buf - (package-menu-mode) - (set (make-local-variable 'package-menu--new-package-list) - new-packages) - (package-menu--generate nil t)) - ;; The package menu buffer has keybindings. If the user types - ;; `M-x list-packages', that suggests it should become current. - (switch-to-buffer buf)) - - (let ((upgrades (package-menu--find-upgrades))) - (if upgrades - (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading." - (length upgrades) - (if (= (length upgrades) 1) "" "s") - (substitute-command-keys "\\[package-menu-mark-upgrades]") - (if (= (length upgrades) 1) "it" "them")))))) + ;; Integrate the package-menu with updating the archives. + (add-hook 'package--post-download-archives-hook + #'package-menu--post-refresh) + + (unless no-fetch + (setq package-menu--old-archive-contents package-archive-contents) + (setq package-menu--new-package-list nil) + ;; Fetch the remote list of packages. + (package-refresh-contents package-menu-async)) + + ;; Generate the Package Menu. + (let ((buf (get-buffer-create "*Packages*"))) + (with-current-buffer buf + (package-menu-mode) + (package-menu--generate nil t)) + ;; The package menu buffer has keybindings. If the user types + ;; `M-x list-packages', that suggests it should become current. + (switch-to-buffer buf))) ;;;###autoload (defalias 'package-list-packages 'list-packages) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 057b12894f9..3a2fa4fdc81 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -103,7 +103,6 @@ UPatterns can take the following forms: (or UPAT...) matches if any of the patterns matches. (and UPAT...) matches if all the patterns match. 'VAL matches if the object is `equal' to VAL - `QPAT matches if the QPattern QPAT matches. (pred FUN) matches if FUN applied to the object returns non-nil. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. (let UPAT EXP) matches if EXP matches UPAT. @@ -111,14 +110,6 @@ UPatterns can take the following forms: If a SYMBOL is used twice in the same pattern (i.e. the pattern is \"non-linear\"), then the second occurrence is turned into an `eq'uality test. -QPatterns can take the following forms: - (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. - [QPAT1 QPAT2..QPATn] matches a vector of length n and QPAT1..QPATn match - its 0..(n-1)th elements, respectively. - ,UPAT matches if the UPattern UPAT matches. - STRING matches if the object is `equal' to STRING. - ATOM matches if the object is `eq' to ATOM. - FUN can take the form SYMBOL or (lambda ARGS BODY) in which case it's called with one argument. (F ARG1 .. ARGn) in which case F gets called with an n+1'th argument @@ -129,7 +120,10 @@ FUN is assumed to be pure, i.e. it can be dropped if its result is not used, and two identical calls can be merged into one. 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))))" +`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a)))) + +Additional patterns can be defined via `pcase-defmacro'. +Currently, the following patterns are provided this way:" (declare (indent 1) (debug (form &rest (pcase-UPAT body)))) ;; 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 @@ -154,6 +148,26 @@ like `(,a . ,(pred (< a))) or, with more checks: ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2) expansion)))) +;; FIXME: Obviously, this will collide with nadvice's use of +;; function-documentation if we happen to advise `pcase'. +(put 'pcase 'function-documentation '(pcase--make-docstring)) +(defun pcase--make-docstring () + (let* ((main (documentation (symbol-function 'pcase) 'raw)) + (ud (help-split-fundoc main 'pcase))) + (with-temp-buffer + (insert (or (cdr ud) main)) + (mapatoms + (lambda (symbol) + (let ((me (get symbol 'pcase-macroexpander))) + (when me + (insert "\n\n-- ") + (let* ((doc (documentation me 'raw))) + (setq doc (help-fns--signature symbol doc me + (indirect-function me))) + (insert "\n" (or doc "Not documented."))))))) + (let ((combined-doc (buffer-string))) + (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) + ;;;###autoload (defmacro pcase-exhaustive (exp &rest cases) "The exhaustive version of `pcase' (which see)." @@ -166,23 +180,26 @@ like `(,a . ,(pred (< a))) or, with more checks: ;;;###autoload (defmacro pcase-lambda (lambda-list &rest body) - "Like `lambda' but allow each argument to be a pattern. -`&rest' argument is supported." + "Like `lambda' but allow each argument to be a UPattern. +I.e. accepts the usual &optional and &rest keywords, but every +formal argument can be any pattern accepted by `pcase' (a mere +variable name being but a special case of it)." (declare (doc-string 2) (indent defun) - (debug ((&rest pcase-UPAT &optional ["&rest" pcase-UPAT]) body))) - (let ((args (make-symbol "args")) - (pats (mapcar (lambda (u) - (unless (eq u '&rest) - (if (eq (car-safe u) '\`) (cadr u) (list '\, u)))) - lambda-list)) - (body (macroexp-parse-body body))) - ;; Handle &rest - (when (eq nil (car (last pats 2))) - (setq pats (append (butlast pats 2) (car (last pats))))) - `(lambda (&rest ,args) - ,@(remq nil (car body)) - (pcase ,args - (,(list '\` pats) . ,(cdr body)))))) + (debug ((&rest pcase-UPAT) body))) + (let* ((bindings ()) + (parsed-body (macroexp-parse-body body)) + (args (mapcar (lambda (pat) + (if (symbolp pat) + ;; Simple vars and &rest/&optional are just passed + ;; through unchanged. + pat + (let ((arg (make-symbol + (format "arg%s" (length bindings))))) + (push `(,pat ,arg) bindings) + arg))) + lambda-list))) + `(lambda ,args ,@(car parsed-body) + (pcase-let* ,(nreverse bindings) ,@(cdr parsed-body))))) (defun pcase--let* (bindings body) (cond @@ -344,9 +361,13 @@ of the form (UPAT EXP)." ;;;###autoload (defmacro pcase-defmacro (name args &rest body) "Define a pcase UPattern macro." - (declare (indent 2) (debug (def-name sexp def-body)) (doc-string 3)) - `(put ',name 'pcase-macroexpander - (lambda ,args ,@body))) + (declare (indent 2) (debug defun) (doc-string 3)) + (let ((fsym (intern (format "%s--pcase-macroexpander" name)))) + ;; Add the function via `fsym', so that an autoload cookie placed + ;; on a pcase-defmacro will cause the macro to be loaded on demand. + `(progn + (defun ,fsym ,args ,@body) + (put ',name 'pcase-macroexpander #',fsym)))) (defun pcase--match (val upat) "Build a MATCH structure, hoisting all `or's and `and's outside." @@ -561,6 +582,7 @@ MATCH is the pattern that needs to be matched, of the form: (cond ((eq 'pred (car-safe pat)) (cadr pat)) ((not (eq 'quote (car-safe pat))) nil) ((consp (cadr pat)) #'consp) + ((stringp (cadr pat)) #'stringp) ((vectorp (cadr pat)) #'vectorp) ((byte-code-function-p (cadr pat)) #'byte-code-function-p)))) @@ -807,6 +829,14 @@ Otherwise, it defers to REST which is a list of branches of the form (t (error "Incorrect MATCH %S" (car matches))))) (pcase-defmacro \` (qpat) + "Backquote-style pcase patterns. +QPAT can take the following forms: + (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. + [QPAT1 QPAT2..QPATn] matches a vector of length n and QPAT1..QPATn match + its 0..(n-1)th elements, respectively. + ,UPAT matches if the UPattern UPAT matches. + STRING matches if the object is `equal' to STRING. + ATOM matches if the object is `eq' to ATOM." (cond ((eq (car-safe qpat) '\,) (cadr qpat)) ((vectorp qpat) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 025d94e10b9..c5f5906e7e5 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -4,7 +4,8 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: sequences -;; Version: 1.1 +;; Version: 1.3 +;; Package: seq ;; Maintainer: emacs-devel@gnu.org @@ -32,8 +33,8 @@ ;; ;; All provided functions work on lists, strings and vectors. ;; -;; Functions taking a predicate or a function iterating over the -;; sequence as argument take the function as their first argument and +;; Functions taking a predicate or iterating over a sequence using a +;; function as argument take the function as their first argument and ;; the sequence as their second argument. All other functions take ;; the sequence as their first argument. ;; @@ -171,9 +172,7 @@ The result is a sequence of the same type as SEQ." (if (listp seq) (sort (seq-copy seq) pred) (let ((result (seq-sort pred (append seq nil)))) - (cond ((stringp seq) (concat result)) - ((vectorp seq) (vconcat result)) - (t (error "Unsupported sequence: %s" seq)))))) + (seq-into result (type-of seq))))) (defun seq-contains-p (seq elt &optional testfn) "Return the first element in SEQ that equals to ELT. @@ -245,17 +244,38 @@ negative integer or 0, nil is returned." "Apply FUNCTION to each element of SEQ. Separate the elements of SEQ into an alist using the results as keys. Keys are compared using `equal'." - (nreverse - (seq-reduce - (lambda (acc elt) - (let* ((key (funcall function elt)) - (cell (assoc key acc))) - (if cell - (setcdr cell (push elt (cdr cell))) - (push (list key elt) acc)) - acc)) - seq - nil))) + (seq-reduce + (lambda (acc elt) + (let* ((key (funcall function elt)) + (cell (assoc key acc))) + (if cell + (setcdr cell (push elt (cdr cell))) + (push (list key elt) acc)) + acc)) + (seq-reverse seq) + nil)) + +(defalias 'seq-reverse + (if (ignore-errors (reverse [1 2])) + #'reverse + (lambda (seq) + "Return the reversed copy of list, vector, or string SEQ. +See also the function `nreverse', which is used more often." + (let ((result '())) + (seq-map (lambda (elt) (push elt result)) + seq) + (if (listp seq) + result + (seq-into result (type-of seq))))))) + +(defun seq-into (seq type) + "Convert the sequence SEQ into a sequence of type TYPE. +TYPE can be one of the following symbols: vector, string or list." + (pcase type + (`vector (vconcat seq)) + (`string (concat seq)) + (`list (append seq nil)) + (t (error "Not a sequence type name: %s" type)))) (defun seq--drop-list (list n) "Return a list from LIST without its first N elements. @@ -300,7 +320,6 @@ This is an optimization for lists in `seq-take-while'." (defalias 'seq-copy #'copy-sequence) (defalias 'seq-elt #'elt) -(defalias 'seq-reverse #'reverse) (defalias 'seq-length #'length) (defalias 'seq-do #'mapc) (defalias 'seq-each #'seq-do) diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 5b9dc6422a2..1bc5eb28720 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -612,8 +612,11 @@ PREC2 is a table as returned by `smie-precs->prec2' or (cons (pcase (cdr x) (`closer (cddr (assoc token table))) (`opener (cdr (assoc token table)))))) - (cl-assert (numberp (car cons))) - (setf (car cons) (list (car cons))))) + ;; `cons' can be nil for openers/closers which only contain + ;; "atomic" elements. + (when cons + (cl-assert (numberp (car cons))) + (setf (car cons) (list (car cons)))))) (let ((ca (gethash :smie-closer-alist prec2))) (when ca (push (cons :smie-closer-alist ca) table))) ;; (smie-check-grammar table prec2 'step3) @@ -834,12 +837,12 @@ Possible return values: ;;; Miscellaneous commands using the precedence parser. -(defun smie-backward-sexp-command (&optional n) +(defun smie-backward-sexp-command (n) "Move backward through N logical elements." (interactive "^p") (smie-forward-sexp-command (- n))) -(defun smie-forward-sexp-command (&optional n) +(defun smie-forward-sexp-command (n) "Move forward through N logical elements." (interactive "^p") (let ((forw (> n 0)) |