diff options
Diffstat (limited to 'lisp/emacs-lisp')
76 files changed, 9953 insertions, 3145 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index b9a3a32a9b6..8e8d0e22651 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2051,6 +2051,8 @@ in that CLASS." function class name))) (error "ad-remove-advice: `%s' is not advised" function))) +(declare-function comp-subr-trampoline-install "comp") + ;;;###autoload (defun ad-add-advice (function advice class position) "Add a piece of ADVICE to FUNCTION's list of advices in CLASS. @@ -2074,6 +2076,9 @@ mapped to the closest extremal position). If FUNCTION was not advised already, its advice info will be initialized. Redefining a piece of advice whose name is part of the cache-id will clear the cache." + (when (and (featurep 'native-compile) + (subr-primitive-p (symbol-function function))) + (comp-subr-trampoline-install function)) (cond ((not (ad-is-advised function)) (ad-initialize-advice-info function) (ad-set-advice-info-field diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index ec7492dd4b1..e9a20634af8 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -141,9 +141,12 @@ expression, in which case we want to handle forms differently." ((stringp (car-safe rest)) (car rest)))) ;; Look for an interactive spec. (interactive (pcase body - ((or `((interactive . ,_) . ,_) - `(,_ (interactive . ,_) . ,_)) - t)))) + ((or `((interactive . ,iargs) . ,_) + `(,_ (interactive . ,iargs) . ,_)) + ;; List of modes or just t. + (if (nthcdr 1 iargs) + (list 'quote (nthcdr 1 iargs)) + t))))) ;; Add the usage form at the end where describe-function-1 ;; can recover it. (when (consp args) (setq doc (help-add-fundoc-usage doc args))) @@ -167,7 +170,9 @@ expression, in which case we want to handle forms differently." define-inline cl-defun cl-defmacro cl-defgeneric cl-defstruct pcase-defmacro)) (macrop car) - (setq expand (let ((load-file-name file)) (macroexpand form))) + (setq expand (let ((load-true-file-name file) + (load-file-name file)) + (macroexpand form))) (memq (car expand) '(progn prog1 defalias))) (make-autoload expand file 'expansion)) ;Recurse on the expansion. @@ -207,7 +212,11 @@ expression, in which case we want to handle forms differently." easy-mmode-define-minor-mode define-minor-mode)) t) - (eq (car-safe (car body)) 'interactive)) + (and (eq (car-safe (car body)) 'interactive) + ;; List of modes or just t. + (or (if (nthcdr 1 (car body)) + (list 'quote (nthcdr 1 (car body))) + t)))) ,(if macrop ''macro nil)))) ;; For defclass forms, use `eieio-defclass-autoload'. @@ -241,7 +250,10 @@ expression, in which case we want to handle forms differently." (custom-autoload ',varname ,file ,(condition-case nil (null (plist-get props :set)) - (error nil)))))) + (error nil))) + ;; Propagate the :safe property to the loaddefs file. + ,@(when-let ((safe (plist-get props :safe))) + `((put ',varname 'safe-local-variable ,safe)))))) ((eq car 'defgroup) ;; In Emacs this is normally handled separately by cus-dep.el, but for @@ -614,8 +626,8 @@ Don't try to split prefixes that are already longer than that.") (radix-tree-iter-mappings (cdr x) (lambda (s _) (push (concat prefix s) dropped))) - (message "Not registering prefix \"%s\" from %s. Affects: %S" - prefix file dropped) + (message "%s:0: Warning: Not registering prefix \"%s\". Affects: %S" + file prefix dropped) nil)))) prefixes))) `(register-definition-prefixes ,file ',(sort (delq nil strings) diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index 75c732269e2..4382985eb85 100644 --- a/lisp/emacs-lisp/avl-tree.el +++ b/lisp/emacs-lisp/avl-tree.el @@ -74,7 +74,7 @@ cmpfun) (defmacro avl-tree--root (tree) - ;; Return the root node for an AVL tree. INTERNAL USE ONLY. + "Return the root node for an AVL TREE. INTERNAL USE ONLY." `(avl-tree--node-left (avl-tree--dummyroot ,tree))) ;; ---------------------------------------------------------------- @@ -117,11 +117,11 @@ NODE is the node, and BRANCH is the branch. `(- 1 ,dir)) (defmacro avl-tree--dir-to-sign (dir) - "Convert direction (0,1) to sign factor (-1,+1)." + "Convert direction DIR (0,1) to sign factor (-1,+1)." `(1- (* 2 ,dir))) (defmacro avl-tree--sign-to-dir (dir) - "Convert sign factor (-x,+x) to direction (0,1)." + "Convert sign factor in DIR (-x,+x) to direction (0,1)." `(if (< ,dir 0) 0 1)) @@ -129,7 +129,7 @@ NODE is the node, and BRANCH is the branch. ;; Deleting data (defun avl-tree--del-balance (node branch dir) - "Rebalance a tree after deleting a node. + "Rebalance a tree after deleting a NODE. The deletion was done from the left (DIR=0) or right (DIR=1) sub-tree of the left (BRANCH=0) or right (BRANCH=1) child of NODE. Return t if the height of the tree has shrunk." @@ -247,9 +247,9 @@ the related data." ;; Entering data (defun avl-tree--enter-balance (node branch dir) - "Rebalance tree after an insertion -into the left (DIR=0) or right (DIR=1) sub-tree of the -left (BRANCH=0) or right (BRANCH=1) child of NODE. + "Rebalance tree after insertion of NODE. +NODE was inserted into the left (DIR=0) or right (DIR=1) sub-tree +of the left (BRANCH=0) or right (BRANCH=1) child of NODE. Return t if the height of the tree has grown." (let ((br (avl-tree--node-branch node branch)) ;; opposite direction: 0,1 -> 1,0 @@ -337,7 +337,7 @@ inserted data." )))) (defun avl-tree--check (tree) - "Check the tree's balance." + "Check the balance of TREE." (avl-tree--check-node (avl-tree--root tree))) (defun avl-tree--check-node (node) (if (null node) 0 @@ -379,7 +379,8 @@ itself." ;;; INTERNAL USE ONLY (defun avl-tree--do-copy (root) - "Copy the AVL tree with ROOT as root. Highly recursive." + "Copy the AVL tree wiath ROOT as root. +This function is highly recursive." (if (null root) nil (avl-tree--node-create @@ -405,8 +406,9 @@ itself." \n(fn OBJ)") (defun avl-tree--stack-repopulate (stack) - ;; Recursively push children of the node at the head of STACK onto the - ;; front of the STACK, until a leaf is reached. + "Recursively push children of STACK onto the front. +This pushes the children of the node at the head of STACK onto +the front of STACK, until a leaf node is reached." (let ((node (car (avl-tree--stack-store stack))) (dir (if (avl-tree--stack-reverse stack) 1 0))) (when node ; check for empty stack @@ -429,7 +431,7 @@ and returns non-nil if A is less than B, and nil otherwise. \n(fn TREE)") (defun avl-tree-empty (tree) - "Return t if AVL tree TREE is empty, otherwise return nil." + "Return t if AVL TREE is empty, otherwise return nil." (null (avl-tree--root tree))) (defun avl-tree-enter (tree data &optional updatefun) @@ -451,7 +453,7 @@ Returns the new data." 0 data updatefun))) (defun avl-tree-delete (tree data &optional test nilflag) - "Delete the element matching DATA from the AVL tree TREE. + "Delete the element matching DATA from the AVL TREE. Matching uses the comparison function previously specified in `avl-tree-create' when TREE was created. @@ -473,7 +475,7 @@ value is non-nil." (defun avl-tree-member (tree data &optional nilflag) - "Return the element in the AVL tree TREE which matches DATA. + "Return the element in the AVL TREE which matches DATA. Matching uses the comparison function previously specified in `avl-tree-create' when TREE was created. @@ -496,7 +498,7 @@ for you.)" (defun avl-tree-member-p (tree data) - "Return t if an element matching DATA exists in the AVL tree TREE. + "Return t if an element matching DATA exists in the AVL TREE. Otherwise return nil. Matching uses the comparison function previously specified in `avl-tree-create' when TREE was created." (let ((flag '(nil))) @@ -504,13 +506,13 @@ previously specified in `avl-tree-create' when TREE was created." (defun avl-tree-map (fun tree &optional reverse) - "Modify all elements in the AVL tree TREE by applying FUNCTION. + "Modify all elements in the AVL TREE by applying function FUN. -Each element is replaced by the return value of FUNCTION applied -to that element. +Each element is replaced by the return value of FUN applied to +that element. -FUNCTION is applied to the elements in ascending order, or -descending order if REVERSE is non-nil." +FUN is applied to the elements in ascending order, or descending +order if REVERSE is non-nil." (avl-tree--mapc (lambda (node) (setf (avl-tree--node-data node) @@ -520,8 +522,7 @@ descending order if REVERSE is non-nil." (defun avl-tree-mapc (fun tree &optional reverse) - "Apply FUNCTION to all elements in AVL tree TREE, -for side-effect only. + "Apply function FUN to all elements in AVL TREE, for side-effect only. FUNCTION is applied to the elements in ascending order, or descending order if REVERSE is non-nil." @@ -534,8 +535,7 @@ descending order if REVERSE is non-nil." (defun avl-tree-mapf (fun combinator tree &optional reverse) - "Apply FUNCTION to all elements in AVL tree TREE, -and combine the results using COMBINATOR. + "Apply FUN to all elements in AVL TREE, combine results using COMBINATOR. The FUNCTION is applied and the results are combined in ascending order, or descending order if REVERSE is non-nil." @@ -553,8 +553,7 @@ order, or descending order if REVERSE is non-nil." (defun avl-tree-mapcar (fun tree &optional reverse) - "Apply function FUN to all elements in AVL tree TREE, -and make a list of the results. + "Apply FUN to all elements in AVL TREE, and make a list of the results. The function is applied and the list constructed in ascending order, or descending order if REVERSE is non-nil. @@ -586,7 +585,7 @@ is more efficient." (avl-tree--node-data node)))) (defun avl-tree-copy (tree) - "Return a copy of the AVL tree TREE." + "Return a copy of the AVL TREE." (let ((new-tree (avl-tree-create (avl-tree--cmpfun tree)))) (setf (avl-tree--root new-tree) (avl-tree--do-copy (avl-tree--root tree))) new-tree)) @@ -608,13 +607,12 @@ is more efficient." treesize)) (defun avl-tree-clear (tree) - "Clear the AVL tree TREE." + "Clear the AVL TREE." (setf (avl-tree--root tree) nil)) (defun avl-tree-stack (tree &optional reverse) - "Return an object that behaves like a sorted stack -of all elements of TREE. + "Return an object that behaves like a sorted stack of all elements of TREE. If REVERSE is non-nil, the stack is sorted in reverse order. \(See also `avl-tree-stack-pop'). @@ -655,8 +653,7 @@ a null element stored in the AVL tree.)" (defun avl-tree-stack-first (avl-tree-stack &optional nilflag) - "Return the first element of AVL-TREE-STACK, without removing it -from the stack. + "Return the first element of AVL-TREE-STACK, without removing it from stack. Returns nil if the stack is empty, or NILFLAG if specified. \(The latter allows an empty stack to be distinguished from diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 3e1c3292650..ea70baa9532 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -190,7 +190,7 @@ This is commonly used to recompute `backtrace-frames'.") (defvar-local backtrace-print-function #'cl-prin1 "Function used to print values in the current Backtrace buffer.") -(defvar-local backtrace-goto-source-functions nil +(defvar backtrace-goto-source-functions nil "Abnormal hook used to jump to the source code for the current frame. Each hook function is called with no argument, and should return non-nil if it is able to switch to the buffer containing the @@ -638,10 +638,8 @@ content of the sexp." (source-available (plist-get (backtrace-frame-flags frame) :source-available))) (unless (and source-available - (catch 'done - (dolist (func backtrace-goto-source-functions) - (when (funcall func) - (throw 'done t))))) + (run-hook-with-args-until-success + 'backtrace-goto-source-functions)) (user-error "Source code location not known")))) (defun backtrace-help-follow-symbol (&optional pos) diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index 14bc2817390..64c628822df 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -31,16 +31,72 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) ;For `named-let'. + (defmacro benchmark-elapse (&rest forms) "Return the time in seconds elapsed for execution of FORMS." (declare (indent 0) (debug t)) (let ((t1 (make-symbol "t1"))) - `(let (,t1) - (setq ,t1 (current-time)) + `(let ((,t1 (current-time))) ,@forms (float-time (time-since ,t1))))) ;;;###autoload +(defun benchmark-call (func &optional repetitions) + "Measure the run time of calling FUNC a number REPETITIONS of times. +The result is a list (TIME GC GCTIME) +where TIME is the total time it took, in seconds. +GCTIME is the amount of time that was spent in the GC +and GC is the number of times the GC was called. + +REPETITIONS can also be a floating point number, in which case it +specifies a minimum number of seconds that the benchmark execution +should take. In that case the return value is prepended with the +number of repetitions actually used." + (if (floatp repetitions) + (benchmark--adaptive func repetitions) + (unless repetitions (setq repetitions 1)) + (let ((gc gc-elapsed) + (gcs gcs-done) + (empty-func (lambda () 'empty-func))) + (list + (if (> repetitions 1) + (- (benchmark-elapse (dotimes (_ repetitions) (funcall func))) + (benchmark-elapse (dotimes (_ repetitions) (funcall empty-func)))) + (- (benchmark-elapse (funcall func)) + (benchmark-elapse (funcall empty-func)))) + (- gcs-done gcs) + (- gc-elapsed gc))))) + +(defun benchmark--adaptive (func time) + "Measure the run time of FUNC, calling it enough times to last TIME seconds. +Result is (REPETITIONS . DATA) where DATA is as returned by `branchmark-call'." + (named-let loop ((repetitions 1) + (data (let ((x (list 0))) (setcdr x x) x))) + ;; (message "Running %d iteration" repetitions) + (let ((newdata (benchmark-call func repetitions))) + (if (<= (car newdata) 0) + ;; This can happen if we're unlucky, e.g. the process got preempted + ;; (or the GC ran) just during the empty-func loop. + ;; Just try again, hopefully this won't repeat itself. + (progn + ;; (message "Ignoring the %d iterations" repetitions) + (loop (* 2 repetitions) data)) + (let* ((sum (cl-mapcar #'+ data (cons repetitions newdata))) + (totaltime (nth 1 sum))) + (if (>= totaltime time) + sum + (let* ((iter-time (/ totaltime (car sum))) + (missing-time (- time totaltime)) + (missing-iter (/ missing-time iter-time))) + ;; `iter-time' is approximate because of effects like the GC, + ;; so multiply at most by 10, in case we are wildly off the mark. + (loop (max repetitions + (min (ceiling missing-iter) + (* 10 repetitions))) + sum)))))))) + +;;;###autoload (defmacro benchmark-run (&optional repetitions &rest forms) "Time execution of FORMS. If REPETITIONS is supplied as a number, run FORMS that many times, @@ -53,19 +109,7 @@ See also `benchmark-run-compiled'." (unless (or (natnump repetitions) (and repetitions (symbolp repetitions))) (setq forms (cons repetitions forms) repetitions 1)) - (let ((i (make-symbol "i")) - (gcs (make-symbol "gcs")) - (gc (make-symbol "gc"))) - `(let ((,gc gc-elapsed) - (,gcs gcs-done)) - (list ,(if (or (symbolp repetitions) (> repetitions 1)) - ;; Take account of the loop overhead. - `(- (benchmark-elapse (dotimes (,i ,repetitions) - ,@forms)) - (benchmark-elapse (dotimes (,i ,repetitions)))) - `(benchmark-elapse ,@forms)) - (- gcs-done ,gcs) - (- gc-elapsed ,gc))))) + `(benchmark-call (lambda () ,@forms) ,repetitions)) ;;;###autoload (defmacro benchmark-run-compiled (&optional repetitions &rest forms) @@ -77,21 +121,7 @@ result. The overhead of the `lambda's is accounted for." (unless (or (natnump repetitions) (and repetitions (symbolp repetitions))) (setq forms (cons repetitions forms) repetitions 1)) - (let ((i (make-symbol "i")) - (gcs (make-symbol "gcs")) - (gc (make-symbol "gc")) - (code (byte-compile `(lambda () ,@forms))) - (lambda-code (byte-compile '(lambda ())))) - `(let ((,gc gc-elapsed) - (,gcs gcs-done)) - (list ,(if (or (symbolp repetitions) (> repetitions 1)) - ;; Take account of the loop overhead. - `(- (benchmark-elapse (dotimes (,i ,repetitions) - (funcall ,code))) - (benchmark-elapse (dotimes (,i ,repetitions) - (funcall ,lambda-code)))) - `(benchmark-elapse (funcall ,code))) - (- gcs-done ,gcs) (- gc-elapsed ,gc))))) + `(benchmark-call (byte-compile '(lambda () ,@forms)) ,repetitions)) ;;;###autoload (defun benchmark (repetitions form) @@ -99,9 +129,15 @@ result. The overhead of the `lambda's is accounted for." Interactively, REPETITIONS is taken from the prefix arg, and the command prompts for the form to benchmark. For non-interactive use see also `benchmark-run' and -`benchmark-run-compiled'." +`benchmark-run-compiled'. +FORM can also be a function in which case we measure the time it takes +to call it without any argument." (interactive "p\nxForm: ") - (let ((result (eval `(benchmark-run ,repetitions ,form) t))) + (let ((result (benchmark-call (eval (pcase form + ((or `#',_ `(lambda . ,_)) form) + (_ `(lambda () ,form))) + t) + repetitions))) (if (zerop (nth 1 result)) (message "Elapsed time: %fs" (car result)) (message "Elapsed time: %fs (%fs in %d GCs)" (car result) diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 0d9ba57d663..76c2e80fda8 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -26,7 +26,7 @@ ;; Packing and unpacking of (binary) data structures. ;; ;; The data formats used in binary files and network protocols are -;; often structed data which can be described by a C-style structure +;; often structured data which can be described by a C-style structure ;; such as the one shown below. Using the bindat package, decoding ;; and encoding binary data formats like these is made simple using a ;; structure specification which closely resembles the C style @@ -41,57 +41,61 @@ ;; Consider the following C structures: ;; ;; struct header { -;; unsigned long dest_ip; -;; unsigned long src_ip; -;; unsigned short dest_port; -;; unsigned short src_port; +;; uint32_t dest_ip; +;; uint32_t src_ip; +;; uint16_t dest_port; +;; uint16_t src_port; ;; }; ;; ;; struct data { -;; unsigned char type; -;; unsigned char opcode; -;; unsigned long length; /* In little endian order */ +;; uint8_t type; +;; uint8_t opcode; +;; uint32_t length; /* In little endian order */ ;; unsigned char id[8]; /* nul-terminated string */ ;; unsigned char data[/* (length + 3) & ~3 */]; ;; }; ;; ;; struct packet { ;; struct header header; -;; unsigned char items; +;; uint8_t items; ;; unsigned char filler[3]; ;; struct data item[/* items */]; ;; }; ;; -;; The corresponding Lisp bindat specification looks like this: +;; The corresponding Lisp bindat specification could look like this: +;; +;; (bindat-defmacro ip () '(vec 4 byte)) ;; ;; (setq header-bindat-spec -;; '((dest-ip ip) +;; (bindat-type +;; (dest-ip ip) ;; (src-ip ip) -;; (dest-port u16) -;; (src-port u16))) +;; (dest-port uint 16) +;; (src-port uint 16))) ;; ;; (setq data-bindat-spec -;; '((type u8) +;; (bindat-type +;; (type u8) ;; (opcode u8) -;; (length u16r) ;; little endian order +;; (length uintr 32) ;; little endian order ;; (id strz 8) -;; (data vec (length)) -;; (align 4))) +;; (data vec length) +;; (_ align 4))) ;; ;; (setq packet-bindat-spec -;; '((header struct header-bindat-spec) -;; (items u8) -;; (fill 3) -;; (item repeat (items) -;; (struct data-bindat-spec)))) -;; +;; (bindat-type +;; (header type header-bindat-spec) +;; (nitems u8) +;; (_ fill 3) +;; (items repeat nitems type data-bindat-spec))) ;; ;; A binary data representation may look like ;; [ 192 168 1 100 192 168 1 101 01 28 21 32 2 0 0 0 ;; 2 3 5 0 ?A ?B ?C ?D ?E ?F 0 0 1 2 3 4 5 0 0 0 ;; 1 4 7 0 ?B ?C ?D ?E ?F ?G 0 0 6 7 8 9 10 11 12 0 ] ;; -;; The corresponding decoded structure looks like +;; The corresponding decoded structure returned by `bindat-unpack' (or taken +;; by `bindat-pack') looks like: ;; ;; ((header ;; (dest-ip . [192 168 1 100]) @@ -111,92 +115,28 @@ ;; (type . 1)))) ;; ;; To access a specific value in this structure, use the function -;; bindat-get-field with the structure as first arg followed by a list +;; `bindat-get-field' with the structure as first arg followed by a list ;; of field names and array indexes, e.g. using the data above, ;; (bindat-get-field decoded-structure 'item 1 'id) ;; returns "BCDEFG". -;; Binary Data Structure Specification Format -;; ------------------------------------------ - -;; We recommend using names that end in `-bindat-spec'; such names -;; are recognized automatically as "risky" variables. - -;; The data specification is formatted as follows: - -;; SPEC ::= ( ITEM... ) - -;; ITEM ::= ( [FIELD] TYPE ) -;; | ( [FIELD] eval FORM ) -- eval FORM for side-effect only -;; | ( [FIELD] fill LEN ) -- skip LEN bytes -;; | ( [FIELD] align LEN ) -- skip to next multiple of LEN bytes -;; | ( [FIELD] struct SPEC_NAME ) -;; | ( [FIELD] union TAG_VAL (TAG SPEC)... [(t SPEC)] ) -;; | ( [FIELD] repeat COUNT ITEM... ) - -;; -- In (eval EXPR), the value of the last field is available in -;; the dynamically bound variable `last'. - -;; TYPE ::= ( eval EXPR ) -- interpret result as TYPE -;; | u8 | byte -- length 1 -;; | u16 | word | short -- length 2, network byte order -;; | u24 -- 3-byte value -;; | u32 | dword | long -- length 4, network byte order -;; | u16r | u24r | u32r -- little endian byte order. -;; | str LEN -- LEN byte string -;; | strz LEN -- LEN byte (zero-terminated) string -;; | vec LEN [TYPE] -- vector of LEN items of TYPE (default: u8) -;; | ip -- 4 byte vector -;; | bits LEN -- List with bits set in LEN bytes. -;; -;; -- Example: `bits 2' will unpack 0x28 0x1c to (2 3 4 11 13) -;; and 0x1c 0x28 to (3 5 10 11 12). - -;; FIELD ::= ( eval EXPR ) -- use result as NAME -;; | NAME - -;; LEN ::= ARG -;; | <omitted> | nil -- LEN = 1 - - -;; TAG_VAL ::= ARG - -;; TAG ::= LISP_CONSTANT -;; | ( eval EXPR ) -- return non-nil if tag match; -;; current TAG_VAL in `tag'. - -;; ARG ::= ( eval EXPR ) -- interpret result as ARG -;; | INTEGER_CONSTANT -;; | DEREF - -;; DEREF ::= ( [NAME | INTEGER]... ) -- Field NAME or Array index relative -;; to current structure spec. -;; -- see bindat-get-field - -;; A `union' specification -;; ([FIELD] union TAG_VAL (TAG SPEC) ... [(t SPEC)]) -;; is interpreted by evalling TAG_VAL and then comparing that to -;; each TAG using equal; if a match is found, the corresponding SPEC -;; is used. -;; If TAG is a form (eval EXPR), EXPR is evalled with `tag' bound to the -;; value of TAG_VAL; the corresponding SPEC is used if the result is non-nil. -;; Finally, if TAG is t, the corresponding SPEC is used unconditionally. -;; -;; An `eval' specification -;; ([FIELD] eval FORM) -;; is interpreted by evalling FORM for its side effects only. -;; If FIELD is specified, the value is bound to that field. -;; The FORM may access and update `bindat-raw' and `bindat-idx' (see `bindat-unpack'). - ;;; Code: ;; Helper functions for structure unpacking. -;; Relies on dynamic binding of BINDAT-RAW and BINDAT-IDX +;; Relies on dynamic binding of `bindat-raw' and `bindat-idx'. + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) ;For `named-let'. + +(cl-defstruct (bindat--type + (:predicate nil) + (:constructor bindat--make)) + le ue pe) (defvar bindat-raw) (defvar bindat-idx) -(defun bindat--unpack-u8 () +(defsubst bindat--unpack-u8 () (prog1 (aref bindat-raw bindat-idx) (setq bindat-idx (1+ bindat-idx)))) @@ -219,77 +159,79 @@ (defun bindat--unpack-u32r () (logior (bindat--unpack-u16r) (ash (bindat--unpack-u16r) 16))) +(defun bindat--unpack-str (len) + (let ((s (substring bindat-raw bindat-idx (+ bindat-idx len)))) + (setq bindat-idx (+ bindat-idx len)) + (if (stringp s) s + (apply #'unibyte-string s)))) + +(defun bindat--unpack-strz (len) + (let ((i 0) s) + (while (and (if len (< i len) t) (/= (aref bindat-raw (+ bindat-idx i)) 0)) + (setq i (1+ i))) + (setq s (substring bindat-raw bindat-idx (+ bindat-idx i))) + (setq bindat-idx (+ bindat-idx len)) + (if (stringp s) s + (apply #'unibyte-string s)))) + +(defun bindat--unpack-bits (len) + (let ((bits nil) (bnum (1- (* 8 len))) j m) + (while (>= bnum 0) + (if (= (setq m (bindat--unpack-u8)) 0) + (setq bnum (- bnum 8)) + (setq j 128) + (while (> j 0) + (if (/= 0 (logand m j)) + (setq bits (cons bnum bits))) + (setq bnum (1- bnum) + j (ash j -1))))) + bits)) + (defun bindat--unpack-item (type len &optional vectype) (if (eq type 'ip) (setq type 'vec len 4)) - (cond - ((memq type '(u8 byte)) - (bindat--unpack-u8)) - ((memq type '(u16 word short)) - (bindat--unpack-u16)) - ((eq type 'u24) - (bindat--unpack-u24)) - ((memq type '(u32 dword long)) - (bindat--unpack-u32)) - ((eq type 'u16r) - (bindat--unpack-u16r)) - ((eq type 'u24r) - (bindat--unpack-u24r)) - ((eq type 'u32r) - (bindat--unpack-u32r)) - ((eq type 'bits) - (let ((bits nil) (bnum (1- (* 8 len))) j m) - (while (>= bnum 0) - (if (= (setq m (bindat--unpack-u8)) 0) - (setq bnum (- bnum 8)) - (setq j 128) - (while (> j 0) - (if (/= 0 (logand m j)) - (setq bits (cons bnum bits))) - (setq bnum (1- bnum) - j (ash j -1))))) - bits)) - ((eq type 'str) - (let ((s (substring bindat-raw bindat-idx (+ bindat-idx len)))) - (setq bindat-idx (+ bindat-idx len)) - (if (stringp s) s - (apply #'unibyte-string s)))) - ((eq type 'strz) - (let ((i 0) s) - (while (and (< i len) (/= (aref bindat-raw (+ bindat-idx i)) 0)) - (setq i (1+ i))) - (setq s (substring bindat-raw bindat-idx (+ bindat-idx i))) - (setq bindat-idx (+ bindat-idx len)) - (if (stringp s) s - (apply #'unibyte-string s)))) - ((eq type 'vec) - (let ((v (make-vector len 0)) (i 0) (vlen 1)) + (pcase type + ((or 'u8 'byte) (bindat--unpack-u8)) + ((or 'u16 'word 'short) (bindat--unpack-u16)) + ('u24 (bindat--unpack-u24)) + ((or 'u32 'dword 'long) (bindat--unpack-u32)) + ('u16r (bindat--unpack-u16r)) + ('u24r (bindat--unpack-u24r)) + ('u32r (bindat--unpack-u32r)) + ('bits (bindat--unpack-bits len)) + ('str (bindat--unpack-str len)) + ('strz (bindat--unpack-strz len)) + ('vec + (let ((v (make-vector len 0)) (vlen 1)) (if (consp vectype) (setq vlen (nth 1 vectype) vectype (nth 2 vectype)) (setq type (or vectype 'u8) vectype nil)) - (while (< i len) - (aset v i (bindat--unpack-item type vlen vectype)) - (setq i (1+ i))) + (dotimes (i len) + (aset v i (bindat--unpack-item type vlen vectype))) v)) - (t nil))) + (_ nil))) + +(defsubst bindat--align (n len) + (* len (/ (+ n (1- len)) len))) ;Isn't there a simpler way? (defun bindat--unpack-group (spec) - (with-suppressed-warnings ((lexical last)) - (defvar last)) + ;; FIXME: Introduce a new primitive so we can mark `bindat-unpack' + ;; as obsolete (maybe that primitive should be a macro which takes + ;; a bindat type *expression* as argument). + (if (cl-typep spec 'bindat--type) + (funcall (bindat--type-ue spec)) + (with-suppressed-warnings ((lexical struct last)) + (defvar struct) (defvar last)) (let (struct last) - (while spec - (let* ((item (car spec)) - (field (car item)) + (dolist (item spec) + (let* ((field (car item)) (type (nth 1 item)) (len (nth 2 item)) (vectype (and (eq type 'vec) (nth 3 item))) (tail 3) data) - (setq spec (cdr spec)) - (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field)) t))) (if (and type (consp type) (eq (car type) 'eval)) (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) @@ -299,29 +241,28 @@ len type type field field nil)) + (if (and (consp field) (eq (car field) 'eval)) + (setq field (eval (car (cdr field)) t))) (if (and (consp len) (not (eq type 'eval))) (setq len (apply #'bindat-get-field struct len))) (if (not len) (setq len 1)) - (cond - ((eq type 'eval) + (pcase type + ('eval (if field (setq data (eval len t)) (eval len t))) - ((eq type 'fill) + ('fill (setq bindat-idx (+ bindat-idx len))) - ((eq type 'align) - (while (/= (% bindat-idx len) 0) - (setq bindat-idx (1+ bindat-idx)))) - ((eq type 'struct) + ('align + (setq bindat-idx (bindat--align bindat-idx len))) + ('struct (setq data (bindat--unpack-group (eval len t)))) - ((eq type 'repeat) - (let ((index 0) (count len)) - (while (< index count) - (push (bindat--unpack-group (nthcdr tail item)) data) - (setq index (1+ index))) - (setq data (nreverse data)))) - ((eq type 'union) + ('repeat + (dotimes (_ len) + (push (bindat--unpack-group (nthcdr tail item)) data)) + (setq data (nreverse data))) + ('union (with-suppressed-warnings ((lexical tag)) (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) @@ -333,14 +274,15 @@ (and (consp cc) (eval cc t))) (setq data (bindat--unpack-group (cdr case)) cases nil))))) - (t + ((pred integerp) (debug t)) + (_ (setq data (bindat--unpack-item type len vectype) last data))) (if data (setq struct (if field (cons (cons field data) struct) (append data struct)))))) - struct)) + struct))) (defun bindat-unpack (spec raw &optional idx) "Return structured data according to SPEC for binary data in RAW. @@ -361,14 +303,12 @@ An integer value in the field list is taken as an array index, e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (while (and struct field) (setq struct (if (integerp (car field)) - (nth (car field) struct) - (let ((val (assq (car field) struct))) - (if (consp val) (cdr val))))) + (elt struct (car field)) + (cdr (assq (car field) struct)))) (setq field (cdr field))) struct) - -;; Calculate bindat-raw length of structured data +;;;; Calculate bindat-raw length of structured data (defvar bindat--fixed-length-alist '((u8 . 1) (byte . 1) @@ -378,19 +318,17 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (ip . 4))) (defun bindat--length-group (struct spec) - (with-suppressed-warnings ((lexical last)) - (defvar last)) - (let (last) - (while spec - (let* ((item (car spec)) - (field (car item)) + (if (cl-typep spec 'bindat--type) + (funcall (bindat--type-le spec) struct) + (with-suppressed-warnings ((lexical struct last)) + (defvar struct) (defvar last)) + (let ((struct struct) last) + (dolist (item spec) + (let* ((field (car item)) (type (nth 1 item)) (len (nth 2 item)) (vectype (and (eq type 'vec) (nth 3 item))) (tail 3)) - (setq spec (cdr spec)) - (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field)) t))) (if (and type (consp type) (eq (car type) 'eval)) (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) @@ -400,6 +338,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." len type type field field nil)) + (if (and (consp field) (eq (car field) 'eval)) + (setq field (eval (car (cdr field)) t))) (if (and (consp len) (not (eq type 'eval))) (setq len (apply #'bindat-get-field struct len))) (if (not len) @@ -410,27 +350,24 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." type (nth 2 vectype)) (setq type (or vectype 'u8) vectype nil))) - (cond - ((eq type 'eval) + (pcase type + ('eval (if field (setq struct (cons (cons field (eval len t)) struct)) (eval len t))) - ((eq type 'fill) + ('fill (setq bindat-idx (+ bindat-idx len))) - ((eq type 'align) - (while (/= (% bindat-idx len) 0) - (setq bindat-idx (1+ bindat-idx)))) - ((eq type 'struct) + ('align + (setq bindat-idx (bindat--align bindat-idx len))) + ('struct (bindat--length-group (if field (bindat-get-field struct field) struct) (eval len t))) - ((eq type 'repeat) - (let ((index 0) (count len)) - (while (< index count) - (bindat--length-group - (nth index (bindat-get-field struct field)) - (nthcdr tail item)) - (setq index (1+ index))))) - ((eq type 'union) + ('repeat + (dotimes (index len) + (bindat--length-group + (nth index (bindat-get-field struct field)) + (nthcdr tail item)))) + ('union (with-suppressed-warnings ((lexical tag)) (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) @@ -443,23 +380,23 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (progn (bindat--length-group struct (cdr case)) (setq cases nil)))))) - (t + (_ (if (setq type (assq type bindat--fixed-length-alist)) (setq len (* len (cdr type)))) (if field (setq last (bindat-get-field struct field))) - (setq bindat-idx (+ bindat-idx len)))))))) + (setq bindat-idx (+ bindat-idx len))))))))) (defun bindat-length (spec struct) - "Calculate bindat-raw length for STRUCT according to bindat SPEC." + "Calculate `bindat-raw' length for STRUCT according to bindat SPEC." (let ((bindat-idx 0)) (bindat--length-group struct spec) bindat-idx)) -;; Pack structured data into bindat-raw +;;;; Pack structured data into bindat-raw -(defun bindat--pack-u8 (v) +(defsubst bindat--pack-u8 (v) (aset bindat-raw bindat-idx (logand v 255)) (setq bindat-idx (1+ bindat-idx))) @@ -476,6 +413,10 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (bindat--pack-u16 (ash v -16)) (bindat--pack-u16 v)) +(defun bindat--pack-u64 (v) + (bindat--pack-u32 (ash v -32)) + (bindat--pack-u32 v)) + (defun bindat--pack-u16r (v) (aset bindat-raw (1+ bindat-idx) (logand (ash v -8) 255)) (aset bindat-raw bindat-idx (logand v 255)) @@ -489,74 +430,74 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (bindat--pack-u16r v) (bindat--pack-u16r (ash v -16))) +(defun bindat--pack-u64r (v) + (bindat--pack-u32r v) + (bindat--pack-u32r (ash v -32))) + +(defun bindat--pack-str (len v) + (dotimes (i (min len (length v))) + (aset bindat-raw (+ bindat-idx i) (aref v i))) + (setq bindat-idx (+ bindat-idx len))) + +(defun bindat--pack-strz (v) + (let ((len (length v))) + (dotimes (i len) + (aset bindat-raw (+ bindat-idx i) (aref v i))) + (setq bindat-idx (+ bindat-idx len 1)))) + +(defun bindat--pack-bits (len v) + (let ((bnum (1- (* 8 len))) j m) + (while (>= bnum 0) + (setq m 0) + (if (null v) + (setq bnum (- bnum 8)) + (setq j 128) + (while (> j 0) + (if (memq bnum v) + (setq m (logior m j))) + (setq bnum (1- bnum) + j (ash j -1)))) + (bindat--pack-u8 m)))) + (defun bindat--pack-item (v type len &optional vectype) (if (eq type 'ip) (setq type 'vec len 4)) - (cond - ((null v) - (setq bindat-idx (+ bindat-idx len))) - ((memq type '(u8 byte)) - (bindat--pack-u8 v)) - ((memq type '(u16 word short)) - (bindat--pack-u16 v)) - ((eq type 'u24) - (bindat--pack-u24 v)) - ((memq type '(u32 dword long)) - (bindat--pack-u32 v)) - ((eq type 'u16r) - (bindat--pack-u16r v)) - ((eq type 'u24r) - (bindat--pack-u24r v)) - ((eq type 'u32r) - (bindat--pack-u32r v)) - ((eq type 'bits) - (let ((bnum (1- (* 8 len))) j m) - (while (>= bnum 0) - (setq m 0) - (if (null v) - (setq bnum (- bnum 8)) - (setq j 128) - (while (> j 0) - (if (memq bnum v) - (setq m (logior m j))) - (setq bnum (1- bnum) - j (ash j -1)))) - (bindat--pack-u8 m)))) - ((memq type '(str strz)) - (let ((l (length v)) (i 0)) - (if (> l len) (setq l len)) - (while (< i l) - (aset bindat-raw (+ bindat-idx i) (aref v i)) - (setq i (1+ i))) - (setq bindat-idx (+ bindat-idx len)))) - ((eq type 'vec) - (let ((l (length v)) (i 0) (vlen 1)) + (pcase type + ((guard (null v)) (setq bindat-idx (+ bindat-idx len))) + ((or 'u8 'byte) (bindat--pack-u8 v)) + ((or 'u16 'word 'short) (bindat--pack-u16 v)) + ('u24 (bindat--pack-u24 v)) + ((or 'u32 'dword 'long) (bindat--pack-u32 v)) + ('u16r (bindat--pack-u16r v)) + ('u24r (bindat--pack-u24r v)) + ('u32r (bindat--pack-u32r v)) + ('bits (bindat--pack-bits len v)) + ((or 'str 'strz) (bindat--pack-str len v)) + ('vec + (let ((l (length v)) (vlen 1)) (if (consp vectype) (setq vlen (nth 1 vectype) vectype (nth 2 vectype)) (setq type (or vectype 'u8) vectype nil)) (if (> l len) (setq l len)) - (while (< i l) - (bindat--pack-item (aref v i) type vlen vectype) - (setq i (1+ i))))) - (t + (dotimes (i l) + (bindat--pack-item (aref v i) type vlen vectype)))) + (_ (setq bindat-idx (+ bindat-idx len))))) (defun bindat--pack-group (struct spec) - (with-suppressed-warnings ((lexical last)) - (defvar last)) - (let (last) - (while spec - (let* ((item (car spec)) - (field (car item)) + (if (cl-typep spec 'bindat--type) + (funcall (bindat--type-pe spec) struct) + (with-suppressed-warnings ((lexical struct last)) + (defvar struct) (defvar last)) + (let ((struct struct) last) + (dolist (item spec) + (let* ((field (car item)) (type (nth 1 item)) (len (nth 2 item)) (vectype (and (eq type 'vec) (nth 3 item))) (tail 3)) - (setq spec (cdr spec)) - (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field)) t))) (if (and type (consp type) (eq (car type) 'eval)) (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) @@ -566,31 +507,30 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." len type type field field nil)) + (if (and (consp field) (eq (car field) 'eval)) + (setq field (eval (car (cdr field)) t))) (if (and (consp len) (not (eq type 'eval))) (setq len (apply #'bindat-get-field struct len))) (if (not len) (setq len 1)) - (cond - ((eq type 'eval) + (pcase type + ('eval (if field (setq struct (cons (cons field (eval len t)) struct)) (eval len t))) - ((eq type 'fill) + ('fill (setq bindat-idx (+ bindat-idx len))) - ((eq type 'align) - (while (/= (% bindat-idx len) 0) - (setq bindat-idx (1+ bindat-idx)))) - ((eq type 'struct) + ('align + (setq bindat-idx (bindat--align bindat-idx len))) + ('struct (bindat--pack-group (if field (bindat-get-field struct field) struct) (eval len t))) - ((eq type 'repeat) - (let ((index 0) (count len)) - (while (< index count) - (bindat--pack-group - (nth index (bindat-get-field struct field)) - (nthcdr tail item)) - (setq index (1+ index))))) - ((eq type 'union) + ('repeat + (dotimes (index len) + (bindat--pack-group + (nth index (bindat-get-field struct field)) + (nthcdr tail item)))) + ('union (with-suppressed-warnings ((lexical tag)) (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) @@ -603,10 +543,10 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (progn (bindat--pack-group struct (cdr case)) (setq cases nil)))))) - (t + (_ (setq last (bindat-get-field struct field)) (bindat--pack-item last type len vectype) - )))))) + ))))))) (defun bindat-pack (spec struct &optional raw idx) "Return binary data packed according to SPEC for structured data STRUCT. @@ -622,21 +562,15 @@ Optional fourth arg IDX is the starting offset into RAW." (bindat--pack-group struct spec) (if raw nil bindat-raw))) - -;; Misc. format conversions +;;;; Misc. format conversions (defun bindat-format-vector (vect fmt sep &optional len) "Format vector VECT using element format FMT and separator SEP. Result is a string with each element of VECT formatted using FMT and separated by the string SEP. If optional fourth arg LEN is given, use only that many elements from VECT." - (unless len - (setq len (length vect))) - (let ((i len) (fmt2 (concat sep fmt)) (s nil)) - (while (> i 0) - (setq i (1- i) - s (cons (format (if (= i 0) fmt fmt2) (aref vect i)) s))) - (apply #'concat s))) + (when len (setq vect (substring vect 0 len))) + (mapconcat (lambda (x) (format fmt x)) vect sep)) (defun bindat-vector-to-dec (vect &optional sep) "Format vector VECT in decimal format separated by dots. @@ -656,6 +590,393 @@ The port (if any) is omitted. IP can be a string, as well." (format "%d.%d.%d.%d" (aref ip 0) (aref ip 1) (aref ip 2) (aref ip 3)))) +;;;; New approach based on macro-expansion + +;; Further improvements suggested by reading websocket.el: +;; - Support for bit-sized fields? +;; +;; - Add some way to verify redundant/checksum fields's contents without +;; having to provide a complete `:unpack-val' expression. +;; The `:pack-val' thingy can work nicely to compute checksum fields +;; based on previous fields's contents (without impacting or being impacted +;; by the unpacked representation), but if we want to verify +;; those checksums when unpacking, we have to use the :unpack-val +;; and build the whole object by hand instead of being able to focus +;; just on the checksum field. +;; Maybe this could be related to `unit' type fields where we might like +;; to make sure that the "value" we write into it is the same as the +;; value it holds (tho those checks don't happen at the same time (pack +;; vs unpack). +;; +;; - Support for packing/unpacking to/from something else than +;; a unibyte string, e.g. from a buffer. Problems to do that are: +;; - the `str' and `strz' types which use `substring' rather than reading +;; one byte at a time. +;; - the `align' and `fill' which just want to skip without reading/writing +;; - the `pack-uint' case, which would prefer writing the LSB first. +;; - the `align' case needs to now the current position in order to know +;; how far to advance +;; +;; - Don't write triple code when the type is only ever used at a single place +;; (e.g. to unpack). + +(defun bindat--unpack-uint (bitlen) + (let ((v 0) (bitsdone 0)) + (while (< bitsdone bitlen) + (setq v (logior (ash v 8) (bindat--unpack-u8))) + (setq bitsdone (+ bitsdone 8))) + v)) + +(defun bindat--unpack-uintr (bitlen) + (let ((v 0) (bitsdone 0)) + (while (< bitsdone bitlen) + (setq v (logior v (ash (bindat--unpack-u8) bitsdone))) + (setq bitsdone (+ bitsdone 8))) + v)) + +(defun bindat--pack-uint (bitlen v) + (let* ((len (/ bitlen 8)) + (shift (- (* 8 (1- len))))) + (dotimes (_ len) + (bindat--pack-u8 (logand 255 (ash v shift))) + (setq shift (+ 8 shift))))) + +(defun bindat--pack-uintr (bitlen v) + (let* ((len (/ bitlen 8))) + (dotimes (_ len) + (bindat--pack-u8 (logand v 255)) + (setq v (ash v -8))))) + +(defmacro bindat--pcase (&rest args) + "Like `pcase' but optimize the code under the assumption that it's exhaustive." + (declare (indent 1) (debug pcase)) + `(pcase ,@args (pcase--dontcare nil))) + +(cl-defgeneric bindat--type (op head &rest args) + "Return the code for the operation OP of the Bindat type (HEAD . ARGS). +OP can be one of: unpack', (pack VAL), or (length VAL) where VAL +is the name of a variable that will hold the value we need to pack.") + +(cl-defmethod bindat--type (op (_ (eql 'byte))) + (bindat--pcase op + ('unpack `(bindat--unpack-u8)) + (`(length . ,_) `(cl-incf bindat-idx 1)) + (`(pack . ,args) `(bindat--pack-u8 . ,args)))) + +(cl-defmethod bindat--type (op (_ (eql 'uint)) n) + (if (eq n 8) (bindat--type op 'byte) + (bindat--pcase op + ('unpack `(bindat--unpack-uint ,n)) + (`(length . ,_) `(cl-incf bindat-idx (/ ,n 8))) + (`(pack . ,args) `(bindat--pack-uint ,n . ,args))))) + +(cl-defmethod bindat--type (op (_ (eql 'uintr)) n) + (if (eq n 8) (bindat--type op 'byte) + (bindat--pcase op + ('unpack `(bindat--unpack-uintr ,n)) + (`(length . ,_) `(cl-incf bindat-idx (/ ,n 8))) + (`(pack . ,args) `(bindat--pack-uintr ,n . ,args))))) + +(cl-defmethod bindat--type (op (_ (eql 'str)) len) + (bindat--pcase op + ('unpack `(bindat--unpack-str ,len)) + (`(length . ,_) `(cl-incf bindat-idx ,len)) + (`(pack . ,args) `(bindat--pack-str ,len . ,args)))) + +(cl-defmethod bindat--type (op (_ (eql 'strz)) &optional len) + (bindat--pcase op + ('unpack `(bindat--unpack-strz ,len)) + (`(length ,val) + `(cl-incf bindat-idx ,(cond + ((null len) `(length ,val)) + ((numberp len) len) + (t `(or ,len (length ,val)))))) + (`(pack . ,args) + (macroexp-let2 nil len len + `(if ,len + ;; Same as non-zero terminated strings since we don't actually add + ;; the terminating zero anyway (because we rely on the fact that + ;; `bindat-raw' was presumably initialized with all-zeroes before + ;; we started). + (bindat--pack-str ,len . ,args) + (bindat--pack-strz . ,args)))))) + +(cl-defmethod bindat--type (op (_ (eql 'bits)) len) + (bindat--pcase op + ('unpack `(bindat--unpack-bits ,len)) + (`(length . ,_) `(cl-incf bindat-idx ,len)) + (`(pack . ,args) `(bindat--pack-bits ,len . ,args)))) + +(cl-defmethod bindat--type (_op (_ (eql 'fill)) len) + `(progn (cl-incf bindat-idx ,len) nil)) + +(cl-defmethod bindat--type (_op (_ (eql 'align)) len) + `(progn (cl-callf bindat--align bindat-idx ,len) nil)) + +(cl-defmethod bindat--type (op (_ (eql 'type)) exp) + (bindat--pcase op + ('unpack `(funcall (bindat--type-ue ,exp))) + (`(length . ,args) `(funcall (bindat--type-le ,exp) . ,args)) + (`(pack . ,args) `(funcall (bindat--type-pe ,exp) . ,args)))) + +(cl-defmethod bindat--type (op (_ (eql 'vec)) count &rest type) + (unless type (setq type '(byte))) + (let ((fun (macroexpand-all (bindat--fun type) macroexpand-all-environment))) + (bindat--pcase op + ('unpack + `(let* ((bindat--len ,count) + (bindat--v (make-vector bindat--len 0))) + (dotimes (bindat--i bindat--len) + (aset bindat--v bindat--i (funcall ,fun))) + bindat--v)) + ((and `(length . ,_) + ;; FIXME: Improve the pattern match to recognize more complex + ;; "constant" functions? + (let `#'(lambda (,val) (setq bindat-idx (+ bindat-idx ,len))) fun) + (guard (not (macroexp--fgrep `((,val)) len)))) + ;; Optimize the case where the size of each element is constant. + `(cl-incf bindat-idx (* ,count ,len))) + ;; FIXME: It's tempting to use `(mapc (lambda (,val) ,exp) ,val)' + ;; which would be more efficient when `val' is a list, + ;; but that's only right if length of `val' is indeed `count'. + (`(,_ ,val) + `(dotimes (bindat--i ,count) + (funcall ,fun (elt ,val bindat--i))))))) + +(cl-defmethod bindat--type (op (_ (eql 'unit)) val) + (pcase op ('unpack val) (_ nil))) + +(cl-defmethod bindat--type (op (_ (eql 'struct)) &rest args) + (apply #'bindat--type op args)) + +(cl-defmethod bindat--type (op (_ (eql :pack-var)) var &rest fields) + (unless (consp (cdr fields)) + (error "`:pack-var VAR' needs to be followed by fields")) + (bindat--pcase op + ((or 'unpack (guard (null var))) + (apply #'bindat--type op fields)) + (`(,_ ,val) + `(let ((,var ,val)) ,(apply #'bindat--type op fields))))) + +(cl-defmethod bindat--type (op (field cons) &rest fields) + (named-let loop + ((fields (cons field fields)) + (labels ())) + (bindat--pcase fields + ('nil + (bindat--pcase op + ('unpack + (let ((exp ())) + (pcase-dolist (`(,label . ,labelvar) labels) + (setq exp + (if (eq label '_) + (if exp `(nconc ,labelvar ,exp) labelvar) + `(cons (cons ',label ,labelvar) ,exp)))) + exp)) + (_ nil))) + (`(:unpack-val ,exp) + ;; Make it so `:kwd nil' is the same as the absence of the keyword arg. + (if exp (pcase op ('unpack exp)) (loop nil labels))) + + (`((,label . ,type) . ,fields) + (let* ((get-field-val + (let ((tail (memq :pack-val type))) + ;; FIXME: This `TYPE.. :pack EXP' syntax doesn't work well + ;; when TYPE is a struct (a list of fields) or with extensions + ;; such as allowing TYPE to be `if ...'. + (if tail + (prog1 (cadr tail) + (setq type (butlast type (length tail))))))) + (fieldvar (make-symbol (format "field%d" (length fields)))) + (labelvar + (cond + ((eq label '_) fieldvar) + ((keywordp label) + (intern (substring (symbol-name label) 1))) + (t label))) + (field-fun (bindat--fun type)) + (rest-exp (loop fields `((,label . ,labelvar) . ,labels)))) + (bindat--pcase op + ('unpack + (let ((code + `(let ((,labelvar (funcall ,field-fun))) + ,rest-exp))) + (if (or (eq label '_) (not (assq label labels))) + code + (macroexp-warn-and-return + (format "Duplicate label: %S" label) + code)))) + (`(,_ ,val) + ;; `cdr-safe' is easier to optimize (can't signal an error). + `(let ((,fieldvar ,(or get-field-val + (if (eq label '_) val + `(cdr-safe (assq ',label ,val)))))) + (funcall ,field-fun ,fieldvar) + ,@(when rest-exp + `((let ,(unless (eq labelvar fieldvar) + `((,labelvar ,fieldvar))) + (ignore ,labelvar) + ,rest-exp)))))))) + (_ (error "Unrecognized format in bindat fields: %S" fields))))) + +(def-edebug-elem-spec 'bindat-struct + '([&rest (symbolp bindat-type &optional ":pack-val" def-form)] + &optional ":unpack-val" def-form)) + +(def-edebug-elem-spec 'bindat-type + '(&or ["uint" def-form] + ["uintr" def-form] + ["str" def-form] + ["strz" &optional def-form] + ["bits" def-form] + ["fill" def-form] + ["align" def-form] + ["vec" def-form bindat-type] + ["repeat" def-form bindat-type] + ["type" def-form] + ["struct" bindat-struct] + ["unit" def-form] + [":pack-var" symbolp bindat-type] + symbolp ;; u8, u16, etc... + bindat-struct)) + +(defmacro bindat-type (&rest type) + "Return the Bindat type value to pack&unpack TYPE. +TYPE is a Bindat type expression. It can take the following forms: + + uint BITLEN - Big-endian unsigned integer + uintr BITLEN - Little-endian unsigned integer + str LEN - Byte string + strz [LEN] - Zero-terminated byte-string + bits LEN - Bit vector (LEN is counted in bytes) + fill LEN - Just a filler + align LEN - Fill up to the next multiple of LEN bytes + vec COUNT TYPE - COUNT repetitions of TYPE + type EXP - Indirection; EXP should return a Bindat type value + unit EXP - 0-width type holding the value returned by EXP + struct FIELDS... - A composite type + +When the context makes it clear, the symbol `struct' can be omitted. +A composite type is a list of FIELDS where each FIELD is of the form + + (LABEL TYPE) + +where LABEL can be `_' if the field should not deserve a name. + +Composite types get normally packed/unpacked to/from alists, but this can be +controlled in the following way: +- If the list of fields ends with `:unpack-val EXP', then unpacking will + return the value of EXP (which has the previous fields in its scope). +- If a field's TYPE is followed by `:pack-val EXP', then the value placed + into this field will be that returned by EXP instead of looking up the alist. +- If the list of fields is preceded with `:pack-var VAR' then the object to + be packed is bound to VAR when evaluating the EXPs of `:pack-val'. + +All the above BITLEN, LEN, COUNT, and EXP are ELisp expressions evaluated +in the current lexical context extended with the previous fields. + +TYPE can additionally be one of the Bindat type macros defined with +`bindat-defmacro' (and listed below) or an ELisp expression which returns +a bindat type expression." + (declare (indent 0) (debug (bindat-type))) + `(progn + (defvar bindat-idx) + (bindat--make :ue ,(bindat--toplevel 'unpack type) + :le ,(bindat--toplevel 'length type) + :pe ,(bindat--toplevel 'pack type)))) + +(eval-and-compile + (defconst bindat--primitives '(byte uint uintr str strz bits fill align + struct type vec unit))) + +(eval-and-compile + (defvar bindat--macroenv + (mapcar (lambda (s) (cons s (lambda (&rest args) + (bindat--makefun (cons s args))))) + bindat--primitives))) + +(defmacro bindat-defmacro (name args &rest body) + "Define a new Bindat type as a macro." + (declare (indent 2) (doc-string 3) (debug (&define name sexp def-body))) + (let ((leaders ())) + (while (and (cdr body) + (or (stringp (car body)) + (memq (car-safe (car body)) '(:documentation declare)))) + (push (pop body) leaders)) + ;; FIXME: Add support for Edebug decls to those macros. + `(eval-and-compile ;; Yuck! But needed to define types where you use them! + (setf (alist-get ',name bindat--macroenv) + (lambda ,args ,@(nreverse leaders) + (bindat--fun ,(macroexp-progn body))))))) + +(put 'bindat-type 'function-documentation '(bindat--make-docstring)) +(defun bindat--make-docstring () + ;; Largely inspired from `pcase--make-docstring'. + (let* ((main (documentation (symbol-function 'bindat-type) 'raw)) + (ud (help-split-fundoc main 'bindat-type))) + (require 'help-fns) + (declare-function help-fns--signature "help-fns") + (with-temp-buffer + (insert (or (cdr ud) main)) + (pcase-dolist (`(,name . ,me) (reverse bindat--macroenv)) + (unless (memq name bindat--primitives) + (let ((doc (documentation me 'raw))) + (insert "\n\n-- ") + (setq doc (help-fns--signature name doc me + (indirect-function me) + nil)) + (insert "\n" (or doc "Not documented."))))) + (let ((combined-doc (buffer-string))) + (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) + +(bindat-defmacro u8 () "Unsigned 8bit integer." '(byte)) +(bindat-defmacro sint (bitlen r) + "Signed integer of size BITLEN. +Bigendian if R is nil and little endian if not." + (let ((bl (make-symbol "bitlen")) + (max (make-symbol "max")) + (wrap (make-symbol "wrap"))) + `(let* ((,bl ,bitlen) + (,max (ash 1 (1- ,bl))) + (,wrap (+ ,max ,max))) + (struct :pack-var v + (n if ,r (uintr ,bl) (uint ,bl) + :pack-val (if (< v 0) (+ v ,wrap) v)) + :unpack-val (if (>= n ,max) (- n ,wrap) n))))) + +(bindat-defmacro repeat (count &rest type) + "Like `vec', but unpacks to a list rather than a vector." + `(:pack-var v + (v vec ,count ,@type :pack-val v) + :unpack-val (append v nil))) + +(defvar bindat--op nil + "The operation we're currently building. +This is a simple symbol and can be one of: `unpack', `pack', or `length'. +This is used during macroexpansion of `bindat-type' so that the +macros know which code to generate. +FIXME: this is closely related and very similar to the `op' argument passed +to `bindat--type', yet it's annoyingly different.") + +(defun bindat--fun (type) + (if (or (keywordp (car type)) (consp (car type))) (cons 'struct type) + type)) + +(defun bindat--makefun (type) + (let* ((v (make-symbol "v")) + (args (pcase bindat--op ('unpack ()) (_ (list v))))) + (pcase (apply #'bindat--type + (pcase bindat--op ('unpack 'unpack) (op `(,op . ,args))) + type) + (`(funcall ,f . ,(pred (equal args))) f) ;η-reduce. + (exp `(lambda ,args ,exp))))) + +(defun bindat--toplevel (op type) + (let* ((bindat--op op) + (env `(,@bindat--macroenv + ,@macroexpand-all-environment))) + (macroexpand-all (bindat--fun type) env))) + (provide 'bindat) ;;; bindat.el ends here diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index abbe2a2e63f..6475f69eded 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -225,6 +225,14 @@ (byte-compile-log-lap-1 ,format-string ,@args))) +(defvar byte-optimize--lexvars nil + "Lexical variables in scope, in reverse order of declaration. +Each element is on the form (NAME KEEP [VALUE]), where: + NAME is the variable name, + KEEP is a boolean indicating whether the binding must be retained, + VALUE, if present, is a substitutable expression. +Earlier variables shadow later ones with the same name.") + ;;; byte-compile optimizers to support inlining (put 'inline 'byte-optimizer #'byte-optimize-inline-handler) @@ -266,124 +274,42 @@ ((pred byte-code-function-p) ;; (message "Inlining byte-code for %S!" name) ;; The byte-code will be really inlined in byte-compile-unfold-bcf. + (byte-compile--check-arity-bytecode form fn) `(,fn ,@(cdr form))) ((or `(lambda . ,_) `(closure . ,_)) - (if (not (or (eq fn localfn) ;From the same file => same mode. - (eq (car fn) ;Same mode. - (if lexical-binding 'closure 'lambda)))) - ;; While byte-compile-unfold-bcf can inline dynbind byte-code into - ;; letbind byte-code (or any other combination for that matter), we - ;; can only inline dynbind source into dynbind source or letbind - ;; source into letbind source. - (progn - ;; We can of course byte-compile the inlined function - ;; first, and then inline its byte-code. - (byte-compile name) - `(,(symbol-function name) ,@(cdr form))) - (let ((newfn (if (eq fn localfn) - ;; If `fn' is from the same file, it has already - ;; been preprocessed! - `(function ,fn) - ;; Try and process it "in its original environment". - (let ((byte-compile-bound-variables nil)) - (byte-compile-preprocess - (byte-compile--reify-function fn)))))) - (if (eq (car-safe newfn) 'function) - (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) - ;; This can happen because of macroexp-warn-and-return &co. - (byte-compile-warn - "Inlining closure %S failed" name) - form)))) + ;; While byte-compile-unfold-bcf can inline dynbind byte-code into + ;; letbind byte-code (or any other combination for that matter), we + ;; can only inline dynbind source into dynbind source or letbind + ;; source into letbind source. + ;; When the function comes from another file, we byte-compile + ;; the inlined function first, and then inline its byte-code. + ;; This also has the advantage that the final code does not + ;; depend on the order of compilation of ELisp files, making + ;; the build more reproducible. + (if (eq fn localfn) + ;; From the same file => same mode. + (macroexp--unfold-lambda `(,fn ,@(cdr form))) + ;; Since we are called from inside the optimiser, we need to make + ;; sure not to propagate lexvar values. + (let ((byte-optimize--lexvars nil) + ;; Silence all compilation warnings: the useful ones should + ;; be displayed when the function's source file will be + ;; compiled anyway, but more importantly we would otherwise + ;; emit spurious warnings here because we don't have the full + ;; context, such as `declare-functions' placed earlier in the + ;; source file's code or `with-suppressed-warnings' that + ;; surrounded the `defsubst'. + (byte-compile-warnings nil)) + (byte-compile name)) + (let ((bc (symbol-function name))) + (byte-compile--check-arity-bytecode form bc) + `(,bc ,@(cdr form))))) (_ ;; Give up on inlining. form)))) - -;; ((lambda ...) ...) -(defun byte-compile-unfold-lambda (form &optional name) - ;; In lexical-binding mode, let and functions don't bind vars in the same way - ;; (let obey special-variable-p, but functions don't). But luckily, this - ;; 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)) - (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 -(defconst byte-optimize-enable-variable-constprop t - "If non-nil, enable constant propagation through local variables.") - -(defconst byte-optimize-warn-eliminated-variable nil - "Whether to warn when a variable is optimised away entirely. -This does usually not indicate a problem and makes the compiler -very chatty, but can be useful for debugging.") - -(defvar byte-optimize--lexvars nil - "Lexical variables in scope, in reverse order of declaration. -Each element is on the form (NAME KEEP [VALUE]), where: - NAME is the variable name, - KEEP is a boolean indicating whether the binding must be retained, - VALUE, if present, is a substitutable expression. -Earlier variables shadow later ones with the same name.") - (defvar byte-optimize--vars-outside-condition nil "Alist of variables lexically bound outside conditionally executed code. Variables here are sensitive to mutation inside the conditional code, @@ -412,10 +338,44 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (numberp expr) (stringp expr) (and (consp expr) - (eq (car expr) 'quote) + (memq (car expr) '(quote function)) (symbolp (cadr expr))) (keywordp expr))) +(defmacro byte-optimize--pcase (exp &rest cases) + ;; When we do + ;; + ;; (pcase EXP + ;; (`(if ,exp ,then ,else) (DO-TEST)) + ;; (`(plus ,e2 ,e2) (DO-ADD)) + ;; (`(times ,e2 ,e2) (DO-MULT)) + ;; ...) + ;; + ;; we usually don't want to fall back to the default case if + ;; the value of EXP is of a form like `(if E1 E2)' or `(plus E1)' + ;; or `(times E1 E2 E3)', instead we either want to signal an error + ;; that EXP has an unexpected shape, or we want to carry on as if + ;; it had the right shape (ignore the extra data and pretend the missing + ;; data is nil) because it should simply never happen. + ;; + ;; The macro below implements the second option by rewriting patterns + ;; like `(if ,exp ,then ,else)' + ;; to `(if . (or `(,exp ,then ,else) pcase--dontcare))'. + ;; + ;; The resulting macroexpansion is also significantly cleaner/smaller/faster. + (declare (indent 1) (debug pcase)) + `(pcase ,exp + . ,(mapcar (lambda (case) + `(,(pcase (car case) + ((and `(,'\` (,_ . (,'\, ,_))) pat) pat) + (`(,'\` (,head . ,tail)) + (list '\` + (cons head + (list '\, `(or ,(list '\` tail) pcase--dontcare))))) + (pat pat)) + . ,(cdr case))) + cases))) + (defun byte-optimize-form-code-walker (form for-effect) ;; ;; For normal function calls, We can just mapcar the optimizer the cdr. But @@ -428,28 +388,33 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; have no place in an optimizer: the corresponding tests should be ;; performed in `macroexpand-all', or in `cconv', or in `bytecomp'. (let ((fn (car-safe form))) - (pcase form + (byte-optimize--pcase form ((pred (not consp)) (cond ((and for-effect (or byte-compile-delete-errors (not (symbolp form)) - (eq form t))) + (eq form t) + (keywordp form))) nil) ((symbolp form) (let ((lexvar (assq form byte-optimize--lexvars))) - (if (cddr lexvar) ; Value available? - (if (assq form byte-optimize--vars-outside-loop) - ;; Cannot substitute; mark for retention to avoid the - ;; variable being eliminated. - (progn - (setcar (cdr lexvar) t) - form) - (caddr lexvar)) ; variable value to use - form))) + (cond + ((not lexvar) form) + (for-effect nil) + ((cddr lexvar) ; Value available? + (if (assq form byte-optimize--vars-outside-loop) + ;; Cannot substitute; mark for retention to avoid the + ;; variable being eliminated. + (progn + (setcar (cdr lexvar) t) + form) + ;; variable value to use + (caddr lexvar))) + (t form)))) (t form))) (`(quote . ,v) - (if (cdr v) + (if (or (not v) (cdr v)) (byte-compile-warn "malformed quote form: `%s'" (prin1-to-string form))) ;; Map (quote nil) to nil to simplify optimizer logic. @@ -458,31 +423,34 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (not for-effect) form)) (`(,(or 'let 'let*) . ,rest) - (cons fn (byte-optimize-let-form fn rest for-effect))) + (cons fn (byte-optimize-let-form fn rest for-effect))) (`(cond . ,clauses) ;; The condition in the first clause is always executed, but ;; right now we treat all of them as conditional for simplicity. (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars)) (cons fn (mapcar (lambda (clause) - (if (consp clause) - (cons - (byte-optimize-form (car clause) nil) - (byte-optimize-body (cdr clause) for-effect)) - (byte-compile-warn "malformed cond form: `%s'" - (prin1-to-string clause)) - clause)) - clauses)))) + (if (consp clause) + (cons + (byte-optimize-form (car clause) nil) + (byte-optimize-body (cdr clause) for-effect)) + (byte-compile-warn "malformed cond form: `%s'" + (prin1-to-string clause)) + clause)) + clauses)))) (`(progn . ,exps) ;; As an extra added bonus, this simplifies (progn <x>) --> <x>. (if (cdr exps) (macroexp-progn (byte-optimize-body exps for-effect)) (byte-optimize-form (car exps) for-effect))) - (`(prog1 . ,(or `(,exp . ,exps) pcase--dontcare)) - (if exps - `(prog1 ,(byte-optimize-form exp for-effect) - . ,(byte-optimize-body exps t)) - (byte-optimize-form exp for-effect))) + (`(prog1 ,exp . ,exps) + (let ((exp-opt (byte-optimize-form exp for-effect))) + (if exps + (let ((exps-opt (byte-optimize-body exps t))) + (if (macroexp-const-p exp-opt) + `(progn ,@exps-opt ,exp-opt) + `(prog1 ,exp-opt ,@exps-opt))) + exp-opt))) (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps) ;; Those subrs which have an implicit progn; it's not quite good @@ -492,19 +460,23 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (cons fn (byte-optimize-body exps for-effect))) (`(if ,test ,then . ,else) + ;; FIXME: We are conservative here: any variable changed in the + ;; THEN branch will be barred from substitution in the ELSE + ;; branch, despite the branches being mutually exclusive. + ;; The test is always executed. (let* ((test-opt (byte-optimize-form test nil)) - ;; The THEN and ELSE branches are executed conditionally. - ;; - ;; FIXME: We are conservative here: any variable changed in the - ;; THEN branch will be barred from substitution in the ELSE - ;; branch, despite the branches being mutually exclusive. - (byte-optimize--vars-outside-condition byte-optimize--lexvars) - (then-opt (byte-optimize-form then for-effect)) - (else-opt (byte-optimize-body else for-effect))) + (const (macroexp-const-p test-opt)) + ;; The branches are traversed unconditionally when possible. + (byte-optimize--vars-outside-condition + (if const + byte-optimize--vars-outside-condition + byte-optimize--lexvars)) + ;; Avoid traversing dead branches. + (then-opt (and test-opt (byte-optimize-form then for-effect))) + (else-opt (and (not (and test-opt const)) + (byte-optimize-body else for-effect)))) `(if ,test-opt ,then-opt . ,else-opt))) - (`(if . ,_) - (byte-compile-warn "too few arguments for `if'")) (`(,(or 'and 'or) . ,exps) ; Remember, and/or are control structures. ;; FIXME: We have to traverse the expressions in left-to-right @@ -542,8 +514,6 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (body (byte-optimize-body exps t))) `(while ,condition . ,body))) - (`(while . ,_) - (byte-compile-warn "too few arguments for `while'")) (`(interactive . ,_) (byte-compile-warn "misplaced interactive spec: `%s'" @@ -555,13 +525,19 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; all the subexpressions and compiling them separately. form) - (`(condition-case . ,(or `(,var ,exp . ,clauses) pcase--dontcare)) + (`(condition-case ,var ,exp . ,clauses) (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars)) - `(condition-case ,var ;Not evaluated. + `(condition-case ,var ;Not evaluated. ,(byte-optimize-form exp for-effect) ,@(mapcar (lambda (clause) - `(,(car clause) - ,@(byte-optimize-body (cdr clause) for-effect))) + (let ((byte-optimize--lexvars + (and lexical-binding + (if var + (cons (list var t) + byte-optimize--lexvars) + byte-optimize--lexvars)))) + (cons (car clause) + (byte-optimize-body (cdr clause) for-effect)))) clauses)))) (`(unwind-protect ,exp . ,exps) @@ -581,7 +557,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") `(unwind-protect ,bodyform . ,(byte-optimize-body exps t)))))) - (`(catch . ,(or `(,tag . ,exps) pcase--dontcare)) + (`(catch ,tag . ,exps) (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars)) `(catch ,(byte-optimize-form tag nil) . ,(byte-optimize-body exps for-effect)))) @@ -591,7 +567,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; computed for effect. We want to avoid the warnings ;; that might occur if they were treated that way. ;; However, don't actually bother calling `ignore'. - `(prog1 nil . ,(mapcar #'byte-optimize-form exps))) + `(progn ,@(mapcar #'byte-optimize-form exps) nil)) ;; Needed as long as we run byte-optimize-form after cconv. (`(internal-make-closure . ,_) @@ -604,7 +580,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") form) (`((lambda . ,_) . ,_) - (let ((newform (byte-compile-unfold-lambda form))) + (let ((newform (macroexp--unfold-lambda form))) (if (eq newform form) ;; Some error occurred, avoid infinite recursion. form @@ -625,24 +601,20 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (lexvar (assq var byte-optimize--lexvars)) (value (byte-optimize-form expr nil))) (when lexvar - ;; If it's bound outside conditional, invalidate. - (if (assq var byte-optimize--vars-outside-condition) - ;; We are in conditional code and the variable was - ;; bound outside: cancel substitutions. - (setcdr (cdr lexvar) nil) - ;; Set a new value (if substitutable). - (setcdr (cdr lexvar) - (and (byte-optimize--substitutable-p value) - (list value)))) - (setcar (cdr lexvar) t)) ; Mark variable to be kept. + (setcar (cdr lexvar) t) ; Mark variable to be kept. + (setcdr (cdr lexvar) nil)) ; Inhibit further substitution. + (push var var-expr-list) (push value var-expr-list)) (setq args (cddr args))) (cons fn (nreverse var-expr-list)))) - (`(defvar ,(and (pred symbolp) name) . ,_) - (push name byte-optimize--dynamic-vars) - form) + (`(defvar ,(and (pred symbolp) name) . ,rest) + (let ((optimized-rest (and rest + (cons (byte-optimize-form (car rest) nil) + (cdr rest))))) + (push name byte-optimize--dynamic-vars) + `(defvar ,name . ,optimized-rest))) (`(,(pred byte-code-function-p) . ,exps) (cons fn (mapcar #'byte-optimize-form exps))) @@ -674,76 +646,66 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (byte-optimize-constant-args form) form)))))) -(defun byte-optimize-form (form &optional for-effect) +(defun byte-optimize-one-form (form &optional for-effect) "The source-level pass of the optimizer." - ;; - ;; First, optimize all sub-forms of this one. - (setq form (byte-optimize-form-code-walker form for-effect)) - ;; - ;; after optimizing all subforms, optimize this form until it doesn't - ;; optimize any further. This means that some forms will be passed through - ;; the optimizer many times, but that's necessary to make the for-effect - ;; processing do as much as possible. - ;; - (let (opt new) - (if (and (consp form) - (symbolp (car form)) - (or ;; (and for-effect - ;; ;; We don't have any of these yet, but we might. - ;; (setq opt (get (car form) - ;; 'byte-for-effect-optimizer))) - (setq opt (function-get (car form) 'byte-optimizer))) - (not (eq form (setq new (funcall opt form))))) - (progn -;; (if (equal form new) (error "bogus optimizer -- %s" opt)) - (byte-compile-log " %s\t==>\t%s" form new) - (setq new (byte-optimize-form new for-effect)) - new) - form))) + ;; Make optimiser aware of lexical arguments. + (let ((byte-optimize--lexvars + (mapcar (lambda (v) (list (car v) t)) + byte-compile--lexical-environment))) + (byte-optimize-form form for-effect))) + +(defun byte-optimize-form (form &optional for-effect) + (while + (progn + ;; First, optimize all sub-forms of this one. + (setq form (byte-optimize-form-code-walker form for-effect)) + + ;; If a form-specific optimiser is available, run it and start over + ;; until a fixpoint has been reached. + (and (consp form) + (symbolp (car form)) + (let ((opt (function-get (car form) 'byte-optimizer))) + (and opt + (let ((old form) + (new (funcall opt form))) + (byte-compile-log " %s\t==>\t%s" old new) + (setq form new) + (not (eq new old)))))))) + form) (defun byte-optimize-let-form (head form for-effect) ;; Recursively enter the optimizer for the bindings and body ;; of a let or let*. This for depth-firstness: forms that ;; are more deeply nested are optimized first. - (if (and lexical-binding byte-optimize-enable-variable-constprop) + (if lexical-binding (let* ((byte-optimize--lexvars byte-optimize--lexvars) (new-lexvars nil) (let-vars nil)) (dolist (binding (car form)) - (let (name expr) - (cond ((consp binding) - (setq name (car binding)) - (unless (symbolp name) - (byte-compile-warn "let-bind nonvariable: `%S'" name)) - (setq expr (byte-optimize-form (cadr binding) nil))) - ((symbolp binding) - (setq name binding)) - (t (byte-compile-warn "malformed let binding: `%S'" binding))) - (let* ( - (value (and (byte-optimize--substitutable-p expr) - (list expr))) - (lexical (not (or (and (symbolp name) - (special-variable-p name)) - (memq name byte-compile-bound-variables) - (memq name byte-optimize--dynamic-vars)))) - (lexinfo (and lexical (cons name (cons nil value))))) - (push (cons name (cons expr (cdr lexinfo))) let-vars) - (when lexinfo - (push lexinfo (if (eq head 'let*) - byte-optimize--lexvars - new-lexvars)))))) + (let* ((name (car binding)) + (expr (byte-optimize-form (cadr binding) nil)) + (value (and (byte-optimize--substitutable-p expr) + (list expr))) + (lexical (not (or (special-variable-p name) + (memq name byte-compile-bound-variables) + (memq name byte-optimize--dynamic-vars)))) + (lexinfo (and lexical (cons name (cons nil value))))) + (push (cons name (cons expr (cdr lexinfo))) let-vars) + (when lexinfo + (push lexinfo (if (eq head 'let*) + byte-optimize--lexvars + new-lexvars))))) (setq byte-optimize--lexvars (append new-lexvars byte-optimize--lexvars)) ;; Walk the body expressions, which may mutate some of the records, ;; and generate new bindings that exclude unused variables. - (let* ((opt-body (byte-optimize-body (cdr form) for-effect)) + (let* ((byte-optimize--dynamic-vars byte-optimize--dynamic-vars) + (opt-body (byte-optimize-body (cdr form) for-effect)) (bindings nil)) (dolist (var let-vars) ;; VAR is (NAME EXPR [KEEP [VALUE]]) - (if (and (nthcdr 3 var) (not (nth 2 var))) - ;; Value present and not marked to be kept: eliminate. - (when byte-optimize-warn-eliminated-variable - (byte-compile-warn "eliminating local variable %S" (car var))) + (when (or (not (nthcdr 3 var)) (nth 2 var)) + ;; Value not present, or variable marked to be kept. (push (list (nth 0 var) (nth 1 var)) bindings))) (cons bindings opt-body))) @@ -768,7 +730,6 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; all-for-effect is true. returns a new list of forms. (let ((rest forms) (result nil) - (byte-optimize--dynamic-vars byte-optimize--dynamic-vars) fe new) (while rest (setq fe (or all-for-effect (cdr rest))) @@ -981,27 +942,45 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") "Whether EXPR is a constant symbol." (and (macroexp-const-p expr) (symbolp (eval expr)))) +(defun byte-optimize--fixnump (o) + "Return whether O is guaranteed to be a fixnum in all Emacsen. +See Info node `(elisp) Integer Basics'." + (and (fixnump o) (<= -536870912 o 536870911))) + (defun byte-optimize-equal (form) - ;; Replace `equal' or `eql' with `eq' if at least one arg is a symbol. + ;; Replace `equal' or `eql' with `eq' if at least one arg is a + ;; symbol or fixnum. (byte-optimize-binary-predicate (if (= (length (cdr form)) 2) (if (or (byte-optimize--constant-symbol-p (nth 1 form)) - (byte-optimize--constant-symbol-p (nth 2 form))) + (byte-optimize--constant-symbol-p (nth 2 form)) + (byte-optimize--fixnump (nth 1 form)) + (byte-optimize--fixnump (nth 2 form))) (cons 'eq (cdr form)) form) ;; Arity errors reported elsewhere. form))) +(defun byte-optimize-eq (form) + (pcase (cdr form) + ((or `(,x nil) `(nil ,x)) `(not ,x)) + (_ (byte-optimize-binary-predicate form)))) + (defun byte-optimize-member (form) ;; Replace `member' or `memql' with `memq' if the first arg is a symbol, - ;; or the second arg is a list of symbols. + ;; or the second arg is a list of symbols. Same with fixnums. (if (= (length (cdr form)) 2) (if (or (byte-optimize--constant-symbol-p (nth 1 form)) + (byte-optimize--fixnump (nth 1 form)) (let ((arg2 (nth 2 form))) (and (macroexp-const-p arg2) (let ((listval (eval arg2))) (and (listp listval) - (not (memq nil (mapcar #'symbolp listval)))))))) + (not (memq nil (mapcar + (lambda (o) + (or (symbolp o) + (byte-optimize--fixnump o))) + listval)))))))) (cons 'memq (cdr form)) form) ;; Arity errors reported elsewhere. @@ -1009,11 +988,12 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (defun byte-optimize-assoc (form) ;; Replace 2-argument `assoc' with `assq', `rassoc' with `rassq', - ;; if the first arg is a symbol. + ;; if the first arg is a symbol or fixnum. (cond ((/= (length form) 3) form) - ((byte-optimize--constant-symbol-p (nth 1 form)) + ((or (byte-optimize--constant-symbol-p (nth 1 form)) + (byte-optimize--fixnump (nth 1 form))) (cons (if (eq (car form) 'assoc) 'assq 'rassq) (cdr form))) (t (byte-optimize-constant-args form)))) @@ -1073,7 +1053,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (put 'min 'byte-optimizer #'byte-optimize-min-max) (put '= 'byte-optimizer #'byte-optimize-binary-predicate) -(put 'eq 'byte-optimizer #'byte-optimize-binary-predicate) +(put 'eq 'byte-optimizer #'byte-optimize-eq) (put 'eql 'byte-optimizer #'byte-optimize-equal) (put 'equal 'byte-optimizer #'byte-optimize-equal) (put 'string= 'byte-optimizer #'byte-optimize-binary-predicate) @@ -1089,7 +1069,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (defun byte-optimize-quote (form) (if (or (consp (nth 1 form)) (and (symbolp (nth 1 form)) - (not (macroexp--const-symbol-p form)))) + (not (macroexp--const-symbol-p (nth 1 form))))) form (nth 1 form))) @@ -1250,18 +1230,31 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (put 'let 'byte-optimizer #'byte-optimize-letX) (put 'let* 'byte-optimizer #'byte-optimize-letX) (defun byte-optimize-letX (form) - (cond ((null (nth 1 form)) - ;; No bindings - (cons 'progn (cdr (cdr form)))) - ((or (nth 2 form) (nthcdr 3 form)) - form) - ;; The body is nil - ((eq (car form) 'let) - (append '(progn) (mapcar 'car-safe (mapcar 'cdr-safe (nth 1 form))) - '(nil))) - (t - (let ((binds (reverse (nth 1 form)))) - (list 'let* (reverse (cdr binds)) (nth 1 (car binds)) nil))))) + (pcase form + ;; No bindings. + (`(,_ () . ,body) + `(progn . ,body)) + + ;; Body is empty or just contains a constant. + (`(,head ,bindings . ,(or '() `(,(and const (pred macroexp-const-p))))) + (if (eq head 'let) + `(progn ,@(mapcar (lambda (binding) + (and (consp binding) (cadr binding))) + bindings) + ,const) + `(let* ,(butlast bindings) ,(cadar (last bindings)) ,const))) + + ;; Body is last variable. + (`(,head ,bindings ,(and var (pred symbolp) (pred (not keywordp)) + (pred (not booleanp)) + (guard (eq var (caar (last bindings)))))) + (if (eq head 'let) + `(progn ,@(mapcar (lambda (binding) + (and (consp binding) (cadr binding))) + bindings)) + `(let* ,(butlast bindings) ,(cadar (last bindings))))) + + (_ form))) (put 'nth 'byte-optimizer #'byte-optimize-nth) @@ -1286,6 +1279,14 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") form) form)) +(put 'cons 'byte-optimizer #'byte-optimize-cons) +(defun byte-optimize-cons (form) + ;; (cons X nil) => (list X) + (if (and (= (safe-length form) 3) + (null (nth 2 form))) + `(list ,(nth 1 form)) + form)) + ;; Fixme: delete-char -> delete-region (byte-coded) ;; optimize string-as-unibyte, string-as-multibyte, string-make-unibyte, ;; string-make-multibyte for constant args. @@ -1341,6 +1342,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") elt encode-char exp expt encode-time error-message-string fboundp fceiling featurep ffloor file-directory-p file-exists-p file-locked-p file-name-absolute-p + file-name-concat file-newer-than-file-p file-readable-p file-symlink-p file-writable-p float float-time floor format format-time-string frame-first-window frame-root-window frame-selected-window @@ -1354,7 +1356,8 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") line-beginning-position line-end-position local-variable-if-set-p local-variable-p locale-info log log10 logand logb logcount logior lognot logxor lsh - make-byte-code make-list make-string make-symbol marker-buffer max + make-byte-code make-list make-string make-symbol mark marker-buffer max + match-beginning match-end member memq memql min minibuffer-selected-window minibuffer-window mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string parse-colon-path plist-get plist-member @@ -1363,6 +1366,8 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") radians-to-degrees rassq rassoc read-from-string regexp-opt regexp-quote region-beginning region-end reverse round sin sqrt string string< string= string-equal string-lessp + string> string-greaterp string-empty-p + string-prefix-p string-suffix-p string-blank-p string-search string-to-char string-to-number string-to-syntax substring sxhash sxhash-equal sxhash-eq sxhash-eql @@ -1387,7 +1392,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") window-total-height window-total-width window-use-time window-vscroll window-width zerop)) (side-effect-and-error-free-fns - '(arrayp atom + '(always arrayp atom bignump bobp bolp bool-vector-p buffer-end buffer-list buffer-size buffer-string bufferp car-safe case-table-p cdr-safe char-or-string-p characterp @@ -1402,7 +1407,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") invocation-directory invocation-name keymapp keywordp list listp - make-marker mark mark-marker markerp max-char + make-marker mark-marker markerp max-char memory-limit mouse-movement-p natnump nlistp not null number-or-marker-p numberp @@ -1452,7 +1457,8 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") copysign isnan ldexp float logb floor ceiling round truncate ffloor fceiling fround ftruncate - string= string-equal string< string-lessp + string= string-equal string< string-lessp string> string-greaterp + string-empty-p string-blank-p string-prefix-p string-suffix-p string-search consp atom listp nlistp proper-list-p sequencep arrayp vectorp stringp bool-vector-p hash-table-p @@ -1601,10 +1607,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; so we create a copy of it, and replace the addresses with ;; TAGs. (let ((orig-table last-constant)) - (cl-loop for e across constvec - when (eq e last-constant) - do (setq last-constant (copy-hash-table e)) - and return nil) + (setq last-constant (copy-hash-table last-constant)) ;; Replace all addresses with TAGs. (maphash #'(lambda (value offset) (let ((match (assq offset tags))) @@ -2386,6 +2389,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; (eval-when-compile (or (byte-code-function-p (symbol-function 'byte-optimize-form)) + (subr-native-elisp-p (symbol-function 'byte-optimize-form)) (assq 'byte-code (symbol-function 'byte-optimize-form)) (let ((byte-optimize nil) (byte-compile-warnings nil)) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 88f362d24f0..aca5dcba62c 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -113,6 +113,9 @@ The return value of this function is not used." (list 'function-put (list 'quote f) ''side-effect-free (list 'quote val)))) +(put 'compiler-macro 'edebug-declaration-spec + '(&or symbolp ("lambda" &define lambda-list lambda-doc def-body))) + (defalias 'byte-run--set-compiler-macro #'(lambda (f args compiler-function) (if (not (eq (car-safe compiler-function) 'lambda)) @@ -143,6 +146,21 @@ The return value of this function is not used." (list 'function-put (list 'quote f) ''lisp-indent-function (list 'quote val)))) +(defalias 'byte-run--set-speed + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''speed (list 'quote val)))) + +(defalias 'byte-run--set-completion + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''completion-predicate (list 'function val)))) + +(defalias 'byte-run--set-modes + #'(lambda (f _args &rest val) + (list 'function-put (list 'quote f) + ''command-modes (list 'quote val)))) + ;; Add any new entries to info node `(elisp)Declare Form'. (defvar defun-declarations-alist (list @@ -159,7 +177,10 @@ This may shift errors from run-time to compile-time.") If `error-free', drop calls even if `byte-compile-delete-errors' is nil.") (list 'compiler-macro #'byte-run--set-compiler-macro) (list 'doc-string #'byte-run--set-doc-string) - (list 'indent #'byte-run--set-indent)) + (list 'indent #'byte-run--set-indent) + (list 'speed #'byte-run--set-speed) + (list 'completion #'byte-run--set-completion) + (list 'modes #'byte-run--set-modes)) "List associating function properties to their macro expansion. Each element of the list takes the form (PROP FUN) where FUN is a function. For each (PROP . VALUES) in a function's declaration, @@ -232,7 +253,7 @@ The return value is undefined. #'(lambda (x) (let ((f (cdr (assq (car x) macro-declarations-alist)))) (if f (apply (car f) name arglist (cdr x)) - (macroexp--warn-and-return + (macroexp-warn-and-return (format-message "Unknown macro property %S in %S" (car x) name) @@ -305,7 +326,7 @@ The return value is undefined. body))) nil) (t - (macroexp--warn-and-return + (macroexp-warn-and-return (format-message "Unknown defun property `%S' in %S" (car x) name) nil))))) @@ -366,6 +387,10 @@ You don't need this. (See bytecomp.el commentary for more details.) `(prog1 (defun ,name ,arglist ,@body) (eval-and-compile + ;; Never native-compile defsubsts as we need the byte + ;; definition in `byte-compile-unfold-bcf' to perform the + ;; inlining (Bug#42664, Bug#43280, Bug#44209). + ,(byte-run--set-speed name nil -1) (put ',name 'byte-optimizer 'byte-compile-inline-expand)))) (defvar advertised-signature-table (make-hash-table :test 'eq :weakness 'key)) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 9429d6a0d5d..7bd642d2b23 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -192,10 +192,9 @@ otherwise adds \".elc\"." (autoload 'byte-compile-inline-expand "byte-opt") ;; This is the entry point to the lapcode optimizer pass1. -(autoload 'byte-optimize-form "byte-opt") +(autoload 'byte-optimize-one-form "byte-opt") ;; This is the entry point to the lapcode optimizer pass2. (autoload 'byte-optimize-lapcode "byte-opt") -(autoload 'byte-compile-unfold-lambda "byte-opt") ;; This is the entry point to the decompiler, which is used by the ;; disassembler. The disassembler just requires 'byte-compile, but @@ -549,6 +548,10 @@ has the form (autoload . FILENAME).") (defvar byte-compile-unresolved-functions nil "Alist of undefined functions to which calls have been compiled. +Each element in the list has the form (FUNCTION POSITION . CALLS) +where CALLS is a list whose elements are integers (indicating the +number of arguments passed in the function call) or the constant `t' +if the function is called indirectly. This variable is only significant whilst compiling an entire buffer. Used for warnings when a function is not known to be defined or is later defined with incorrect args.") @@ -574,6 +577,46 @@ Each element is (INDEX . VALUE)") (defvar byte-compile-depth 0 "Current depth of execution stack.") (defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") +;; The following is used by comp.el to spill data out of here. +;; +;; Spilling is done in 3 places: +;; +;; - `byte-compile-lapcode' to obtain the map bytecode -> LAP for any +;; code assembled. +;; +;; - `byte-compile-lambda' to obtain arglist doc and interactive spec +;; af any lambda compiled (including anonymous). +;; +;; - `byte-compile-file-form-defmumble' to obtain the list of +;; top-level forms as they would be outputted in the .elc file. +;; + +(cl-defstruct byte-to-native-lambda + byte-func lap) + +;; Top level forms: +(cl-defstruct byte-to-native-func-def + "Named function defined at top-level." + name c-name byte-func) +(cl-defstruct byte-to-native-top-level + "All other top-level forms." + form lexical) + +(defvar byte-native-compiling nil + "Non-nil while native compiling.") +(defvar byte-native-qualities nil + "To spill default qualities from the compiled file.") +(defvar byte+native-compile nil + "Non-nil while producing at the same time byte and native code.") +(defvar byte-to-native-lambdas-h nil + "Hash byte-code -> byte-to-native-lambda.") +(defvar byte-to-native-top-level-forms nil + "List of top level forms.") +(defvar byte-to-native-output-file nil + "Temporary file containing the byte-compilation output.") +(defvar byte-to-native-plist-environment nil + "To spill `overriding-plist-environment'.") + ;;; The byte codes; this information is duplicated in bytecomp.c @@ -970,7 +1013,12 @@ CONST2 may be evaluated multiple times." ;; it within 2 bytes in the byte string). (puthash value pc hash-table)) hash-table)) - (apply 'unibyte-string (nreverse bytes)))) + (let ((bytecode (apply 'unibyte-string (nreverse bytes)))) + (when byte-native-compiling + ;; Spill LAP for the native compiler here. + (puthash bytecode (make-byte-to-native-lambda :lap lap) + byte-to-native-lambdas-h)) + bytecode))) ;;; compile-time evaluation @@ -1424,11 +1472,35 @@ when printing the error message." ;; Remember number of args in call. (let ((cons (assq f byte-compile-unresolved-functions))) (if cons - (or (memq nargs (cdr cons)) - (push nargs (cdr cons))) - (push (list f nargs) + (or (memq nargs (cddr cons)) + (push nargs (cddr cons))) + (push (list f byte-compile-last-position nargs) byte-compile-unresolved-functions))))) +(defun byte-compile-emit-callargs-warn (name actual-args min-args max-args) + (byte-compile-set-symbol-position name) + (byte-compile-warn + "%s called with %d argument%s, but %s %s" + name actual-args + (if (= 1 actual-args) "" "s") + (if (< actual-args min-args) + "requires" + "accepts only") + (byte-compile-arglist-signature-string (cons min-args max-args)))) + +(defun byte-compile--check-arity-bytecode (form bytecode) + "Check that the call in FORM matches that allowed by BYTECODE." + (when (and (byte-code-function-p bytecode) + (byte-compile-warning-enabled-p 'callargs)) + (let* ((actual-args (length (cdr form))) + (arity (func-arity bytecode)) + (min-args (car arity)) + (max-args (and (numberp (cdr arity)) (cdr arity)))) + (when (or (< actual-args min-args) + (and max-args (> actual-args max-args))) + (byte-compile-emit-callargs-warn + (car form) actual-args min-args max-args))))) + ;; Warn if the form is calling a function with the wrong number of arguments. (defun byte-compile-callargs-warn (form) (let* ((def (or (byte-compile-fdefinition (car form) nil) @@ -1443,16 +1515,9 @@ when printing the error message." (setcdr sig nil)) (if sig (when (or (< ncall (car sig)) - (and (cdr sig) (> ncall (cdr sig)))) - (byte-compile-set-symbol-position (car form)) - (byte-compile-warn - "%s called with %d argument%s, but %s %s" - (car form) ncall - (if (= 1 ncall) "" "s") - (if (< ncall (car sig)) - "requires" - "accepts only") - (byte-compile-arglist-signature-string sig)))) + (and (cdr sig) (> ncall (cdr sig)))) + (byte-compile-emit-callargs-warn + (car form) ncall (car sig) (cdr sig)))) (byte-compile-format-warn form) (byte-compile-function-warn (car form) (length (cdr form)) def))) @@ -1526,14 +1591,14 @@ extra args." (setq byte-compile-unresolved-functions (delq calls byte-compile-unresolved-functions)) (setq calls (delq t calls)) ;Ignore higher-order uses of the function. - (when (cdr calls) + (when (cddr calls) (when (and (symbolp name) (eq (function-get name 'byte-optimizer) 'byte-compile-inline-expand)) (byte-compile-warn "defsubst `%s' was used before it was defined" name)) (setq sig (byte-compile-arglist-signature arglist) - nums (sort (copy-sequence (cdr calls)) (function <)) + nums (sort (copy-sequence (cddr calls)) (function <)) min (car nums) max (car (nreverse nums))) (when (or (< min (car sig)) @@ -1579,7 +1644,7 @@ the `\\\\=[command]' ones that are assumed to be of length `byte-compile--wide-docstring-substitution-len'. Also ignore URLs." (string-match - (format "^.\\{%s,\\}$" (int-to-string (1+ col))) + (format "^.\\{%d,\\}$" (min (1+ col) #xffff)) ; Heed RE_DUP_MAX. (replace-regexp-in-string (rx (or ;; Ignore some URLs. @@ -1587,7 +1652,10 @@ URLs." ;; Ignore these `substitute-command-keys' substitutions. (seq "\\" (or "=" (seq "<" (* (not ">")) ">") - (seq "{" (* (not "}")) "}"))))) + (seq "{" (* (not "}")) "}"))) + ;; Ignore the function signature that's stashed at the end of + ;; the doc string (in some circumstances). + (seq bol "(fn (" (* nonl)))) "" ;; Heuristic: assume these substitutions are of some length N. (replace-regexp-in-string @@ -1641,56 +1709,21 @@ It is too wide if it has any lines longer than the largest of kind name col)))) form) -(defun byte-compile-print-syms (str1 strn syms) - (when syms - (byte-compile-set-symbol-position (car syms) t)) - (cond ((and (cdr syms) (not noninteractive)) - (let* ((str strn) - (L (length str)) - s) - (while syms - (setq s (symbol-name (pop syms)) - L (+ L (length s) 2)) - (if (< L (1- (buffer-local-value 'fill-column - (or (get-buffer - byte-compile-log-buffer) - (current-buffer))))) - (setq str (concat str " " s (and syms ","))) - (setq str (concat str "\n " s (and syms ",")) - L (+ (length s) 4)))) - (byte-compile-warn "%s" str))) - ((cdr syms) - (byte-compile-warn "%s %s" - strn - (mapconcat #'symbol-name syms ", "))) - - (syms - (byte-compile-warn str1 (car syms))))) - ;; If we have compiled any calls to functions which are not known to be ;; defined, issue a warning enumerating them. ;; `unresolved' in the list `byte-compile-warnings' disables this. (defun byte-compile-warn-about-unresolved-functions () (when (byte-compile-warning-enabled-p 'unresolved) - (let ((byte-compile-current-form :end) - (noruntime nil) - (unresolved nil)) + (let ((byte-compile-current-form :end)) ;; Separate the functions that will not be available at runtime ;; from the truly unresolved ones. - (dolist (f byte-compile-unresolved-functions) - (setq f (car f)) - (when (not (memq f byte-compile-new-defuns)) - (if (fboundp f) (push f noruntime) (push f unresolved)))) - ;; Complain about the no-run-time functions - (byte-compile-print-syms - "the function `%s' might not be defined at runtime." - "the following functions might not be defined at runtime:" - noruntime) - ;; Complain about the unresolved functions - (byte-compile-print-syms - "the function `%s' is not known to be defined." - "the following functions are not known to be defined:" - unresolved))) + (dolist (urf byte-compile-unresolved-functions) + (let ((f (car urf))) + (when (not (memq f byte-compile-new-defuns)) + (let ((byte-compile-last-position (cadr urf))) + (byte-compile-warn + (if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.") + (car urf)))))))) nil) @@ -1728,11 +1761,20 @@ It is too wide if it has any lines longer than the largest of ;; (byte-compile-generate-emacs19-bytecodes ;; byte-compile-generate-emacs19-bytecodes) (byte-compile-warnings byte-compile-warnings) + ;; Indicate that we're not currently loading some file. + ;; This is used in `macroexp-file-name' to make sure that + ;; loading file A which does (byte-compile-file B) won't + ;; cause macro calls in B to think they come from A. + (current-load-list (list nil)) ) - ,@body)) + (prog1 + (progn ,@body) + (when byte-native-compiling + (setq byte-to-native-plist-environment + overriding-plist-environment))))) (defmacro displaying-byte-compile-warnings (&rest body) - (declare (debug t)) + (declare (debug (def-body))) `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body)) (warning-series-started (and (markerp warning-series) @@ -1815,8 +1857,8 @@ also be compiled." (while directories (setq directory (car directories)) (message "Checking %s..." directory) - (dolist (file (directory-files directory)) - (let ((source (expand-file-name file directory))) + (dolist (source (directory-files directory t)) + (let ((file (file-name-nondirectory source))) (if (file-directory-p source) (and (not (member file '("RCS" "CVS"))) (not (eq ?\. (aref file 0))) @@ -1832,8 +1874,7 @@ also be compiled." (file-readable-p source) (not (string-match "\\`\\.#" file)) (not (auto-save-file-name-p source)) - (not (string-equal dir-locals-file - (file-name-nondirectory source)))) + (not (member source (dir-locals--all-files directory)))) (progn (cl-incf (pcase (byte-recompile-file source force arg) ('no-byte-compile skip-count) @@ -2041,64 +2082,73 @@ See also `emacs-lisp-byte-compile-and-load'." (message "Compiling %s...done" filename)) (kill-buffer input-buffer) (with-current-buffer output-buffer - (goto-char (point-max)) - (insert "\n") ; aaah, unix. - (cond - ((null target-file) nil) ;We only wanted the warnings! - ((and (file-writable-p target-file) - ;; We attempt to create a temporary file in the - ;; target directory, so the target directory must be - ;; writable. - (file-writable-p - (file-name-directory - ;; Need to expand in case TARGET-FILE doesn't - ;; include a directory (Bug#45287). - (expand-file-name target-file)))) - ;; We must disable any code conversion here. - (let* ((coding-system-for-write 'no-conversion) - ;; Write to a tempfile so that if another Emacs - ;; process is trying to load target-file (eg in a - ;; parallel bootstrap), it does not risk getting a - ;; half-finished file. (Bug#4196) - (tempfile - (make-temp-file (expand-file-name target-file))) - (default-modes (default-file-modes)) - (temp-modes (logand default-modes #o600)) - (desired-modes (logand default-modes #o666)) - (kill-emacs-hook - (cons (lambda () (ignore-errors - (delete-file tempfile))) - kill-emacs-hook))) - (unless (= temp-modes desired-modes) - (set-file-modes tempfile desired-modes 'nofollow)) - (write-region (point-min) (point-max) tempfile nil 1) - ;; This has the intentional side effect that any - ;; hard-links to target-file continue to - ;; point to the old file (this makes it possible - ;; for installed files to share disk space with - ;; the build tree, without causing problems when - ;; emacs-lisp files in the build tree are - ;; recompiled). Previously this was accomplished by - ;; deleting target-file before writing it. - (rename-file tempfile target-file t)) - (or noninteractive (message "Wrote %s" target-file))) - ((file-writable-p target-file) - ;; In case the target directory isn't writable (see e.g. Bug#44631), - ;; try writing to the output file directly. We must disable any - ;; code conversion here. - (let ((coding-system-for-write 'no-conversion)) - (with-file-modes (logand (default-file-modes) #o666) - (write-region (point-min) (point-max) target-file nil 1))) - (or noninteractive (message "Wrote %s" target-file))) - (t - ;; This is just to give a better error message than write-region - (let ((exists (file-exists-p target-file))) - (signal (if exists 'file-error 'file-missing) - (list "Opening output file" - (if exists - "Cannot overwrite file" - "Directory not writable or nonexistent") - target-file))))) + (when (and target-file + (or (not byte-native-compiling) + (and byte-native-compiling byte+native-compile))) + (goto-char (point-max)) + (insert "\n") ; aaah, unix. + (cond + ((and (file-writable-p target-file) + ;; We attempt to create a temporary file in the + ;; target directory, so the target directory must be + ;; writable. + (file-writable-p + (file-name-directory + ;; Need to expand in case TARGET-FILE doesn't + ;; include a directory (Bug#45287). + (expand-file-name target-file)))) + ;; We must disable any code conversion here. + (let* ((coding-system-for-write 'no-conversion) + ;; Write to a tempfile so that if another Emacs + ;; process is trying to load target-file (eg in a + ;; parallel bootstrap), it does not risk getting a + ;; half-finished file. (Bug#4196) + (tempfile + (make-temp-file (when (file-writable-p target-file) + (expand-file-name target-file)))) + (default-modes (default-file-modes)) + (temp-modes (logand default-modes #o600)) + (desired-modes (logand default-modes #o666)) + (kill-emacs-hook + (cons (lambda () (ignore-errors + (delete-file tempfile))) + kill-emacs-hook))) + (unless (= temp-modes desired-modes) + (set-file-modes tempfile desired-modes 'nofollow)) + (write-region (point-min) (point-max) tempfile nil 1) + ;; This has the intentional side effect that any + ;; hard-links to target-file continue to + ;; point to the old file (this makes it possible + ;; for installed files to share disk space with + ;; the build tree, without causing problems when + ;; emacs-lisp files in the build tree are + ;; recompiled). Previously this was accomplished by + ;; deleting target-file before writing it. + (if byte-native-compiling + ;; Defer elc final renaming. + (setf byte-to-native-output-file + (cons tempfile target-file)) + (rename-file tempfile target-file t))) + (or noninteractive + byte-native-compiling + (message "Wrote %s" target-file))) + ((file-writable-p target-file) + ;; In case the target directory isn't writable (see e.g. Bug#44631), + ;; try writing to the output file directly. We must disable any + ;; code conversion here. + (let ((coding-system-for-write 'no-conversion)) + (with-file-modes (logand (default-file-modes) #o666) + (write-region (point-min) (point-max) target-file nil 1))) + (or noninteractive (message "Wrote %s" target-file))) + (t + ;; This is just to give a better error message than write-region + (let ((exists (file-exists-p target-file))) + (signal (if exists 'file-error 'file-missing) + (list "Opening output file" + (if exists + "Cannot overwrite file" + "Directory not writable or nonexistent") + target-file)))))) (kill-buffer (current-buffer))) (if (and byte-compile-generate-call-tree (or (eq t byte-compile-generate-call-tree) @@ -2201,6 +2251,17 @@ With argument ARG, insert value in current buffer after the form." (setq byte-compile-unresolved-functions nil) (setq byte-compile-noruntime-functions nil) (setq byte-compile-new-defuns nil) + (when byte-native-compiling + (defvar native-comp-speed) + (push `(native-comp-speed . ,native-comp-speed) byte-native-qualities) + (defvar native-comp-debug) + (push `(native-comp-debug . ,native-comp-debug) byte-native-qualities) + (defvar native-comp-driver-options) + (push `(native-comp-driver-options . ,native-comp-driver-options) + byte-native-qualities) + (defvar no-native-compile) + (push `(no-native-compile . ,no-native-compile) + byte-native-qualities)) ;; Compile the forms from the input buffer. (while (progn @@ -2273,6 +2334,10 @@ Call from the source buffer." ;; defalias calls are output directly by byte-compile-file-form-defmumble; ;; it does not pay to first build the defalias in defmumble and then parse ;; it here. + (when byte-native-compiling + ;; Spill output for the native compiler here + (push (make-byte-to-native-top-level :form form :lexical lexical-binding) + byte-to-native-top-level-forms)) (let ((print-escape-newlines t) (print-length nil) (print-level nil) @@ -2390,7 +2455,7 @@ list that represents a doc string reference. (defun byte-compile-keep-pending (form &optional handler) (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-form form t))) + (setq form (byte-optimize-one-form form t))) (if handler (let ((byte-compile--for-effect t)) ;; To avoid consing up monstrously large forms at load time, we split @@ -2418,8 +2483,6 @@ list that represents a doc string reference. byte-compile-output nil byte-compile-jump-tables nil)))) -(defvar byte-compile-force-lexical-warnings nil) - (defun byte-compile-preprocess (form &optional _for-effect) (setq form (macroexpand-all form byte-compile-macro-environment)) ;; FIXME: We should run byte-optimize-form here, but it currently does not @@ -2430,7 +2493,6 @@ list that represents a doc string reference. ;; (setq form (byte-optimize-form form for-effect))) (cond (lexical-binding (cconv-closure-convert form)) - (byte-compile-force-lexical-warnings (cconv-warnings-only form)) (t form))) ;; byte-hunk-handlers cannot call this! @@ -2496,12 +2558,14 @@ list that represents a doc string reference. (put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) (put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar) -(defun byte-compile--declare-var (sym) +(defun byte-compile--check-prefixed-var (sym) (when (and (symbolp sym) (not (string-match "[-*/:$]" (symbol-name sym))) (byte-compile-warning-enabled-p 'lexical sym)) - (byte-compile-warn "global/dynamic var `%s' lacks a prefix" - sym)) + (byte-compile-warn "global/dynamic var `%s' lacks a prefix" sym))) + +(defun byte-compile--declare-var (sym) + (byte-compile--check-prefixed-var sym) (when (memq sym byte-compile-lexical-variables) (setq byte-compile-lexical-variables (delq sym byte-compile-lexical-variables)) @@ -2717,6 +2781,15 @@ not to take responsibility for the actual compilation of the code." ;; If there's no doc string, provide -1 as the "doc string ;; index" so that no element will be treated as a doc string. (if (not (stringp (documentation code t))) -1 4))) + (when byte-native-compiling + ;; Spill output for the native compiler here. + (push (if macro + (make-byte-to-native-top-level + :form `(defalias ',name '(macro . ,code) nil) + :lexical lexical-binding) + (make-byte-to-native-func-def :name name + :byte-func code)) + byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having ;; b-c-output-file-form analyze the defalias. (byte-compile-output-docform @@ -2784,16 +2857,12 @@ FUN should be either a `lambda' value or a `closure' value." (dolist (binding env) (cond ((consp binding) - ;; We check shadowing by the args, so that the `let' can be moved - ;; within the lambda, which can then be unfolded. FIXME: Some of those - ;; bindings might be unused in `body'. - (unless (memq (car binding) args) ;Shadowed. - (push `(,(car binding) ',(cdr binding)) renv))) + (push `(,(car binding) ',(cdr binding)) renv)) ((eq binding t)) (t (push `(defvar ,binding) body)))) (if (null renv) `(lambda ,args ,@preamble ,@body) - `(lambda ,args ,@preamble (let ,(nreverse renv) ,@body))))) + `(let ,renv (lambda ,args ,@preamble ,@body))))) ;;;###autoload (defun byte-compile (form) @@ -2818,23 +2887,27 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (symbolp form) form "provided")) fun) (t - (when (or (symbolp form) (eq (car-safe fun) 'closure)) - ;; `fun' is a function *value*, so try to recover its corresponding - ;; source code. - (setq lexical-binding (eq (car fun) 'closure)) - (setq fun (byte-compile--reify-function fun))) - ;; Expand macros. - (setq fun (byte-compile-preprocess fun)) - (setq fun (byte-compile-top-level fun nil 'eval)) - (if (symbolp form) - ;; byte-compile-top-level returns an *expression* equivalent to the - ;; `fun' expression, so we need to evaluate it, tho normally - ;; this is not needed because the expression is just a constant - ;; byte-code object, which is self-evaluating. - (setq fun (eval fun t))) - (if macro (push 'macro fun)) - (if (symbolp form) (fset form fun)) - fun)))))) + (let (final-eval) + (when (or (symbolp form) (eq (car-safe fun) 'closure)) + ;; `fun' is a function *value*, so try to recover its corresponding + ;; source code. + (setq lexical-binding (eq (car fun) 'closure)) + (setq fun (byte-compile--reify-function fun)) + (setq final-eval t)) + ;; Expand macros. + (setq fun (byte-compile-preprocess fun)) + (setq fun (byte-compile-top-level fun nil 'eval)) + (if (symbolp form) + ;; byte-compile-top-level returns an *expression* equivalent to the + ;; `fun' expression, so we need to evaluate it, tho normally + ;; this is not needed because the expression is just a constant + ;; byte-code object, which is self-evaluating. + (setq fun (eval fun t))) + (if final-eval + (setq fun (eval fun t))) + (if macro (push 'macro fun)) + (if (symbolp form) (fset form fun)) + fun))))))) (defun byte-compile-sexp (sexp) "Compile and return SEXP." @@ -2860,7 +2933,9 @@ If FORM is a lambda or a macro, byte-compile it as a function." ((eq arg '&optional) (when (memq '&optional (cdr list)) (error "Duplicate &optional"))) - ((memq arg vars) + ((and (memq arg vars) + ;; Allow repetitions for unused args. + (not (string-match "\\`_" (symbol-name arg)))) (byte-compile-warn "repeated variable %s in lambda-list" arg)) (t (push arg vars)))) @@ -2940,7 +3015,8 @@ for symbols generated by the byte compiler itself." ;; unless it is the last element of the body. (if (cdr body) (setq body (cdr body)))))) - (int (assq 'interactive body))) + (int (assq 'interactive body)) + command-modes) (when lexical-binding (dolist (var arglistvars) (when (assq var byte-compile--known-dynamic-vars) @@ -2951,10 +3027,13 @@ for symbols generated by the byte compiler itself." ;; Skip (interactive) if it is in front (the most usual location). (if (eq int (car body)) (setq body (cdr body))) - (cond ((consp (cdr int)) - (if (cdr (cdr int)) - (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string int))) + (cond ((consp (cdr int)) ; There is an `interactive' spec. + ;; Check that the bit after the `interactive' spec is + ;; just a list of symbols (i.e., modes). + (unless (seq-every-p #'symbolp (cdr (cdr int))) + (byte-compile-warn "malformed interactive specc: %s" + (prin1-to-string int))) + (setq command-modes (cdr (cdr int))) ;; If the interactive spec is a call to `list', don't ;; compile it, because `call-interactively' looks at the ;; args of `list'. Actually, compile it to get warnings, @@ -2965,15 +3044,14 @@ for symbols generated by the byte compiler itself." (while (consp (cdr form)) (setq form (cdr form))) (setq form (car form))) - (if (and (eq (car-safe form) 'list) - ;; For code using lexical-binding, form is not - ;; valid lisp, but rather an intermediate form - ;; which may include "calls" to - ;; internal-make-closure (Bug#29988). - (not lexical-binding)) - nil - (setq int `(interactive ,newform))))) - ((cdr int) + (when (or (not (eq (car-safe form) 'list)) + ;; For code using lexical-binding, form is not + ;; valid lisp, but rather an intermediate form + ;; which may include "calls" to + ;; internal-make-closure (Bug#29988). + lexical-binding) + (setq int `(interactive ,newform))))) + ((cdr int) ; Invalid (interactive . something). (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string int))))) ;; Process the body. @@ -2989,23 +3067,37 @@ for symbols generated by the byte compiler itself." reserved-csts))) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) - (apply #'make-byte-code - (if lexical-binding - (byte-compile-make-args-desc arglist) - arglist) - (append - ;; byte-string, constants-vector, stack depth - (cdr compiled) - ;; optionally, the doc string. - (cond ((and lexical-binding arglist) - ;; byte-compile-make-args-desc lost the args's names, - ;; so preserve them in the docstring. - (list (help-add-fundoc-usage doc arglist))) - ((or doc int) - (list doc))) - ;; optionally, the interactive spec. - (if int - (list (nth 1 int)))))))) + (let ((out + (apply #'make-byte-code + (if lexical-binding + (byte-compile-make-args-desc arglist) + arglist) + (append + ;; byte-string, constants-vector, stack depth + (cdr compiled) + ;; optionally, the doc string. + (cond ((and lexical-binding arglist) + ;; byte-compile-make-args-desc lost the args's names, + ;; so preserve them in the docstring. + (list (help-add-fundoc-usage doc arglist))) + ((or doc int) + (list doc))) + ;; optionally, the interactive spec (and the modes the + ;; command applies to). + (cond + ;; We have some command modes, so use the vector form. + (command-modes + (list (vector (nth 1 int) command-modes))) + ;; No command modes, use the simple form with just the + ;; interactive spec. + (int + (list (nth 1 int)))))))) + (when byte-native-compiling + (setf (byte-to-native-lambda-byte-func + (gethash (cadr compiled) + byte-to-native-lambdas-h)) + out)) + out)))) (defvar byte-compile-reserved-constants 0) @@ -3063,7 +3155,7 @@ for symbols generated by the byte compiler itself." (byte-compile-output nil) (byte-compile-jump-tables nil)) (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-form form byte-compile--for-effect))) + (setq form (byte-optimize-one-form form byte-compile--for-effect))) (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) (setq form (nth 1 form))) ;; Set up things for a lexically-bound function. @@ -3277,7 +3369,7 @@ for symbols generated by the byte compiler itself." ((and (eq (car-safe (car form)) 'lambda) ;; if the form comes out the same way it went in, that's ;; because it was malformed, and we couldn't unfold it. - (not (eq form (setq form (byte-compile-unfold-lambda form))))) + (not (eq form (setq form (macroexp--unfold-lambda form))))) (byte-compile-form form byte-compile--for-effect) (setq byte-compile--for-effect nil)) ((byte-compile-normal-call form))) @@ -3806,15 +3898,38 @@ discarding." (cl-assert (or (> (length env) 0) docstring-exp)) ;Otherwise, we don't need a closure. (cl-assert (byte-code-function-p fun)) - (byte-compile-form `(make-byte-code - ',(aref fun 0) ',(aref fun 1) - (vconcat (vector . ,env) ',(aref fun 2)) - ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun)))) - (if docstring-exp - `(,(car rest) - ,docstring-exp - ,@(cddr rest)) - rest))))))) + (byte-compile-form + (if (or (not docstring-exp) (stringp docstring-exp)) + ;; Use symbols V0, V1 ... as placeholders for closure variables: + ;; they should be short (to save space in the .elc file), yet + ;; distinct when disassembled. + (let* ((dummy-vars (mapcar (lambda (i) (intern (format "V%d" i))) + (number-sequence 0 (1- (length env))))) + (opt-args (mapcar (lambda (i) (aref fun i)) + (number-sequence 4 (1- (length fun))))) + (proto-fun + (apply #'make-byte-code + (aref fun 0) (aref fun 1) + ;; Prepend dummy cells to the constant vector, + ;; to get the indices right when disassembling. + (vconcat dummy-vars (aref fun 2)) + (aref fun 3) + (if docstring-exp + (cons docstring-exp (cdr opt-args)) + opt-args)))) + `(make-closure ,proto-fun ,@env)) + ;; Nontrivial doc string expression: create a bytecode object + ;; from small pieces at run time. + `(make-byte-code + ',(aref fun 0) ',(aref fun 1) + (vconcat (vector . ,env) ',(aref fun 2)) + ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun)))) + (if docstring-exp + `(,(car rest) + ,docstring-exp + ,@(cddr rest)) + rest)))) + )))) (defun byte-compile-get-closed-var (form) "Byte-compile the special `internal-get-closed-var' form." @@ -4148,9 +4263,15 @@ that suppresses all warnings during execution of BODY." byte-compile-unresolved-functions)) (bound-list (byte-compile-find-bound-condition ,condition '(boundp default-boundp local-variable-p))) + (new-bound-list + ;; (seq-difference byte-compile-bound-variables)) + (delq nil (mapcar (lambda (s) + (if (memq s byte-compile-bound-variables) nil s)) + bound-list))) ;; Maybe add to the bound list. (byte-compile-bound-variables - (append bound-list byte-compile-bound-variables))) + (append new-bound-list byte-compile-bound-variables))) + (mapc #'byte-compile--check-prefixed-var new-bound-list) (unwind-protect ;; If things not being bound at all is ok, so must them being ;; obsolete. Note that we add to the existing lists since Tramp @@ -4236,6 +4357,17 @@ Return (TAIL VAR TEST CASES), where: (push value keys) (push (cons (list value) (or body '(t))) cases)) t)))) + ;; Treat (not X) as (eq X nil). + (`((,(or 'not 'null) ,(and var (pred symbolp))) . ,body) + (and (or (eq var switch-var) (not switch-var)) + (progn + (setq switch-var var) + (setq switch-test + (byte-compile--common-test switch-test 'eq)) + (unless (memq nil keys) + (push nil keys) + (push (cons (list nil) (or body '(t))) cases)) + t))) (`((,(and fn (or 'memq 'memql 'member)) ,var ,expr) . ,body) (and (symbolp var) (or (eq var switch-var) (not switch-var)) @@ -4608,10 +4740,15 @@ binding slots have been popped." (defun byte-compile-condition-case (form) (let* ((var (nth 1 form)) (body (nth 2 form)) + (handlers (nthcdr 3 form)) (depth byte-compile-depth) + (success-handler (assq :success handlers)) + (failure-handlers (if success-handler + (remq success-handler handlers) + handlers)) (clauses (mapcar (lambda (clause) (cons (byte-compile-make-tag) clause)) - (nthcdr 3 form))) + failure-handlers)) (endtag (byte-compile-make-tag))) (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) @@ -4637,30 +4774,40 @@ binding slots have been popped." (byte-compile-form body) ;; byte-compile--for-effect (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) - (byte-compile-goto 'byte-goto endtag) - (while clauses - (let ((clause (pop clauses)) - (byte-compile-bound-variables byte-compile-bound-variables) - (byte-compile--lexical-environment - byte-compile--lexical-environment)) - (setq byte-compile-depth (1+ depth)) - (byte-compile-out-tag (pop clause)) - (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) - (cond - ((null var) (byte-compile-discard)) - (lexical-binding - (push (cons var (1- byte-compile-depth)) - byte-compile--lexical-environment)) - (t (byte-compile-dynamic-variable-bind var))) - (byte-compile-body (cdr clause)) ;; byte-compile--for-effect - (cond - ((null var) nil) - (lexical-binding (byte-compile-discard 1 'preserve-tos)) - (t (byte-compile-out 'byte-unbind 1))) - (byte-compile-goto 'byte-goto endtag))) + (let ((compile-handler-body + (lambda (body) + (let ((byte-compile-bound-variables byte-compile-bound-variables) + (byte-compile--lexical-environment + byte-compile--lexical-environment)) + (cond + ((null var) (byte-compile-discard)) + (lexical-binding + (push (cons var (1- byte-compile-depth)) + byte-compile--lexical-environment)) + (t (byte-compile-dynamic-variable-bind var))) - (byte-compile-out-tag endtag))) + (byte-compile-body body) ;; byte-compile--for-effect + + (cond + ((null var)) + (lexical-binding (byte-compile-discard 1 'preserve-tos)) + (t (byte-compile-out 'byte-unbind 1))))))) + + (when success-handler + (funcall compile-handler-body (cdr success-handler))) + + (byte-compile-goto 'byte-goto endtag) + + (while clauses + (let ((clause (pop clauses))) + (setq byte-compile-depth (1+ depth)) + (byte-compile-out-tag (pop clause)) + (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) + (funcall compile-handler-body (cdr clause)) + (byte-compile-goto 'byte-goto endtag))) + + (byte-compile-out-tag endtag)))) (defun byte-compile-save-excursion (form) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) @@ -4868,10 +5015,10 @@ binding slots have been popped." (byte-compile-push-constant op) (byte-compile-form fun) (byte-compile-form prop) - (let* ((fun (eval fun)) - (prop (eval prop)) + (let* ((fun (eval fun t)) + (prop (eval prop t)) (val (if (macroexp-const-p val) - (eval val) + (eval val t) (byte-compile-lambda (cadr val))))) (push `(,fun . (,prop ,val ,@(alist-get fun overriding-plist-environment))) @@ -5189,8 +5336,10 @@ already up-to-date." "Reload any Lisp file that was changed since Emacs was dumped. Use with caution." (let* ((argv0 (car command-line-args)) - (emacs-file (executable-find argv0))) - (if (not (and emacs-file (file-executable-p emacs-file))) + (emacs-file (or (and (fboundp 'pdumper-stats) + (cdr (nth 2 (pdumper-stats)))) + (executable-find argv0)))) + (if (not (and emacs-file (file-exists-p emacs-file))) (message "Can't find %s to refresh preloaded Lisp files" argv0) (dolist (f (reverse load-history)) (setq f (car f)) @@ -5203,7 +5352,7 @@ Use with caution." ;; so it can cause recompilation to fail. (not (member (file-name-nondirectory f) '("pcase.el" "bytecomp.el" "macroexp.el" - "cconv.el" "byte-opt.el")))) + "cconv.el" "byte-opt.el" "comp.el")))) (message "Reloading stale %s" (file-name-nondirectory f)) (condition-case nil (load f 'noerror nil 'nosuffix) @@ -5284,13 +5433,15 @@ and corresponding effects." ;; (eval-when-compile (or (byte-code-function-p (symbol-function 'byte-compile-form)) + (subr-native-elisp-p (symbol-function 'byte-compile-form)) (assq 'byte-code (symbol-function 'byte-compile-form)) (let ((byte-optimize nil) ; do it fast (byte-compile-warnings nil)) (mapc (lambda (x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x))) + (unless (subr-native-elisp-p x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x)))) '(byte-compile-normal-call byte-compile-form byte-compile-body diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index e79583974a8..3abbf716875 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -1,4 +1,4 @@ -;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t -*- +;;; cconv.el --- Closure conversion for statically scoped Emacs Lisp. -*- lexical-binding: t -*- ;; Copyright (C) 2011-2021 Free Software Foundation, Inc. @@ -121,19 +121,22 @@ (defconst cconv-liftwhen 6 "Try to do lambda lifting if the number of arguments + free variables is less than this number.") -;; List of all the variables that are both captured by a closure -;; and mutated. Each entry in the list takes the form -;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the -;; variable (or is just (VAR) for variables not introduced by let). -(defvar cconv-captured+mutated) - -;; List of candidates for lambda lifting. -;; Each candidate has the form (BINDER . PARENTFORM). A candidate -;; is a variable that is only passed to `funcall' or `apply'. -(defvar cconv-lambda-candidates) - -;; Alist associating to each function body the list of its free variables. -(defvar cconv-freevars-alist) +(defvar cconv-var-classification + ;; Alist mapping variables to a given class. + ;; The keys are of the form (BINDER . PARENTFORM) where BINDER + ;; is the (VAR VAL) that introduces it (or is just (VAR) for variables + ;; not introduced by let). + ;; The class can be one of: + ;; - :unused + ;; - :lambda-candidate + ;; - :captured+mutated + ;; - nil for "normal" variables, which would then just not appear + ;; in the alist at all. + ) + +(defvar cconv-freevars-alist + ;; Alist associating to each function body the list of its free variables. + ) ;;;###autoload (defun cconv-closure-convert (form) @@ -144,25 +147,13 @@ is less than this number.") Returns a form where all lambdas don't have any free variables." ;; (message "Entering cconv-closure-convert...") (let ((cconv-freevars-alist '()) - (cconv-lambda-candidates '()) - (cconv-captured+mutated '())) + (cconv-var-classification '())) ;; Analyze form - fill these variables with new information. (cconv-analyze-form form '()) (setq cconv-freevars-alist (nreverse cconv-freevars-alist)) (prog1 (cconv-convert form nil nil) ; Env initially empty. (cl-assert (null cconv-freevars-alist))))) -;;;###autoload -(defun cconv-warnings-only (form) - "Add the warnings that closure conversion would encounter." - (let ((cconv-freevars-alist '()) - (cconv-lambda-candidates '()) - (cconv-captured+mutated '())) - ;; Analyze form - fill these variables with new information. - (cconv-analyze-form form '()) - ;; But don't perform the closure conversion. - form)) - (defconst cconv--dummy-var (make-symbol "ignored")) (defun cconv--set-diff (s1 s2) @@ -261,28 +252,56 @@ Returns a form where all lambdas don't have any free variables." (nthcdr 3 mapping))))) new-env)) +(defun cconv--warn-unused-msg (var varkind) + (unless (or ;; Uninterned symbols typically come from macro-expansion, so + ;; it is often non-trivial for the programmer to avoid such + ;; unused vars. + (not (intern-soft var)) + (eq ?_ (aref (symbol-name var) 0)) + ;; As a special exception, ignore "ignore". + (eq var 'ignored)) + (let ((suggestions (help-uni-confusable-suggestions (symbol-name var)))) + (format "Unused lexical %s `%S'%s" + varkind var + (if suggestions (concat "\n " suggestions) ""))))) + +(define-inline cconv--var-classification (binder form) + (inline-quote + (alist-get (cons ,binder ,form) cconv-var-classification + nil nil #'equal))) + (defun cconv--convert-funcbody (funargs funcbody env parentform) "Run `cconv-convert' on FUNCBODY, the forms of a lambda expression. PARENTFORM is the form containing the lambda expression. ENV is a lexical environment (same format as for `cconv-convert'), not including FUNARGS, the function's argument list. Return a list of converted forms." - (let ((letbind ())) + (let ((wrappers ())) (dolist (arg funargs) - (if (not (member (cons (list arg) parentform) cconv-captured+mutated)) - (if (assq arg env) (push `(,arg . nil) env)) - (push `(,arg . (car-safe ,arg)) env) - (push `(,arg (list ,arg)) letbind))) + (pcase (cconv--var-classification (list arg) parentform) + (:captured+mutated + (push `(,arg . (car-safe ,arg)) env) + (push (lambda (body) `(let ((,arg (list ,arg))) ,body)) wrappers)) + ((and :unused + (let (and (pred stringp) msg) + (cconv--warn-unused-msg arg "argument"))) + (if (assq arg env) (push `(,arg . nil) env)) ;FIXME: Is it needed? + (push (lambda (body) (macroexp--warn-wrap msg body 'lexical)) wrappers)) + (_ + (if (assq arg env) (push `(,arg . nil) env))))) (setq funcbody (mapcar (lambda (form) (cconv-convert form env nil)) funcbody)) - (if letbind + (if wrappers (let ((special-forms '())) ;; Keep special forms at the beginning of the body. - (while (or (stringp (car funcbody)) ;docstring. - (memq (car-safe (car funcbody)) '(interactive declare))) + (while (or (and (cdr funcbody) (stringp (car funcbody))) ;docstring. + (memq (car-safe (car funcbody)) + '(interactive declare :documentation))) (push (pop funcbody) special-forms)) - `(,@(nreverse special-forms) (let ,letbind . ,funcbody))) + (let ((body (macroexp-progn funcbody))) + (dolist (wrapper wrappers) (setq body (funcall wrapper body))) + `(,@(nreverse special-forms) ,@(macroexp-unprogn body)))) funcbody))) (defun cconv-convert (form env extend) @@ -338,69 +357,91 @@ places where they originally did not directly appear." "Malformed `%S' binding: %S" letsym binder)) (setq value (cadr binder)) - (car binder))) - (new-val - (cond - ;; Check if var is a candidate for lambda lifting. - ((and (member (cons binder form) cconv-lambda-candidates) - (progn - (cl-assert (and (eq (car value) 'function) - (eq (car (cadr value)) 'lambda))) - (cl-assert (equal (cddr (cadr value)) - (caar cconv-freevars-alist))) - ;; Peek at the freevars to decide whether to λ-lift. - (let* ((fvs (cdr (car cconv-freevars-alist))) - (fun (cadr value)) - (funargs (cadr fun)) - (funcvars (append fvs funargs))) + (car binder)))) + (cond + ;; Ignore bindings without a valid name. + ((not (symbolp var)) + (byte-compile-warn "attempt to let-bind nonvariable `%S'" var)) + ((or (booleanp var) (keywordp var)) + (byte-compile-warn "attempt to let-bind constant `%S'" var)) + (t + (let ((new-val + (pcase (cconv--var-classification binder form) + ;; Check if var is a candidate for lambda lifting. + ((and :lambda-candidate + (guard + (progn + (cl-assert (and (eq (car value) 'function) + (eq (car (cadr value)) 'lambda))) + (cl-assert (equal (cddr (cadr value)) + (caar cconv-freevars-alist))) + ;; Peek at the freevars to decide whether + ;; to λ-lift. + (let* ((fvs (cdr (car cconv-freevars-alist))) + (fun (cadr value)) + (funargs (cadr fun)) + (funcvars (append fvs funargs))) ; lambda lifting condition - (and fvs (>= cconv-liftwhen (length funcvars)))))) + (and fvs (>= cconv-liftwhen + (length funcvars))))))) ; Lift. - (let* ((fvs (cdr (pop cconv-freevars-alist))) - (fun (cadr value)) - (funargs (cadr fun)) - (funcvars (append fvs funargs)) - (funcbody (cddr fun)) - (funcbody-env ())) - (push `(,var . (apply-partially ,var . ,fvs)) new-env) - (dolist (fv fvs) - (cl-pushnew fv new-extend) - (if (and (eq 'car-safe (car-safe (cdr (assq fv env)))) - (not (memq fv funargs))) - (push `(,fv . (car-safe ,fv)) funcbody-env))) - `(function (lambda ,funcvars . - ,(cconv--convert-funcbody - funargs funcbody funcbody-env value))))) - - ;; Check if it needs to be turned into a "ref-cell". - ((member (cons binder form) cconv-captured+mutated) - ;; Declared variable is mutated and captured. - (push `(,var . (car-safe ,var)) new-env) - `(list ,(cconv-convert value env extend))) - - ;; Normal default case. - (t - (if (assq var new-env) (push `(,var) new-env)) - (cconv-convert value env extend))))) - - (when (and (eq letsym 'let*) (memq var new-extend)) - ;; One of the lambda-lifted vars is shadowed, so add - ;; a reference to the outside binding and arrange to use - ;; that reference. - (let ((closedsym (make-symbol (format "closed-%s" var)))) - (setq new-env (cconv--remap-llv new-env var closedsym)) - (setq new-extend (cons closedsym (remq var new-extend))) - (push `(,closedsym ,var) binders-new))) - - ;; We push the element after redefined free variables are - ;; processed. This is important to avoid the bug when free - ;; variable and the function have the same name. - (push (list var new-val) binders-new) - - (when (eq letsym 'let*) - (setq env new-env) - (setq extend new-extend)) - )) ; end of dolist over binders + (let* ((fvs (cdr (pop cconv-freevars-alist))) + (fun (cadr value)) + (funargs (cadr fun)) + (funcvars (append fvs funargs)) + (funcbody (cddr fun)) + (funcbody-env ())) + (push `(,var . (apply-partially ,var . ,fvs)) new-env) + (dolist (fv fvs) + (cl-pushnew fv new-extend) + (if (and (eq 'car-safe (car-safe + (cdr (assq fv env)))) + (not (memq fv funargs))) + (push `(,fv . (car-safe ,fv)) funcbody-env))) + `(function (lambda ,funcvars . + ,(cconv--convert-funcbody + funargs funcbody funcbody-env value))))) + + ;; Check if it needs to be turned into a "ref-cell". + (:captured+mutated + ;; Declared variable is mutated and captured. + (push `(,var . (car-safe ,var)) new-env) + `(list ,(cconv-convert value env extend))) + + ;; Check if it needs to be turned into a "ref-cell". + (:unused + ;; Declared variable is unused. + (if (assq var new-env) + (push `(,var) new-env)) ;FIXME:Needed? + (let ((newval + `(ignore ,(cconv-convert value env extend))) + (msg (cconv--warn-unused-msg var "variable"))) + (if (null msg) newval + (macroexp--warn-wrap msg newval 'lexical)))) + + ;; Normal default case. + (_ + (if (assq var new-env) (push `(,var) new-env)) + (cconv-convert value env extend))))) + + (when (and (eq letsym 'let*) (memq var new-extend)) + ;; One of the lambda-lifted vars is shadowed, so add + ;; a reference to the outside binding and arrange to use + ;; that reference. + (let ((closedsym (make-symbol (format "closed-%s" var)))) + (setq new-env (cconv--remap-llv new-env var closedsym)) + (setq new-extend (cons closedsym (remq var new-extend))) + (push `(,closedsym ,var) binders-new))) + + ;; We push the element after redefined free variables are + ;; processed. This is important to avoid the bug when free + ;; variable and the function have the same name. + (push (list var new-val) binders-new) + + (when (eq letsym 'let*) + (setq env new-env) + (setq extend new-extend)))))) + ) ; end of dolist over binders (when (not (eq letsym 'let*)) ;; We can't do the cconv--remap-llv at the same place for let and @@ -464,22 +505,28 @@ places where they originally did not directly appear." ; condition-case (`(condition-case ,var ,protected-form . ,handlers) - `(condition-case ,var - ,(cconv-convert protected-form env extend) - ,@(let* ((cm (and var (member (cons (list var) form) - cconv-captured+mutated))) - (newenv - (cond (cm (cons `(,var . (car-save ,var)) env)) - ((assq var env) (cons `(,var) env)) - (t env)))) - (mapcar + (let* ((class (and var (cconv--var-classification (list var) form))) + (newenv + (cond ((eq class :captured+mutated) + (cons `(,var . (car-safe ,var)) env)) + ((assq var env) (cons `(,var) env)) + (t env))) + (msg (when (eq class :unused) + (cconv--warn-unused-msg var "variable"))) + (newprotform (cconv-convert protected-form env extend))) + `(condition-case ,var + ,(if msg + (macroexp--warn-wrap msg newprotform 'lexical) + newprotform) + ,@(mapcar (lambda (handler) `(,(car handler) ,@(let ((body (mapcar (lambda (form) (cconv-convert form newenv extend)) (cdr handler)))) - (if (not cm) body + (if (not (eq class :captured+mutated)) + body `((let ((,var (list ,var))) ,@body)))))) handlers)))) @@ -548,9 +595,6 @@ places where they originally did not directly appear." (_ (or (cdr (assq form env)) form)))) -(unless (fboundp 'byte-compile-not-lexical-var-p) - ;; Only used to test the code in non-lexbind Emacs. - (defalias 'byte-compile-not-lexical-var-p 'boundp)) (defvar byte-compile-lexical-variables) (defun cconv--analyze-use (vardata form varkind) @@ -563,29 +607,30 @@ FORM is the parent form that binds this var." (`(,_ nil nil nil nil) nil) (`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_) ,_ ,_ ,_ ,_) + ;; FIXME: Convert this warning to use `macroexp--warn-wrap' + ;; so as to give better position information and obey + ;; `byte-compile-warnings'. (byte-compile-warn - "%s `%S' not left unused" varkind var))) + "%s `%S' not left unused" varkind var)) + ((and (let (or 'let* 'let) (car form)) + `((,var) ;; (or `(,var nil) : Too many false positives: bug#47080 + t nil ,_ ,_)) + ;; FIXME: Convert this warning to use `macroexp--warn-wrap' + ;; so as to give better position information and obey + ;; `byte-compile-warnings'. + (unless (not (intern-soft var)) + (byte-compile-warn "Variable `%S' left uninitialized" var)))) (pcase vardata - (`((,var . ,_) nil ,_ ,_ nil) - ;; FIXME: This gives warnings in the wrong order, with imprecise line - ;; numbers and without function name info. - (unless (or ;; Uninterned symbols typically come from macro-expansion, so - ;; it is often non-trivial for the programmer to avoid such - ;; unused vars. - (not (intern-soft var)) - (eq ?_ (aref (symbol-name var) 0)) - ;; As a special exception, ignore "ignore". - (eq var 'ignored)) - (let ((suggestions (help-uni-confusable-suggestions (symbol-name var)))) - (byte-compile-warn "Unused lexical %s `%S'%s" - varkind var - (if suggestions (concat "\n " suggestions) ""))))) + (`(,binder nil ,_ ,_ nil) + (push (cons (cons binder form) :unused) cconv-var-classification)) ;; If it's unused, there's no point converting it into a cons-cell, even if ;; it's captured and mutated. (`(,binder ,_ t t ,_) - (push (cons binder form) cconv-captured+mutated)) + (push (cons (cons binder form) :captured+mutated) + cconv-var-classification)) (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t) - (push (cons binder form) cconv-lambda-candidates)))) + (push (cons (cons binder form) :lambda-candidate) + cconv-var-classification)))) (defun cconv--analyze-function (args body env parentform) (let* ((newvars nil) @@ -638,8 +683,7 @@ Analyze lambdas if they are suitable for lambda lifting. - ENV is an alist mapping each enclosing lexical variable to its info. I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)). This function does not return anything but instead fills the -`cconv-captured+mutated' and `cconv-lambda-candidates' variables -and updates the data stored in ENV." +`cconv-var-classification' variable and updates the data stored in ENV." (pcase form ; let special form (`(,(and (or 'let* 'let) letsym) ,binders . ,body-forms) @@ -756,7 +800,7 @@ and updates the data stored in ENV." (let ((dv (assq form env))) ; dv = declared and visible (when dv (setf (nth 1 dv) t)))))) -(define-obsolete-function-alias 'cconv-analyse-form 'cconv-analyze-form "25.1") +(define-obsolete-function-alias 'cconv-analyse-form #'cconv-analyze-form "25.1") (provide 'cconv) ;;; cconv.el ends here diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 7d760ffc57f..0494497feaf 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -89,33 +89,39 @@ Useful if new Emacs is used on B&W display.") (declare-function x-display-color-cells "xfns.c" (&optional terminal)) -(defvar chart-face-list - (if (display-color-p) - (let ((cl chart-face-color-list) - (pl chart-face-pixmap-list) - (faces ()) - nf) - (while cl - (setq nf (make-face - (intern (concat "chart-" (car cl) "-" (car pl))))) - (set-face-background nf (if (condition-case nil - (> (x-display-color-cells) 4) - (error t)) - (car cl) - "white")) - (set-face-foreground nf "black") - (if (and chart-face-use-pixmaps pl) - (condition-case nil - (set-face-background-pixmap nf (car pl)) - (error (message "Cannot set background pixmap %s" (car pl))))) - (push nf faces) - (setq cl (cdr cl) - pl (cdr pl))) - faces)) +(defvar chart-face-list #'chart--face-list "Faces used to colorize charts. +This should either be a list of faces, or a function that returns +a list of faces. + List is limited currently, which is ok since you really can't display too much in text characters anyways.") +(defun chart--face-list () + (and + (display-color-p) + (let ((cl chart-face-color-list) + (pl chart-face-pixmap-list) + (faces ()) + nf) + (while cl + (setq nf (make-face + (intern (concat "chart-" (car cl) "-" (car pl))))) + (set-face-background nf (if (condition-case nil + (> (x-display-color-cells) 4) + (error t)) + (car cl) + "white")) + (set-face-foreground nf "black") + (if (and chart-face-use-pixmaps pl) + (condition-case nil + (set-face-background-pixmap nf (car pl)) + (error (message "Cannot set background pixmap %s" (car pl))))) + (push nf faces) + (setq cl (cdr cl) + pl (cdr pl))) + faces))) + (define-derived-mode chart-mode special-mode "Chart" "Define a mode in Emacs for displaying a chart." (buffer-disable-undo) @@ -187,7 +193,7 @@ Make sure the width/height is correct." ) "Class used to display an axis which represents different named items.") -(defclass chart-sequece () +(defclass chart-sequence () ((data :initarg :data :initform nil) (name :initarg :name @@ -197,7 +203,7 @@ Make sure the width/height is correct." (defclass chart-bar (chart) ((direction :initarg :direction - :initform vertical)) + :initform 'vertical)) "Subclass for bar charts (vertical or horizontal).") (cl-defmethod chart-draw ((c chart) &optional buff) @@ -374,7 +380,10 @@ of the drawing." (let* ((data (oref c sequences)) (dir (oref c direction)) (odir (if (eq dir 'vertical) 'horizontal 'vertical)) - ) + (faces + (if (functionp chart-face-list) + (funcall chart-face-list) + chart-face-list))) (while data (if (stringp (car (oref (car data) data))) ;; skip string lists... @@ -390,10 +399,9 @@ of the drawing." (zp (if (eq dir 'vertical) (chart-translate-ypos c 0) (chart-translate-xpos c 0))) - (fc (if chart-face-list - (nth (% i (length chart-face-list)) chart-face-list) - 'default)) - ) + (fc (if faces + (nth (% i (length faces)) faces) + 'default))) (if (< dp zp) (progn (chart-draw-line dir (car rng) dp zp) @@ -583,12 +591,12 @@ SORT-PRED if desired." )) (iv (eq dir 'vertical))) (chart-add-sequence nc - (make-instance 'chart-sequece + (make-instance 'chart-sequence :data namelst :name nametitle) (if iv 'x-axis 'y-axis)) (chart-add-sequence nc - (make-instance 'chart-sequece + (make-instance 'chart-sequence :data numlst :name numtitle) (if iv 'y-axis 'x-axis)) diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index 7c2b23b4ec4..bec4ad92503 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -328,4 +328,4 @@ Returns non-nil if any false statements are found." (provide 'check-declare) -;;; check-declare.el ends here. +;;; check-declare.el ends here diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 75aefdc7ba0..00cc7777e1a 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -160,9 +160,6 @@ ;; not specifically docstring related. Would this even be useful? ;;; Code: -(defvar checkdoc-version "0.6.2" - "Release version of checkdoc you are currently running.") -(make-obsolete-variable 'checkdoc-version nil "28.1") (require 'cl-lib) (require 'help-mode) ;; for help-xref-info-regexp @@ -931,16 +928,20 @@ don't move point." ;; Don't bug out if the file is empty (or a ;; definition ends prematurely. (end-of-file))) - (`(,(or 'defun 'defvar 'defcustom 'defmacro 'defconst 'defsubst 'defadvice - 'cl-defun 'cl-defgeneric 'cl-defmethod 'cl-defmacro) + (`(,(and (pred symbolp) def + (let (and doc (guard doc)) (function-get def 'doc-string-elt))) ,(pred symbolp) ;; Require an initializer, i.e. ignore single-argument `defvar' ;; forms, which never have a doc string. ,_ . ,_) (down-list) - ;; Skip over function or macro name, symbol to be defined, and - ;; initializer or argument list. - (forward-sexp 3) + ;; Skip over function or macro name. + (forward-sexp 1) + ;; And now skip until the docstring. + (forward-sexp (1- ; We already skipped the function or macro name. + (cond + ((numberp doc) doc) + ((functionp doc) (funcall doc))))) (skip-chars-forward " \n\t") t))) @@ -1241,7 +1242,7 @@ bound to \\<checkdoc-minor-mode-map>\\[checkdoc-eval-defun] and `checkdoc-eval-c checking of documentation strings. \\{checkdoc-minor-mode-map}" - nil checkdoc-minor-mode-string nil + :lighter checkdoc-minor-mode-string :group 'checkdoc) ;;; Subst utils @@ -2130,8 +2131,8 @@ buffer, otherwise stop after the first error." (user-error "No spellchecker installed: check the variable `ispell-program-name'")) (save-excursion (skip-chars-forward "^a-zA-Z") - (let (word sym case-fold-search err word-beginning word-end) - (while (and (not err) (< (point) end)) + (let (word sym case-fold-search word-beginning word-end) ;; err + (while (and (< (point) end)) ;; (not err) (if (save-excursion (forward-char -1) (looking-at "[('`]")) ;; Skip lists describing meta-syntax, or bound variables (forward-sexp 1) @@ -2163,7 +2164,7 @@ buffer, otherwise stop after the first error." (sit-for 0) (message "Continuing...")))))))) (skip-chars-forward "^a-zA-Z")) - err)))) + nil)))) ;; err ;;; Rogue space checking engine ;; @@ -2705,6 +2706,12 @@ function called to create the messages." (custom-add-option 'emacs-lisp-mode-hook 'checkdoc-minor-mode) +;; Obsolete + +(defvar checkdoc-version "0.6.2" + "Release version of checkdoc you are currently running.") +(make-obsolete-variable 'checkdoc-version 'emacs-version "28.1") + (provide 'checkdoc) ;;; checkdoc.el ends here diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 28ce6b115a4..3840d13ecff 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -94,7 +94,7 @@ strings case-insensitively." (defun cl--mapcar-many (cl-func cl-seqs &optional acc) (if (cdr (cdr cl-seqs)) (let* ((cl-res nil) - (cl-n (apply 'min (mapcar 'length cl-seqs))) + (cl-n (apply #'min (mapcar #'length cl-seqs))) (cl-i 0) (cl-args (copy-sequence cl-seqs)) cl-p1 cl-p2) @@ -131,7 +131,7 @@ strings case-insensitively." "Map a FUNCTION across one or more SEQUENCEs, returning a sequence. TYPE is the sequence type to return. \n(fn TYPE FUNCTION SEQUENCE...)" - (let ((cl-res (apply 'cl-mapcar cl-func cl-seq cl-rest))) + (let ((cl-res (apply #'cl-mapcar cl-func cl-seq cl-rest))) (and cl-type (cl-coerce cl-res cl-type)))) ;;;###autoload @@ -190,14 +190,14 @@ the elements themselves. "Like `cl-mapcar', but nconc's together the values returned by the function. \n(fn FUNCTION SEQUENCE...)" (if cl-rest - (apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest)) + (apply #'nconc (apply #'cl-mapcar cl-func cl-seq cl-rest)) (mapcan cl-func cl-seq))) ;;;###autoload (defun cl-mapcon (cl-func cl-list &rest cl-rest) "Like `cl-maplist', but nconc's together the values returned by the function. \n(fn FUNCTION LIST...)" - (apply 'nconc (apply 'cl-maplist cl-func cl-list cl-rest))) + (apply #'nconc (apply #'cl-maplist cl-func cl-list cl-rest))) ;;;###autoload (defun cl-some (cl-pred cl-seq &rest cl-rest) @@ -236,13 +236,13 @@ non-nil value. (defun cl-notany (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is false of every element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" - (not (apply 'cl-some cl-pred cl-seq cl-rest))) + (not (apply #'cl-some cl-pred cl-seq cl-rest))) ;;;###autoload (defun cl-notevery (cl-pred cl-seq &rest cl-rest) "Return true if PREDICATE is false of some element of SEQ or SEQs. \n(fn PREDICATE SEQ...)" - (not (apply 'cl-every cl-pred cl-seq cl-rest))) + (not (apply #'cl-every cl-pred cl-seq cl-rest))) ;;;###autoload (defun cl--map-keymap-recursively (cl-func-rec cl-map &optional cl-base) @@ -693,12 +693,11 @@ PROPLIST is a list of the sort returned by `symbol-plist'. "Expand macros in FORM and insert the pretty-printed result." (declare (advertised-calling-convention (form) "27.1")) (message "Expanding...") - (let ((byte-compile-macro-environment nil)) - (setq form (macroexpand-all form)) - (message "Formatting...") - (prog1 - (cl-prettyprint form) - (message "")))) + (setq form (macroexpand-all form)) + (message "Formatting...") + (prog1 + (cl-prettyprint form) + (message ""))) ;;; Integration into the online help system. @@ -848,7 +847,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'. "\n"))) "\n")) -(defun cl--print-table (header rows) +(defun cl--print-table (header rows &optional last-slot-on-next-line) ;; FIXME: Isn't this functionality already implemented elsewhere? (let ((cols (apply #'vector (mapcar #'string-width header))) (col-space 2)) @@ -878,7 +877,11 @@ PROPLIST is a list of the sort returned by `symbol-plist'. header)) "\n") (dolist (row rows) - (insert (apply #'format format row) "\n")))))) + (insert (apply #'format format row) "\n") + (when last-slot-on-next-line + (dolist (line (string-lines (car (last row)))) + (insert " " line "\n")) + (insert "\n"))))))) (defun cl--describe-class-slots (class) "Print help description for the slots in CLASS. @@ -904,8 +907,7 @@ Outputs to the current buffer." (setq has-doc t) (substitute-command-keys doc))))) slots))) - (cl--print-table `("Name" "Type" "Default" . ,(if has-doc '("Doc"))) - slots-strings)) + (cl--print-table `("Name" "Type" "Default") slots-strings has-doc)) (insert "\n") (when (> (length cslots) 0) (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 8e36dbe4a36..4a69df15bc8 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -189,6 +189,32 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG (setf (cl--generic name) (setq generic (cl--generic-make name)))) generic)) +(defvar cl--generic-edebug-name nil) + +(defun cl--generic-edebug-remember-name (name pf &rest specs) + ;; Remember the name in `cl-defgeneric' so we can use it when building + ;; the names of its `:methods'. + (let ((cl--generic-edebug-name (car name))) + (funcall pf specs))) + +(defun cl--generic-edebug-make-name (in:method _oldname &rest quals-and-args) + ;; The name to use in Edebug for a method: use the generic + ;; function's name plus all its qualifiers and finish with + ;; its specializers. + (pcase-let* + ((basename (if in:method cl--generic-edebug-name (pop quals-and-args))) + (args (car (last quals-and-args))) + (`(,spec-args . ,_) (cl--generic-split-args args)) + (specializers (mapcar (lambda (spec-arg) + (if (eq '&context (car-safe (car spec-arg))) + spec-arg (cdr spec-arg))) + spec-args))) + (format "%s %s" + (mapconcat (lambda (sexp) (format "%s" sexp)) + (cons basename (butlast quals-and-args)) + " ") + specializers))) + ;;;###autoload (defmacro cl-defgeneric (name args &rest options-and-methods) "Create a generic function NAME. @@ -206,24 +232,22 @@ DEFAULT-BODY, if present, is used as the body of a default method. \(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest DEFAULT-BODY)" (declare (indent 2) (doc-string 3) (debug - (&define [&or name ("setf" name :name setf)] listp - lambda-doc - [&rest [&or - ("declare" &rest sexp) - (":argument-precedence-order" &rest sexp) - (&define ":method" - ;; FIXME: The `:unique' - ;; construct works around - ;; Bug#42672. We'd rather want - ;; names like those generated by - ;; `cl-defmethod', but that - ;; requires larger changes to - ;; Edebug. - :unique "cl-generic-:method@" - [&rest cl-generic-method-qualifier] - cl-generic-method-args lambda-doc - def-body)]] - def-body))) + (&define + &interpose + [&name sexp] ;Allow (setf ...) additionally to symbols. + cl--generic-edebug-remember-name + listp lambda-doc + [&rest [&or + ("declare" &rest sexp) + (":argument-precedence-order" &rest sexp) + (&define ":method" + [&name + [[&rest cl-generic--method-qualifier-p] + listp] ;Formal args + cl--generic-edebug-make-name in:method] + lambda-doc + def-body)]] + def-body))) (let* ((doc (if (stringp (car-safe options-and-methods)) (pop options-and-methods))) (declarations nil) @@ -398,10 +422,23 @@ the specializer used will be the one returned by BODY." (let ((combined-doc (buffer-string))) (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) +(defun cl-generic--method-qualifier-p (x) + (not (listp x))) + +(defun cl--defmethod-doc-pos () + "Return the index of the docstring for a `cl-defmethod'. +Presumes point is at the end of the `cl-defmethod' symbol." + (save-excursion + (let ((n 2)) + (while (and (ignore-errors (forward-sexp 1) t) + (not (eq (char-before) ?\)))) + (cl-incf n)) + n))) + ;;;###autoload (defmacro cl-defmethod (name args &rest body) "Define a new method for generic function NAME. -This it defines an implementation of NAME to use for invocations +This defines an implementation of NAME to use for invocations of specific types of arguments. ARGS is a list of dispatch arguments (see `cl-defun'), but where @@ -418,8 +455,12 @@ all methods of NAME have to use the same set of arguments for dispatch. Each dispatch argument and TYPE are specified in ARGS where the corresponding formal argument appears as (VAR TYPE) rather than just VAR. -The optional second argument QUALIFIER is a specifier that -modifies how the method is combined with other methods, including: +The optional EXTRA element, on the form `:extra STRING', allows +you to add more methods for the same specializers and qualifiers. +These are distinguished by STRING. + +The optional argument QUALIFIER is a specifier that modifies how +the method is combined with other methods, including: :before - Method will be called before the primary :after - Method will be called after the primary :around - Method will be called around everything else @@ -436,19 +477,18 @@ method to be applicable. The set of acceptable TYPEs (also called \"specializers\") is defined \(and can be extended) by the various methods of `cl-generic-generalizers'. -\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" - (declare (doc-string 3) (indent defun) +\(fn NAME [EXTRA] [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" + (declare (doc-string cl--defmethod-doc-pos) (indent defun) (debug (&define ; this means we are defining something - [&or name ("setf" name :name setf)] - ;; ^^ This is the methods symbol - [ &rest cl-generic-method-qualifier ] - ;; Multiple qualifiers are allowed. - cl-generic-method-args ; arguments + [&name [sexp ;Allow (setf ...) additionally to symbols. + [&rest cl-generic--method-qualifier-p] ;qualifiers + listp] ; arguments + cl--generic-edebug-make-name nil] lambda-doc ; documentation string def-body))) ; part to be debugged (let ((qualifiers nil)) - (while (not (listp args)) + (while (cl-generic--method-qualifier-p args) (push args qualifiers) (setq args (pop body))) (when (eq 'setf (car-safe name)) @@ -461,7 +501,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (or (not (fboundp 'byte-compile-warning-enabled-p)) (byte-compile-warning-enabled-p 'obsolete name)) (let* ((obsolete (get name 'byte-obsolete-info))) - (macroexp--warn-and-return + (macroexp-warn-and-return (macroexp--obsolete-warning name obsolete "generic function") nil))) ;; You could argue that `defmethod' modifies rather than defines the @@ -528,17 +568,17 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (cons method mt) ;; Keep the ordering; important for methods with :extra qualifiers. (mapcar (lambda (x) (if (eq x (car me)) method x)) mt))) - (let ((sym (cl--generic-name generic))) ; Actual name (for aliases). + (let ((sym (cl--generic-name generic)) ; Actual name (for aliases). + ;; FIXME: Try to avoid re-constructing a new function if the old one + ;; is still valid (e.g. still empty method cache)? + (gfun (cl--generic-make-function generic))) (unless (symbol-function sym) (defalias sym 'dummy)) ;Record definition into load-history. (cl-pushnew `(cl-defmethod . ,(cl--generic-load-hist-format (cl--generic-name generic) qualifiers 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 + (let (;; Prevent `defalias' from recording this as the definition site of ;; the generic function. current-load-list ;; BEWARE! Don't purify this function definition, since that leads @@ -1113,12 +1153,27 @@ These match if the argument is a cons cell whose car is `eql' to VAL." (cl-generic-define-generalizer cl--generic-eql-generalizer 100 (lambda (name &rest _) `(gethash ,name cl--generic-eql-used)) - (lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (list tag)))) + (lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (cdr tag)))) (cl-defmethod cl-generic-generalizers ((specializer (head eql))) "Support for (eql VAL) specializers. These match if the argument is `eql' to VAL." - (puthash (cadr specializer) specializer cl--generic-eql-used) + (let* ((form (cadr specializer)) + (val (if (or (not (symbolp form)) (macroexp-const-p form)) + (eval form t) + ;; FIXME: Compatibility with Emacs<28. For now emitting + ;; a warning would be annoying for third party packages + ;; which can't use the new form without breaking compatibility + ;; with older Emacsen, but in the future we should emit + ;; a warning. + ;; (message "Quoting obsolete `eql' form: %S" specializer) + form)) + (specializers (cdr (gethash val cl--generic-eql-used)))) + ;; The `specializers-function' needs to return all the (eql EXP) that + ;; were used for the same VALue (bug#49866). + ;; So we keep this info in `cl--generic-eql-used'. + (cl-pushnew specializer specializers :test #'equal) + (puthash val `(eql . ,specializers) cl--generic-eql-used)) (list cl--generic-eql-generalizer)) (cl--generic-prefill-dispatchers 0 (eql nil)) diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 7d0bfc88b15..c88e15d5a8b 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -27,7 +27,7 @@ ;; This package supplies a single entry point, common-lisp-indent-function, ;; which performs indentation in the preferred style for Common Lisp code. -;; It is also a suitable function for indenting Emacs lisp code. +;; It is also a suitable function for indenting Emacs Lisp code. ;; ;; To enable it: ;; diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 3bf3fd21ded..317a4c62309 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -140,7 +140,7 @@ to an element already in the list stored in PLACE. \n(fn X PLACE [KEYWORD VALUE]...)" (declare (debug (form place &rest - &or [[&or ":test" ":test-not" ":key"] function-form] + &or [[&or ":test" ":test-not" ":key"] form] [keywordp form]))) (if (symbolp place) (if (null keys) @@ -232,13 +232,8 @@ one value. ;;; Declarations. -(defvar cl--compiling-file nil) -(defun cl--compiling-file () - (or cl--compiling-file - (and (boundp 'byte-compile--outbuffer) - (bufferp (symbol-value 'byte-compile--outbuffer)) - (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) - " *Compiler Output*")))) +(define-obsolete-function-alias 'cl--compiling-file + #'macroexp-compiling-p "28.1") (defvar cl--proclaims-deferred nil) @@ -253,7 +248,7 @@ one value. Puts `(cl-eval-when (compile load eval) ...)' around the declarations so that they are registered at compile-time as well as run-time." (let ((body (mapcar (lambda (x) `(cl-proclaim ',x)) specs))) - (if (cl--compiling-file) `(cl-eval-when (compile load eval) ,@body) + (if (macroexp-compiling-p) `(cl-eval-when (compile load eval) ,@body) `(progn ,@body)))) ; Avoid loading cl-macs.el for cl-eval-when. @@ -520,111 +515,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) -;; were autoloaded from cl-macs.el. But now that setf, push, and pop are in -;; core Elisp, they need to either be right here or be autoloaded via -;; cl-loaddefs.el, which is more trouble than it is worth. - -;; Some more Emacs-related place types. -(gv-define-simple-setter buffer-file-name set-visited-file-name t) -(gv-define-setter buffer-modified-p (flag &optional buf) - (macroexp-let2 nil buffer `(or ,buf (current-buffer)) - `(with-current-buffer ,buffer - (set-buffer-modified-p ,flag)))) -(gv-define-simple-setter buffer-name rename-buffer t) -(gv-define-setter buffer-string (store) - `(insert (prog1 ,store (erase-buffer)))) -(gv-define-simple-setter buffer-substring cl--set-buffer-substring) -(gv-define-simple-setter current-buffer set-buffer) -(gv-define-simple-setter current-column move-to-column t) -(gv-define-simple-setter current-global-map use-global-map t) -(gv-define-setter current-input-mode (store) - `(progn (apply #'set-input-mode ,store) ,store)) -(gv-define-simple-setter current-local-map use-local-map t) -(gv-define-simple-setter current-window-configuration - set-window-configuration t) -(gv-define-simple-setter default-file-modes set-default-file-modes t) -(gv-define-simple-setter documentation-property put) -(gv-define-setter face-background (x f &optional s) - `(set-face-background ,f ,x ,s)) -(gv-define-setter face-background-pixmap (x f &optional s) - `(set-face-background-pixmap ,f ,x ,s)) -(gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s)) -(gv-define-setter face-foreground (x f &optional s) - `(set-face-foreground ,f ,x ,s)) -(gv-define-setter face-underline-p (x f &optional s) - `(set-face-underline ,f ,x ,s)) -(gv-define-simple-setter file-modes set-file-modes t) -(gv-define-setter frame-height (x &optional frame) - `(set-frame-height (or ,frame (selected-frame)) ,x)) -(gv-define-simple-setter frame-parameters modify-frame-parameters t) -(gv-define-simple-setter frame-visible-p cl--set-frame-visible-p) -(gv-define-setter frame-width (x &optional frame) - `(set-frame-width (or ,frame (selected-frame)) ,x)) -(gv-define-simple-setter getenv setenv t) -(gv-define-simple-setter get-register set-register) -(gv-define-simple-setter global-key-binding global-set-key) -(gv-define-simple-setter local-key-binding local-set-key) -(gv-define-simple-setter mark set-mark t) -(gv-define-simple-setter mark-marker set-mark t) -(gv-define-simple-setter marker-position set-marker t) -(gv-define-setter mouse-position (store scr) - `(set-mouse-position ,scr (car ,store) (cadr ,store) - (cddr ,store))) -(gv-define-simple-setter point goto-char) -(gv-define-simple-setter point-marker goto-char t) -(gv-define-setter point-max (store) - `(progn (narrow-to-region (point-min) ,store) ,store)) -(gv-define-setter point-min (store) - `(progn (narrow-to-region ,store (point-max)) ,store)) -(gv-define-setter read-mouse-position (store scr) - `(set-mouse-position ,scr (car ,store) (cdr ,store))) -(gv-define-simple-setter screen-height set-screen-height t) -(gv-define-simple-setter screen-width set-screen-width t) -(gv-define-simple-setter selected-window select-window) -(gv-define-simple-setter selected-screen select-screen) -(gv-define-simple-setter selected-frame select-frame) -(gv-define-simple-setter standard-case-table set-standard-case-table) -(gv-define-simple-setter syntax-table set-syntax-table) -(gv-define-simple-setter visited-file-modtime set-visited-file-modtime t) -(gv-define-setter window-height (store) - `(progn (enlarge-window (- ,store (window-height))) ,store)) -(gv-define-setter window-width (store) - `(progn (enlarge-window (- ,store (window-width)) t) ,store)) -(gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t) - -;; More complex setf-methods. - -;; This is a hack that allows (setf (eq a 7) B) to mean either -;; (setq a 7) or (setq a nil) depending on whether B is nil or not. -;; This is useful when you have control over the PLACE but not over -;; the VALUE, as is the case in define-minor-mode's :variable. -;; It turned out that :variable needed more flexibility anyway, so -;; this doesn't seem too useful now. -(gv-define-expander eq - (lambda (do place val) - (gv-letplace (getter setter) place - (macroexp-let2 nil val val - (funcall do `(eq ,getter ,val) - (lambda (v) - `(cond - (,v ,(funcall setter val)) - ((eq ,getter ,val) ,(funcall setter `(not ,val)))))))))) - -(gv-define-expander substring - (lambda (do place from &optional to) - (gv-letplace (getter setter) place - (macroexp-let2* nil ((start from) (end to)) - (funcall do `(substring ,getter ,start ,end) - (lambda (v) - (macroexp-let2 nil v v - `(progn - ,(funcall setter `(cl--set-substring - ,getter ,start ,end ,v)) - ,v)))))))) - ;;; Miscellaneous. (provide 'cl-lib) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c2bf02ccece..4ef1948b0fe 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -186,14 +186,14 @@ The name is made by appending a number to PREFIX, default \"T\"." ;;; Program structure. -(def-edebug-spec cl-declarations - (&rest ("cl-declare" &rest sexp))) +(def-edebug-elem-spec 'cl-declarations + '(&rest ("cl-declare" &rest sexp))) -(def-edebug-spec cl-declarations-or-string - (&or lambda-doc cl-declarations)) +(def-edebug-elem-spec 'cl-declarations-or-string + '(lambda-doc &or ("declare" def-declarations) cl-declarations)) -(def-edebug-spec cl-lambda-list - (([&rest cl-lambda-arg] +(def-edebug-elem-spec 'cl-lambda-list + '(([&rest cl-lambda-arg] [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] [&optional ["&rest" cl-lambda-arg]] [&optional ["&key" [cl-&key-arg &rest cl-&key-arg] @@ -202,27 +202,27 @@ The name is made by appending a number to PREFIX, default \"T\"." &or (cl-lambda-arg &optional def-form) arg]] . [&or arg nil]))) -(def-edebug-spec cl-&optional-arg - (&or (cl-lambda-arg &optional def-form arg) arg)) +(def-edebug-elem-spec 'cl-&optional-arg + '(&or (cl-lambda-arg &optional def-form arg) arg)) -(def-edebug-spec cl-&key-arg - (&or ([&or (symbolp cl-lambda-arg) arg] &optional def-form arg) arg)) +(def-edebug-elem-spec 'cl-&key-arg + '(&or ([&or (symbolp cl-lambda-arg) arg] &optional def-form arg) arg)) -(def-edebug-spec cl-lambda-arg - (&or arg cl-lambda-list1)) +(def-edebug-elem-spec 'cl-lambda-arg + '(&or arg cl-lambda-list1)) -(def-edebug-spec cl-lambda-list1 - (([&optional ["&whole" arg]] ;; only allowed at lower levels - [&rest cl-lambda-arg] - [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] - [&optional ["&rest" cl-lambda-arg]] - [&optional ["&key" cl-&key-arg &rest cl-&key-arg - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (cl-lambda-arg &optional def-form) arg]] - . [&or arg nil]))) +(def-edebug-elem-spec 'cl-lambda-list1 + '(([&optional ["&whole" arg]] ;; only allowed at lower levels + [&rest cl-lambda-arg] + [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] + [&optional ["&rest" cl-lambda-arg]] + [&optional ["&key" cl-&key-arg &rest cl-&key-arg + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (cl-lambda-arg &optional def-form) arg]] + . [&or arg nil]))) -(def-edebug-spec cl-type-spec sexp) +(def-edebug-elem-spec 'cl-type-spec '(sexp)) (defconst cl--lambda-list-keywords '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) @@ -358,7 +358,7 @@ more details. \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug ;; Same as defun but use cl-lambda-list. - (&define [&or name ("setf" :name setf name)] + (&define [&name sexp] ;Allow (setf ...) additionally to symbols. cl-lambda-list cl-declarations-or-string [&optional ("interactive" interactive)] @@ -376,7 +376,7 @@ 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)] + (&define [&name sexp] ;Allow (setf ...) additionally to symbols. cl-lambda-list cl-declarations-or-string [&optional ("interactive" interactive)] @@ -390,39 +390,39 @@ and BODY is implicitly surrounded by (cl-block NAME ...). ;; Note that &environment is only allowed as first or last items in the ;; top level list. -(def-edebug-spec cl-macro-list - (([&optional "&environment" arg] - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (cl-macro-arg &optional def-form) arg]] - [&optional "&environment" arg] - ))) - -(def-edebug-spec cl-macro-arg - (&or arg cl-macro-list1)) - -(def-edebug-spec cl-macro-list1 - (([&optional "&whole" arg] ;; only allowed at lower levels - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (cl-macro-arg &optional def-form) arg]] - . [&or arg nil]))) +(def-edebug-elem-spec 'cl-macro-list + '(([&optional "&environment" arg] + [&rest cl-macro-arg] + [&optional ["&optional" &rest + &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] + [&optional [[&or "&rest" "&body"] cl-macro-arg]] + [&optional ["&key" [&rest + [&or ([&or (symbolp cl-macro-arg) arg] + &optional def-form cl-macro-arg) + arg]] + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (cl-macro-arg &optional def-form) arg]] + [&optional "&environment" arg] + ))) + +(def-edebug-elem-spec 'cl-macro-arg + '(&or arg cl-macro-list1)) + +(def-edebug-elem-spec 'cl-macro-list1 + '(([&optional "&whole" arg] ;; only allowed at lower levels + [&rest cl-macro-arg] + [&optional ["&optional" &rest + &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] + [&optional [[&or "&rest" "&body"] cl-macro-arg]] + [&optional ["&key" [&rest + [&or ([&or (symbolp cl-macro-arg) arg] + &optional def-form cl-macro-arg) + arg]] + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (cl-macro-arg &optional def-form) arg]] + . [&or arg nil]))) ;;;###autoload (defmacro cl-defmacro (name args &rest body) @@ -452,19 +452,19 @@ more details. (indent 2)) `(defmacro ,name ,@(cl--transform-lambda (cons args body) name))) -(def-edebug-spec cl-lambda-expr - (&define ("lambda" cl-lambda-list - cl-declarations-or-string - [&optional ("interactive" interactive)] - def-body))) +(def-edebug-elem-spec 'cl-lambda-expr + '(&define ("lambda" cl-lambda-list + cl-declarations-or-string + [&optional ("interactive" interactive)] + def-body))) ;; Redefine function-form to also match cl-function -(def-edebug-spec function-form +(def-edebug-elem-spec 'function-form ;; form at the end could also handle "function", ;; but recognize it specially to avoid wrapping function forms. - (&or ([&or "quote" "function"] &or symbolp lambda-expr) - ("cl-function" cl-function) - form)) + '(&or ([&or "quote" "function"] &or symbolp lambda-expr) + ("cl-function" cl-function) + form)) ;;;###autoload (defmacro cl-function (func) @@ -545,7 +545,7 @@ its argument list allows full Common Lisp conventions." (let ((p (memq '&body args))) (if p (setcar p '&rest))) (if (memq '&environment args) (error "&environment used incorrectly")) (let ((restarg (memq '&rest args)) - (safety (if (cl--compiling-file) cl--optimize-safety 3)) + (safety (if (macroexp-compiling-p) cl--optimize-safety 3)) (keys t) (laterarg nil) (exactarg nil) minarg) (or num (setq num 0)) @@ -565,7 +565,7 @@ its argument list allows full Common Lisp conventions." ,(length (cl-ldiff args p))) exactarg (not (eq args p))))) (while (and args (not (memq (car args) cl--lambda-list-keywords))) - (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) + (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car-safe) restarg))) (cl--do-arglist (pop args) @@ -709,7 +709,7 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. \(fn (WHEN...) BODY...)" (declare (indent 1) (debug (sexp body))) - (if (and (fboundp 'cl--compiling-file) (cl--compiling-file) + (if (and (macroexp-compiling-p) (not cl--not-toplevel) (not (boundp 'for-effect))) ;Horrible kludge. (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) (cl--not-toplevel t)) @@ -723,7 +723,7 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. (defun cl--compile-time-too (form) (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler)) (setq form (macroexpand - form (cons '(cl-eval-when) byte-compile-macro-environment)))) + form (cons '(cl-eval-when) macroexpand-all-environment)))) (cond ((eq (car-safe form) 'progn) (cons 'progn (mapcar #'cl--compile-time-too (cdr form)))) ((eq (car-safe form) 'cl-eval-when) @@ -738,7 +738,7 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. "Like `progn', but evaluates the body at load time. The result of the body appears to the compiler as a quoted constant." (declare (debug (form &optional sexp))) - (if (cl--compiling-file) + (if (macroexp-compiling-p) (let* ((temp (cl-gentemp "--cl-load-time--")) (set `(setq ,temp ,form))) (if (and (fboundp 'byte-compile-file-form-defmumble) @@ -941,7 +941,8 @@ For more details, see Info node `(cl)Loop Facility'. "above" "below" "by" "in" "on" "=" "across" "repeat" "while" "until" "always" "never" "thereis" "collect" "append" "nconc" "sum" - "count" "maximize" "minimize" "if" "unless" + "count" "maximize" "minimize" + "if" "when" "unless" "return"] form] ["using" (symbolp symbolp)] @@ -1051,20 +1052,20 @@ For more details, see Info node `(cl)Loop Facility'. ;; [&rest loop-clause] ;; )) -;; (def-edebug-spec loop-with -;; ("with" loop-var +;; (def-edebug-elem-spec 'loop-with +;; '("with" loop-var ;; loop-type-spec ;; [&optional ["=" form]] ;; &rest ["and" loop-var ;; loop-type-spec ;; [&optional ["=" form]]])) -;; (def-edebug-spec loop-for-as -;; ([&or "for" "as"] loop-for-as-subclause +;; (def-edebug-elem-spec 'loop-for-as +;; '([&or "for" "as"] loop-for-as-subclause ;; &rest ["and" loop-for-as-subclause])) -;; (def-edebug-spec loop-for-as-subclause -;; (loop-var +;; (def-edebug-elem-spec 'loop-for-as-subclause +;; '(loop-var ;; loop-type-spec ;; &or ;; [[&or "in" "on" "in-ref" "across-ref"] @@ -1124,19 +1125,19 @@ For more details, see Info node `(cl)Loop Facility'. ;; [&optional ["by" form]] ;; ])) -;; (def-edebug-spec loop-initial-final -;; (&or ["initially" +;; (def-edebug-elem-spec 'loop-initial-final +;; '(&or ["initially" ;; ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this. ;; &rest loop-non-atomic-expr] ;; ["finally" &or ;; [[&optional &or "do" "doing"] &rest loop-non-atomic-expr] ;; ["return" form]])) -;; (def-edebug-spec loop-and-clause -;; (loop-clause &rest ["and" loop-clause])) +;; (def-edebug-elem-spec 'loop-and-clause +;; '(loop-clause &rest ["and" loop-clause])) -;; (def-edebug-spec loop-clause -;; (&or +;; (def-edebug-elem-spec 'loop-clause +;; '(&or ;; [[&or "while" "until" "always" "never" "thereis"] form] ;; [[&or "collect" "collecting" @@ -1163,10 +1164,10 @@ For more details, see Info node `(cl)Loop Facility'. ;; loop-initial-final ;; )) -;; (def-edebug-spec loop-non-atomic-expr -;; ([¬ atom] form)) +;; (def-edebug-elem-spec 'loop-non-atomic-expr +;; '([¬ atom] form)) -;; (def-edebug-spec loop-var +;; (def-edebug-elem-spec 'loop-var ;; ;; The symbolp must be last alternative to recognize e.g. (a b . c) ;; ;; loop-var => ;; ;; (loop-var . [&or nil loop-var]) @@ -1175,13 +1176,13 @@ For more details, see Info node `(cl)Loop Facility'. ;; ;; (symbolp . (symbolp . [&or nil loop-var])) ;; ;; (symbolp . (symbolp . loop-var)) ;; ;; (symbolp . (symbolp . symbolp)) == (symbolp symbolp . symbolp) -;; (&or (loop-var . [&or nil loop-var]) [gate symbolp])) +;; '(&or (loop-var . [&or nil loop-var]) [gate symbolp])) -;; (def-edebug-spec loop-type-spec -;; (&optional ["of-type" loop-d-type-spec])) +;; (def-edebug-elem-spec 'loop-type-spec +;; '(&optional ["of-type" loop-d-type-spec])) -;; (def-edebug-spec loop-d-type-spec -;; (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) +;; (def-edebug-elem-spec 'loop-d-type-spec +;; '(&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) (defun cl--parse-loop-clause () ; uses loop-* (let ((word (pop cl--loop-args)) @@ -1924,7 +1925,8 @@ from OBARRAY. \(fn (VAR [OBARRAY [RESULT]]) BODY...)" (declare (indent 1) - (debug ((symbolp &optional form form) cl-declarations body))) + (debug ((symbolp &optional form form) cl-declarations + def-body))) ;; Apparently this doesn't have an implicit block. `(cl-block nil (let (,(car spec)) @@ -1964,7 +1966,7 @@ Each symbol in the first list is bound to the corresponding value in the second list (or to nil if VALUES is shorter than SYMBOLS); then the BODY forms are executed and their result is returned. This is much like a `let' form, except that the list of symbols can be computed at run-time." - (declare (indent 2) (debug (form form body))) + (declare (indent 2) (debug (form form def-body))) (let ((bodyfun (make-symbol "body")) (binds (make-symbol "binds")) (syms (make-symbol "syms")) @@ -1976,7 +1978,8 @@ a `let' form, except that the list of symbols can be computed at run-time." (,binds ())) (while ,syms (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds)) - (eval (list 'let ,binds (list 'funcall (list 'quote ,bodyfun)))))))) + (eval (list 'let (nreverse ,binds) + (list 'funcall (list 'quote ,bodyfun)))))))) (defconst cl--labels-magic (make-symbol "cl--labels-magic")) @@ -2016,8 +2019,9 @@ info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) - (debug ((&rest [&or (&define name :unique "cl-flet@" function-form) - (&define name :unique "cl-flet@" + (debug ((&rest [&or (symbolp form) + (&define [&name symbolp "@cl-flet@"] + [&name [] gensym] ;Make it unique! cl-lambda-list cl-declarations-or-string [&optional ("interactive" interactive)] @@ -2067,6 +2071,8 @@ Like `cl-flet' but the definitions can refer to previous ones. ;; even handle mutually recursive functions. (letrec ((done nil) ;; Non-nil if some TCO happened. + ;; This var always holds the value `nil' until (just before) we + ;; exit the loop. (retvar (make-symbol "retval")) (ofargs (mapcar (lambda (s) (if (memq s cl--lambda-list-keywords) s (make-symbol (symbol-name s)))) @@ -2099,6 +2105,12 @@ Like `cl-flet' but the definitions can refer to previous ones. (`(progn . ,exps) `(progn . ,(funcall opt-exps exps))) (`(if ,cond ,then . ,else) `(if ,cond ,(funcall opt then) . ,(funcall opt-exps else))) + (`(and . ,exps) `(and . ,(funcall opt-exps exps))) + (`(or ,arg) (funcall opt arg)) + (`(or ,arg . ,args) + (let ((val (make-symbol "val"))) + `(let ((,val ,arg)) + (if ,val ,(funcall opt val) ,(funcall opt `(or . ,args)))))) (`(cond . ,conds) (let ((cs '())) (while conds @@ -2108,14 +2120,18 @@ Like `cl-flet' but the definitions can refer to previous ones. ;; This returns the value of `exp' but it's ;; only in tail position if it's the ;; last condition. + ;; Note: This may set the var before we + ;; actually exit the loop, but luckily it's + ;; only the case if we set the var to nil, + ;; so it does preserve the invariant that + ;; the var is nil until we exit the loop. `((setq ,retvar ,exp) nil) `(,(funcall opt exp))) cs)) (exps (push (funcall opt-exps exps) cs)))) - (if (eq t (caar cs)) - `(cond . ,(nreverse cs)) - `(cond ,@(nreverse cs) (t (setq ,retvar nil)))))) + ;; No need to set `retvar' to return nil. + `(cond . ,(nreverse cs)))) ((and `(,(or 'let 'let*) ,bindings . ,exps) (guard ;; Note: it's OK for this `let' to shadow any @@ -2127,8 +2143,17 @@ Like `cl-flet' but the definitions can refer to previous ones. ;; tail-called any more. (not (memq var shadowings))))) `(,(car exp) ,bindings . ,(funcall opt-exps exps))) - (_ - `(progn (setq ,retvar ,exp) nil)))))) + ((and `(condition-case ,err-var ,bodyform . ,handlers) + (guard (not (eq err-var var)))) + `(condition-case ,err-var + ,(if (assq :success handlers) + bodyform + `(progn (setq ,retvar ,bodyform) nil)) + . ,(mapcar (lambda (h) + (cons (car h) (funcall opt-exps (cdr h)))) + handlers))) + ('nil nil) ;No need to set `retvar' to return nil. + (_ `(progn (setq ,retvar ,exp) nil)))))) (let ((optimized-body (funcall opt-exps body))) (if (not done) @@ -2192,6 +2217,20 @@ details. (macroexp-progn body) newenv))))) +(defvar edebug-lexical-macro-ctx) + +(defun cl--edebug-macrolet-interposer (bindings pf &rest specs) + ;; (cl-assert (null (cdr bindings))) + (setq bindings (car bindings)) + (let ((edebug-lexical-macro-ctx + (nconc (mapcar (lambda (binding) + (cons (car binding) + (when (eq 'declare (car-safe (nth 2 binding))) + (nth 1 (assq 'debug (cdr (nth 2 binding))))))) + bindings) + edebug-lexical-macro-ctx))) + (funcall pf specs))) + ;; The following ought to have a better definition for use with newer ;; byte compilers. ;;;###autoload @@ -2201,7 +2240,13 @@ This is like `cl-flet', but for macros instead of functions. \(fn ((NAME ARGLIST BODY...) ...) FORM...)" (declare (indent 1) - (debug (cl-macrolet-expr))) + (debug (&interpose (&rest (&define [&name symbolp "@cl-macrolet@"] + [&name [] gensym] ;Make it unique! + cl-macro-list + cl-declarations-or-string + def-body)) + cl--edebug-macrolet-interposer + cl-declarations body))) (if (cdr bindings) `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body)) (if (null bindings) (macroexp-progn body) @@ -2254,7 +2299,7 @@ of `cl-symbol-macrolet' to additionally expand symbol macros." ;; on this behavior (haven't found any yet). ;; Such code should explicitly use `cl-letf' instead, I think. ;; - ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare)) + ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) pcase--dontcare)) ;; (let ((letf nil) (found nil) (nbs ())) ;; (dolist (binding bindings) ;; (let* ((var (if (symbolp binding) binding (car binding))) @@ -2277,7 +2322,7 @@ of `cl-symbol-macrolet' to additionally expand symbol macros." ;; The behavior of CL made sense in a dynamically scoped ;; language, but nowadays, lexical scoping semantics is more often ;; expected. - (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) dontcare)) + (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) pcase--dontcare)) (let ((nbs ()) (found nil)) (dolist (binding bindings) (let* ((var (if (symbolp binding) binding (car binding))) @@ -2372,7 +2417,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (append bindings venv)) macroexpand-all-environment)))) (if malformed-bindings - (macroexp--warn-and-return + (macroexp-warn-and-return (format-message "Malformed `cl-symbol-macrolet' binding(s): %S" (nreverse malformed-bindings)) expansion) @@ -2434,7 +2479,15 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (defmacro cl-the (type form) "Return FORM. If type-checking is enabled, assert that it is of TYPE." (declare (indent 1) (debug (cl-type-spec form))) - (if (not (or (not (cl--compiling-file)) + ;; When native compiling possibly add the appropriate type hint. + (when (and (boundp 'byte-native-compiling) + byte-native-compiling) + (setf form + (cl-case type + (fixnum `(comp-hint-fixnum ,form)) + (cons `(comp-hint-cons ,form)) + (otherwise form)))) + (if (not (or (not (macroexp-compiling-p)) (< cl--optimize-speed 3) (= cl--optimize-safety 3))) form @@ -2444,6 +2497,28 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (list ',type ,temp ',form))) ,temp)))) +;;;###autoload +(or (assq 'cl-optimize defun-declarations-alist) + (let ((x (list 'cl-optimize #'cl--optimize))) + (push x macro-declarations-alist) + (push x defun-declarations-alist))) + +(defun cl--optimize (f _args &rest qualities) + "Serve 'cl-optimize' in function declarations. +Example: +(defun foo (x) + (declare (cl-optimize (speed 3) (safety 0))) + x)" + ;; FIXME this should make use of `cl--declare-stack' but I suspect + ;; this mechanism should be reviewed first. + (cl-loop for (qly val) in qualities + do (cl-ecase qly + (speed + (setf cl--optimize-speed val) + (byte-run--set-speed f nil val)) + (safety + (setf cl--optimize-safety val))))) + (defvar cl--proclaim-history t) ; for future compilers (defvar cl--declare-stack t) ; for future compilers @@ -2460,12 +2535,12 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). '(nil byte-compile-inline-expand)) (error "%s already has a byte-optimizer, can't make it inline" (car spec))) - (put (car spec) 'byte-optimizer 'byte-compile-inline-expand))) + (put (car spec) 'byte-optimizer #'byte-compile-inline-expand))) ((eq (car-safe spec) 'notinline) (while (setq spec (cdr spec)) (if (eq (get (car spec) 'byte-optimizer) - 'byte-compile-inline-expand) + #'byte-compile-inline-expand) (put (car spec) 'byte-optimizer nil)))) ((eq (car-safe spec) 'optimize) @@ -2501,7 +2576,7 @@ For instance will turn off byte-compile warnings in the function. See Info node `(cl)Declarations' for details." - (if (cl--compiling-file) + (if (macroexp-compiling-p) (while specs (if (listp cl--declare-stack) (push (car specs) cl--declare-stack)) (cl--do-proclaim (pop specs) nil))) @@ -2838,7 +2913,7 @@ Supported keywords for slots are: (copier (intern (format "copy-%s" name))) (predicate (intern (format "%s-p" name))) (print-func nil) (print-auto nil) - (safety (if (cl--compiling-file) cl--optimize-safety 3)) + (safety (if (macroexp-compiling-p) cl--optimize-safety 3)) (include nil) ;; There are 4 types of structs: ;; - `vector' type: means we should use a vector, which can come @@ -3011,7 +3086,7 @@ Supported keywords for slots are: forms) (when (cl-oddp (length desc)) (push - (macroexp--warn-and-return + (macroexp-warn-and-return (format "Missing value for option `%S' of slot `%s' in struct %s!" (car (last desc)) slot name) 'nil) @@ -3020,7 +3095,7 @@ Supported keywords for slots are: (not (keywordp (car desc)))) (let ((kw (car defaults))) (push - (macroexp--warn-and-return + (macroexp-warn-and-return (format " I'll take `%s' to be an option rather than a default value." kw) 'nil) @@ -3201,6 +3276,13 @@ STRUCT-TYPE is a symbol naming a struct type. Return `record', (declare (side-effect-free t) (pure t)) (cl--struct-class-type (cl--struct-get-class struct-type))) +(defun cl--alist-to-plist (alist) + (let ((res '())) + (dolist (x alist) + (push (car x) res) + (push (cdr x) res)) + (nreverse res))) + (defun cl-struct-slot-info (struct-type) "Return a list of slot names of struct STRUCT-TYPE. Each entry is a list (SLOT-NAME . OPTS), where SLOT-NAME is a @@ -3218,7 +3300,7 @@ slots skipped by :initial-offset may appear in the list." ,(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)) + ,@(cl--alist-to-plist (cl--slot-descriptor-props slot))) descs))) (nreverse descs))) @@ -3236,29 +3318,30 @@ does not contain SLOT-NAME." (signal 'cl-struct-unknown-slot (list struct-type slot-name)))) (defvar byte-compile-function-environment) -(defvar byte-compile-macro-environment) (defun cl--macroexp-fboundp (sym) "Return non-nil if SYM will be bound when we run the code. Of course, we really can't know that for sure, so it's just a heuristic." (or (fboundp sym) - (and (cl--compiling-file) + (and (macroexp-compiling-p) (or (cdr (assq sym byte-compile-function-environment)) - (cdr (assq sym byte-compile-macro-environment)))))) + (cdr (assq sym macroexpand-all-environment)))))) (pcase-dolist (`(,type . ,pred) ;; Mostly kept in alphabetical order. '((array . arrayp) (atom . atom) (base-char . characterp) + (bignum . bignump) (boolean . booleanp) (bool-vector . bool-vector-p) (buffer . bufferp) (character . natnump) (char-table . char-table-p) + (command . commandp) (hash-table . hash-table-p) (cons . consp) - (fixnum . integerp) + (fixnum . fixnump) (float . floatp) (function . functionp) (integer . integerp) @@ -3338,7 +3421,7 @@ Of course, we really can't know that for sure, so it's just a heuristic." "Verify that FORM is of type TYPE; signal an error if not. STRING is an optional description of the desired type." (declare (debug (place cl-type-spec &optional stringp))) - (and (or (not (cl--compiling-file)) + (and (or (not (macroexp-compiling-p)) (< cl--optimize-speed 3) (= cl--optimize-safety 3)) (macroexp-let2 macroexp-copyable-p temp form `(progn (or (cl-typep ,temp ',type) @@ -3358,7 +3441,7 @@ Other args STRING and ARGS... are arguments to be passed to `error'. They are not evaluated unless the assertion fails. If STRING is omitted, a default message listing FORM itself is used." (declare (debug (form &rest form))) - (and (or (not (cl--compiling-file)) + (and (or (not (macroexp-compiling-p)) (< cl--optimize-speed 3) (= cl--optimize-safety 3)) (let ((sargs (and show-args (delq nil (mapcar (lambda (x) @@ -3514,6 +3597,8 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body))))) (cl-deftype extended-char () '(and character (not base-char))) +;; Define fixnum so `cl-typep' recognize it and the type check emitted +;; by `cl-the' is effective. ;;; Additional functions that we can now define because we've defined ;;; `cl-defsubst' and `cl-typep'. @@ -3538,6 +3623,14 @@ STRUCT and SLOT-NAME are symbols. INST is a structure instance." "use `with-eval-after-load' instead." "28.1") (run-hooks 'cl-macs-load-hook) +;;; Pcase type pattern. + +;;;###autoload +(pcase-defmacro cl-type (type) + "Pcase pattern that matches objects of TYPE. +TYPE is a type descriptor as accepted by `cl-typep', which see." + `(pred (pcase--flip cl-typep ',type))) + ;; Local variables: ;; generated-autoload-file: "cl-loaddefs.el" ;; End: diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 7365e23186a..ef60b266f9e 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -124,12 +124,11 @@ supertypes from the most specific to least specific.") (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--plist-to-alist (plist) + (let ((res '())) + (while plist + (push (cons (pop plist) (pop plist)) res)) + (nreverse res))) (defun cl--struct-register-child (parent tag) ;; Can't use (cl-typep parent 'cl-structure-class) at this stage @@ -164,12 +163,14 @@ supertypes from the most specific to least specific.") (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))) + (let* ((props (cl--plist-to-alist (cddr slot))) + (typep (assq :type props)) + (type (if (null typep) t + (setq props (delq typep props)) + (cdr typep)))) (aset v i (cl--make-slot-desc (car slot) (nth 1 slot) - type (cl--plist-remove props typep)))) + type props))) (puthash (car slot) (+ i offset) index-table) (cl-incf i)) v)) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el new file mode 100644 index 00000000000..3c5578217aa --- /dev/null +++ b/lisp/emacs-lisp/comp-cstr.el @@ -0,0 +1,1197 @@ +;;; comp-cstr.el --- native compiler constraint library -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. + +;; Author: Andrea Corallo <akrl@sdf.com> +;; Keywords: lisp +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Constraint library in use by the native compiler. + +;; In LIMPLE each non immediate value is represented by a `comp-mvar'. +;; The part concerning the set of all values the `comp-mvar' can +;; assume is described into its constraint `comp-cstr'. Each +;; constraint consists in a triplet: type-set, value-set, range-set. +;; This file provide set operations between constraints (union +;; intersection and negation) plus routines to convert from and to a +;; CL like type specifier. + +;;; Code: + +(require 'cl-lib) + +(defconst comp--typeof-types (mapcar (lambda (x) + (append x '(t))) + cl--typeof-types) + ;; TODO can we just add t in `cl--typeof-types'? + "Like `cl--typeof-types' but with t as common supertype.") + +(defconst comp--all-builtin-types + (append cl--all-builtin-types '(t)) + "Likewise like `cl--all-builtin-types' but with t as common supertype.") + +(cl-defstruct (comp-cstr (:constructor comp-type-to-cstr + (type &aux + (null (eq type 'null)) + (integer (eq type 'integer)) + (typeset (if (or null integer) + nil + (list type))) + (valset (when null + '(nil))) + (range (when integer + '((- . +)))))) + (:constructor comp-value-to-cstr + (value &aux + (integer (integerp value)) + (valset (unless integer + (list value))) + (range (when integer + `((,value . ,value)))) + (typeset ()))) + (:constructor comp-irange-to-cstr + (irange &aux + (range (list irange)) + (typeset ()))) + (:copier comp-cstr-shallow-copy)) + "Internal representation of a type/value constraint." + (typeset '(t) :type list + :documentation "List of possible types the mvar can assume. +Each element cannot be a subtype of any other element of this slot.") + (valset () :type list + :documentation "List of possible values the mvar can assume. +Integer values are handled in the `range' slot.") + (range () :type list + :documentation "Integer interval.") + (neg nil :type boolean + :documentation "Non-nil if the constraint is negated")) + +(cl-defstruct comp-cstr-f + "Internal constraint representation for a function." + (args () :type list + :documentation "List of `comp-cstr' for its arguments.") + (ret nil :type (or comp-cstr comp-cstr-f) + :documentation "Returned value.")) + +(cl-defstruct comp-cstr-ctxt + (union-typesets-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-union-typesets'.") + ;; TODO we should be able to just cons hash this. + (common-supertype-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-common-supertype'.") + (subtype-p-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-subtype-p-mem'.") + (union-1-mem-no-range (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-cstr-union-1'.") + (union-1-mem-range (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`comp-cstr-union-1'.") + (intersection-mem (make-hash-table :test #'equal) :type hash-table + :documentation "Serve memoization for +`intersection-mem'.")) + +(defmacro with-comp-cstr-accessors (&rest body) + "Define some quick accessor to reduce code vergosity in BODY." + (declare (debug (form body)) + (indent defun)) + `(cl-macrolet ((typeset (x) + `(comp-cstr-typeset ,x)) + (valset (x) + `(comp-cstr-valset ,x)) + (range (x) + `(comp-cstr-range ,x)) + (neg (x) + `(comp-cstr-neg ,x))) + ,@body)) + +(defun comp-cstr-copy (cstr) + "Return a deep copy of CSTR." + (with-comp-cstr-accessors + (make-comp-cstr :typeset (copy-sequence (typeset cstr)) + :valset (copy-sequence (valset cstr)) + :range (copy-tree (range cstr)) + :neg (neg cstr)))) + +(defsubst comp-cstr-empty-p (cstr) + "Return t if CSTR is equivalent to the `nil' type specifier or nil otherwise." + (with-comp-cstr-accessors + (and (null (typeset cstr)) + (null (valset cstr)) + (null (range cstr)) + (null (neg cstr))))) + +(defsubst comp-cstr-null-p (cstr) + "Return t if CSTR is equivalent to the `null' type specifier, nil otherwise." + (with-comp-cstr-accessors + (and (null (typeset cstr)) + (null (range cstr)) + (null (neg cstr)) + (equal (valset cstr) '(nil))))) + +(defun comp-cstrs-homogeneous (cstrs) + "Check if constraints CSTRS are all homogeneously negated or non-negated. +Return `pos' if they are all positive, `neg' if they are all +negated or nil othewise." + (cl-loop + for cstr in cstrs + unless (comp-cstr-neg cstr) + count t into n-pos + else + count t into n-neg + finally + (cond + ((zerop n-neg) (cl-return 'pos)) + ((zerop n-pos) (cl-return 'neg))))) + +(defun comp-split-pos-neg (cstrs) + "Split constraints CSTRS into non-negated and negated. +Return them as multiple value." + (cl-loop + for cstr in cstrs + if (comp-cstr-neg cstr) + collect cstr into negatives + else + collect cstr into positives + finally return (cl-values positives negatives))) + +;; So we can load comp-cstr.el and comp.el in non native compiled +;; builds. +(defvar comp-ctxt nil) + +(defvar comp-cstr-one (comp-value-to-cstr 1) + "Represent the integer immediate one.") + +(defvar comp-cstr-t (comp-type-to-cstr t) + "Represent the superclass t.") + + +;;; Value handling. + +(defun comp-normalize-valset (valset) + "Sort and remove duplicates from VALSET then return it." + (cl-sort (cl-remove-duplicates valset :test #'eq) + (lambda (x y) + (cond + ((and (symbolp x) (symbolp y)) + (string< x y)) + ((and (symbolp x) (not (symbolp y))) + t) + ((and (not (symbolp x)) (symbolp y)) + nil) + (t + (< (sxhash-equal x) + (sxhash-equal y))))))) + +(defun comp-union-valsets (&rest valsets) + "Union values present into VALSETS." + (comp-normalize-valset (cl-reduce #'cl-union valsets))) + +(defun comp-intersection-valsets (&rest valsets) + "Union values present into VALSETS." + (comp-normalize-valset (cl-reduce #'cl-intersection valsets))) + + +;;; Type handling. + +(defun comp-normalize-typeset (typeset) + "Sort TYPESET and return it." + (cl-sort (cl-remove-duplicates typeset) + (lambda (x y) + (string-lessp (symbol-name x) + (symbol-name y))))) + +(defun comp-supertypes (type) + "Return a list of pairs (supertype . hierarchy-level) for TYPE." + (cl-loop + named outer + with found = nil + for l in comp--typeof-types + do (cl-loop + for x in l + for i from (length l) downto 0 + when (eq type x) + do (setf found t) + when found + collect `(,x . ,i) into res + finally (when found + (cl-return-from outer res))))) + +(defun comp-common-supertype-2 (type1 type2) + "Return the first common supertype of TYPE1 TYPE2." + (when-let ((types (cl-intersection + (comp-supertypes type1) + (comp-supertypes type2) + :key #'car))) + (car (cl-reduce (lambda (x y) + (if (> (cdr x) (cdr y)) x y)) + types)))) + +(defun comp-common-supertype (&rest types) + "Return the first common supertype of TYPES." + (or (gethash types (comp-cstr-ctxt-common-supertype-mem comp-ctxt)) + (puthash types + (cl-reduce #'comp-common-supertype-2 types) + (comp-cstr-ctxt-common-supertype-mem comp-ctxt)))) + +(defsubst comp-subtype-p (type1 type2) + "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise." + (let ((types (cons type1 type2))) + (or (gethash types (comp-cstr-ctxt-subtype-p-mem comp-ctxt)) + (puthash types + (eq (comp-common-supertype-2 type1 type2) type2) + (comp-cstr-ctxt-subtype-p-mem comp-ctxt))))) + +(defun comp-union-typesets (&rest typesets) + "Union types present into TYPESETS." + (or (gethash typesets (comp-cstr-ctxt-union-typesets-mem comp-ctxt)) + (puthash typesets + (cl-loop + with types = (apply #'append typesets) + with res = '() + for lane in comp--typeof-types + do (cl-loop + with last = nil + for x in lane + when (memq x types) + do (setf last x) + finally (when last + (push last res))) + finally return (comp-normalize-typeset res)) + (comp-cstr-ctxt-union-typesets-mem comp-ctxt)))) + +(defun comp-intersect-two-typesets (t1 t2) + "Intersect typesets T1 and T2." + (with-comp-cstr-accessors + (cl-loop + for types in (list t1 t2) + for other-types in (list t2 t1) + append + (cl-loop + for type in types + when (cl-some (lambda (x) + (comp-subtype-p type x)) + other-types) + collect type)))) + +(defun comp-intersect-typesets (&rest typesets) + "Intersect types present into TYPESETS." + (unless (cl-some #'null typesets) + (if (length= typesets 1) + (car typesets) + (comp-normalize-typeset + (cl-reduce #'comp-intersect-two-typesets typesets))))) + + +;;; Integer range handling + +(defsubst comp-star-or-num-p (x) + (or (numberp x) (eq '* x))) + +(defsubst comp-range-1+ (x) + (if (symbolp x) + x + (1+ x))) + +(defsubst comp-range-1- (x) + (if (symbolp x) + x + (1- x))) + +(defsubst comp-range-+ (x y) + (pcase (cons x y) + ((or '(+ . -) '(- . +)) '??) + ((or `(- . ,_) `(,_ . -)) '-) + ((or `(+ . ,_) `(,_ . +)) '+) + (_ (+ x y)))) + +(defsubst comp-range-- (x y) + (pcase (cons x y) + ((or '(+ . +) '(- . -)) '??) + ('(+ . -) '+) + ('(- . +) '-) + ((or `(+ . ,_) `(,_ . -)) '+) + ((or `(- . ,_) `(,_ . +)) '-) + (_ (- x y)))) + +(defsubst comp-range-< (x y) + (cond + ((eq x '+) nil) + ((eq x '-) t) + ((eq y '+) t) + ((eq y '-) nil) + (t (< x y)))) + +(defsubst comp-cstr-smallest-in-range (range) + "Smallest entry in RANGE." + (caar range)) + +(defsubst comp-cstr-greatest-in-range (range) + "Greater entry in RANGE." + (cdar (last range))) + +(defun comp-range-union (&rest ranges) + "Combine integer intervals RANGES by union set operation." + (cl-loop + with all-ranges = (apply #'append ranges) + with lows = (mapcar (lambda (x) + (cons (comp-range-1- (car x)) 'l)) + all-ranges) + with highs = (mapcar (lambda (x) + (cons (cdr x) 'h)) + all-ranges) + with nest = 0 + with low = nil + with res = () + for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) + if (eq x 'l) + do + (when (zerop nest) + (setf low i)) + (cl-incf nest) + else + do + (when (= nest 1) + (push `(,(comp-range-1+ low) . ,i) res)) + (cl-decf nest) + finally return (reverse res))) + +(defun comp-range-intersection (&rest ranges) + "Combine integer intervals RANGES by intersecting." + (cl-loop + with all-ranges = (apply #'append ranges) + with n-ranges = (length ranges) + with lows = (mapcar (lambda (x) + (cons (car x) 'l)) + all-ranges) + with highs = (mapcar (lambda (x) + (cons (cdr x) 'h)) + all-ranges) + with nest = 0 + with low = nil + with res = () + for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car) + initially (when (cl-some #'null ranges) + ;; Intersecting with a null range always results in a + ;; null range. + (cl-return '())) + if (eq x 'l) + do + (cl-incf nest) + (when (= nest n-ranges) + (setf low i)) + else + do + (when (= nest n-ranges) + (push `(,low . ,i) + res)) + (cl-decf nest) + finally return (reverse res))) + +(defun comp-range-negation (range) + "Negate range RANGE." + (if (null range) + '((- . +)) + (cl-loop + with res = () + with last-h = '- + for (l . h) in range + unless (eq l '-) + do (push `(,(comp-range-1+ last-h) . ,(1- l)) res) + do (setf last-h h) + finally + (unless (eq '+ last-h) + (push `(,(1+ last-h) . +) res)) + (cl-return (reverse res))))) + +(defsubst comp-cstr-set-cmp-range (dst old-dst ext-range) + "Support range comparison functions." + (with-comp-cstr-accessors + (if ext-range + (setf (typeset dst) (when (cl-some (lambda (x) + (comp-subtype-p 'float x)) + (typeset old-dst)) + '(float)) + (valset dst) () + (range dst) (if (range old-dst) + (comp-range-intersection (range old-dst) + ext-range) + ext-range) + (neg dst) nil) + (setf (typeset dst) (typeset old-dst) + (valset dst) (valset old-dst) + (range dst) (range old-dst) + (neg dst) (neg old-dst))))) + +(defmacro comp-cstr-set-range-for-arithm (dst src1 src2 &rest range-body) + ;; Prevent some code duplication for `comp-cstr-add-2' + ;; `comp-cstr-sub-2'. + (declare (debug (range-body)) + (indent defun)) + `(with-comp-cstr-accessors + (when-let ((r1 (range ,src1)) + (r2 (range ,src2))) + (let* ((l1 (comp-cstr-smallest-in-range r1)) + (l2 (comp-cstr-smallest-in-range r2)) + (h1 (comp-cstr-greatest-in-range r1)) + (h2 (comp-cstr-greatest-in-range r2))) + (setf (typeset ,dst) (when (cl-some (lambda (x) + (comp-subtype-p 'float x)) + (append (typeset src1) + (typeset src2))) + '(float)) + (range ,dst) ,@range-body))))) + +(defun comp-cstr-add-2 (dst src1 src2) + "Sum SRC1 and SRC2 into DST." + (comp-cstr-set-range-for-arithm dst src1 src2 + `((,(comp-range-+ l1 l2) . ,(comp-range-+ h1 h2))))) + +(defun comp-cstr-sub-2 (dst src1 src2) + "Subtract SRC1 and SRC2 into DST." + (comp-cstr-set-range-for-arithm dst src1 src2 + (let ((l (comp-range-- l1 h2)) + (h (comp-range-- h1 l2))) + (if (or (eq l '??) (eq h '??)) + '((- . +)) + `((,l . ,h)))))) + + +;;; Union specific code. + +(defun comp-cstr-union-homogeneous-no-range (dst &rest srcs) + "As `comp-cstr-union' but escluding the irange component. +All SRCS constraints must be homogeneously negated or non-negated." + + ;; Type propagation. + (setf (comp-cstr-typeset dst) + (apply #'comp-union-typesets (mapcar #'comp-cstr-typeset srcs))) + + ;; Value propagation. + (setf (comp-cstr-valset dst) + (comp-normalize-valset + (cl-loop + with values = (mapcar #'comp-cstr-valset srcs) + ;; TODO sort. + for v in (cl-remove-duplicates (apply #'append values) + :test #'equal) + ;; We propagate only values those types are not already + ;; into typeset. + when (cl-notany (lambda (x) + (comp-subtype-p (type-of v) x)) + (comp-cstr-typeset dst)) + collect v))) + + dst) + +(defun comp-cstr-union-homogeneous (range dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do range propagation when RANGE is non-nil. +All SRCS constraints must be homogeneously negated or non-negated. +DST is returned." + (apply #'comp-cstr-union-homogeneous-no-range dst srcs) + ;; Range propagation. + (setf (comp-cstr-neg dst) + (when srcs + (comp-cstr-neg (car srcs))) + + (comp-cstr-range dst) + (when (cl-notany (lambda (x) + (comp-subtype-p 'integer x)) + (comp-cstr-typeset dst)) + (if range + (apply #'comp-range-union + (mapcar #'comp-cstr-range srcs)) + '((- . +))))) + dst) + +(cl-defun comp-cstr-union-1-no-mem (range &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do range propagation when RANGE is non-nil. +Non memoized version of `comp-cstr-union-1'. +DST is returned." + (with-comp-cstr-accessors + (let ((dst (make-comp-cstr))) + (cl-flet ((give-up () + (setf (typeset dst) '(t) + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst))) + + ;; Check first if we are in the simple case of all input non-negate + ;; or negated so we don't have to cons. + (when-let ((res (comp-cstrs-homogeneous srcs))) + (apply #'comp-cstr-union-homogeneous range dst srcs) + (cl-return-from comp-cstr-union-1-no-mem dst)) + + ;; Some are negated and some are not + (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) + (let* ((pos (apply #'comp-cstr-union-homogeneous range + (make-comp-cstr) positives)) + ;; We'll always use neg as result as this is almost + ;; always necessary for describing open intervals + ;; resulting from negated constraints. + (neg (apply #'comp-cstr-union-homogeneous range + (make-comp-cstr :neg t) negatives))) + ;; Type propagation. + (when (and (typeset pos) + ;; When every pos type is a subtype of some neg ones. + (cl-every (lambda (x) + (cl-some (lambda (y) + (comp-subtype-p x y)) + (append (typeset neg) + (when (range neg) + '(integer))))) + (typeset pos))) + ;; This is a conservative choice, ATM we can't represent such + ;; a disjoint set of types unless we decide to add a new slot + ;; into `comp-cstr' or adopt something like + ;; `intersection-type' `union-type' in SBCL. Keep it + ;; "simple" for now. + (give-up)) + + ;; When every neg type is a subtype of some pos one. + ;; In case return pos. + (when (and (typeset neg) + (cl-every (lambda (x) + (cl-some (lambda (y) + (comp-subtype-p x y)) + (append (typeset pos) + (when (range pos) + '(integer))))) + (typeset neg))) + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) + (neg dst) nil) + (cl-return-from comp-cstr-union-1-no-mem dst)) + + ;; Verify disjoint condition between positive types and + ;; negative types coming from values, in case give-up. + (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) + (when (range neg) + '(integer))))) + (when (cl-some (lambda (x) + (cl-some (lambda (y) + (and (not (eq y x)) + (comp-subtype-p y x))) + neg-value-types)) + (typeset pos)) + (give-up))) + + ;; Value propagation. + (cond + ((and (valset pos) (valset neg) + (equal (comp-union-valsets (valset pos) (valset neg)) + (valset pos))) + ;; Pos is a superset of neg. + (give-up)) + ((cl-some (lambda (x) + (cl-some (lambda (y) + (comp-subtype-p y x)) + (mapcar #'type-of (valset pos)))) + (typeset neg)) + (give-up)) + (t + ;; pos is a subset or eq to neg + (setf (valset neg) + (cl-nset-difference (valset neg) (valset pos))))) + + ;; Range propagation + (when range + ;; Handle apart (or (integer 1 1) (not (integer 1 1))) + ;; like cases. + (if (and (range pos) (range neg) + (equal (range pos) (range neg))) + (give-up) + (setf (range neg) + (comp-range-negation + (comp-range-union + (comp-range-negation (range neg)) + (range pos)))))) + + (if (comp-cstr-empty-p neg) + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) + (neg dst) nil) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) (neg neg))))) + + ;; (not null) => t + (when (and (neg dst) + (null (typeset dst)) + (null (valset dst)) + (null (range dst))) + (give-up))) + + dst))) + +(defun comp-cstr-union-1 (range dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do range propagation when RANGE is non-nil. +DST is returned." + (with-comp-cstr-accessors + (let* ((mem-h (if range + (comp-cstr-ctxt-union-1-mem-range comp-ctxt) + (comp-cstr-ctxt-union-1-mem-no-range comp-ctxt))) + (res (or (gethash srcs mem-h) + (puthash + (mapcar #'comp-cstr-copy srcs) + (apply #'comp-cstr-union-1-no-mem range srcs) + mem-h)))) + (setf (typeset dst) (typeset res) + (valset dst) (valset res) + (range dst) (range res) + (neg dst) (neg res)) + res))) + +(cl-defun comp-cstr-intersection-homogeneous (dst &rest srcs) + "Combine SRCS by intersection set operation setting the result in DST. +All SRCS constraints must be homogeneously negated or non-negated. +DST is returned." + + (with-comp-cstr-accessors + (when (cl-some #'comp-cstr-empty-p srcs) + (setf (valset dst) nil + (range dst) nil + (typeset dst) nil) + (cl-return-from comp-cstr-intersection-homogeneous dst)) + + (setf (neg dst) (when srcs + (neg (car srcs)))) + + ;; Type propagation. + (setf (typeset dst) + (apply #'comp-intersect-typesets + (mapcar #'comp-cstr-typeset srcs))) + + ;; Value propagation. + (setf (valset dst) + (comp-normalize-valset + (cl-loop + for src in srcs + append + (cl-loop + for val in (valset src) + ;; If (member value) is subtypep of all other sources then + ;; is good to be colleted. + when (cl-every (lambda (s) + (or (memql val (valset s)) + (cl-some (lambda (type) + (cl-typep val type)) + (typeset s)))) + (remq src srcs)) + collect val)))) + + ;; Range propagation. + (setf (range dst) + ;; Do range propagation only if the destination typeset + ;; doesn't cover it already. + (unless (cl-some (lambda (type) + (comp-subtype-p 'integer type)) + (typeset dst)) + (apply #'comp-range-intersection + (cl-loop + for src in srcs + ;; Collect effective ranges. + collect (or (range src) + (when (cl-some (lambda (s) + (comp-subtype-p 'integer s)) + (typeset src)) + '((- . +)))))))) + + dst)) + +(cl-defun comp-cstr-intersection-no-mem (&rest srcs) + "Combine SRCS by intersection set operation. +Non memoized version of `comp-cstr-intersection-no-mem'." + (let ((dst (make-comp-cstr))) + (with-comp-cstr-accessors + (cl-flet ((return-empty () + (setf (typeset dst) () + (valset dst) () + (range dst) () + (neg dst) nil) + (cl-return-from comp-cstr-intersection-no-mem dst))) + (when-let ((res (comp-cstrs-homogeneous srcs))) + (if (eq res 'neg) + (apply #'comp-cstr-union-homogeneous t dst srcs) + (apply #'comp-cstr-intersection-homogeneous dst srcs)) + (cl-return-from comp-cstr-intersection-no-mem dst)) + + ;; Some are negated and some are not + (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs) + (let* ((pos (apply #'comp-cstr-intersection-homogeneous + (make-comp-cstr) positives)) + (neg (apply #'comp-cstr-intersection-homogeneous + (make-comp-cstr) negatives))) + + ;; In case pos is not relevant return directly the content + ;; of neg. + (when (equal (typeset pos) '(t)) + (setf (typeset dst) (typeset neg) + (valset dst) (valset neg) + (range dst) (range neg) + (neg dst) t) + + ;; (not t) => nil + (when (and (null (valset dst)) + (null (range dst)) + (neg dst) + (equal '(t) (typeset dst))) + (setf (typeset dst) () + (neg dst) nil)) + + (cl-return-from comp-cstr-intersection-no-mem dst)) + + (when (cl-some + (lambda (ty) + (memq ty (typeset neg))) + (typeset pos)) + (return-empty)) + + ;; Some negated types are subtypes of some non-negated one. + ;; Transform the corresponding set of types from neg to pos. + (cl-loop + for neg-type in (typeset neg) + do (cl-loop + for pos-type in (copy-sequence (typeset pos)) + when (and (not (eq neg-type pos-type)) + (comp-subtype-p neg-type pos-type)) + do (cl-loop + with found + for (type . _) in (comp-supertypes neg-type) + when found + collect type into res + when (eq type pos-type) + do (setf (typeset pos) (cl-union (typeset pos) res)) + (cl-return) + when (eq type neg-type) + do (setf found t)))) + + (setf (range pos) + (comp-range-intersection (range pos) + (comp-range-negation (range neg))) + (valset pos) + (cl-set-difference (valset pos) (valset neg))) + + ;; Return a non negated form. + (setf (typeset dst) (typeset pos) + (valset dst) (valset pos) + (range dst) (range pos) + (neg dst) nil))) + dst)))) + + +;;; Entry points. + +(defun comp-cstr-imm-vld-p (cstr) + "Return t if one and only one immediate value can be extracted from CSTR." + (with-comp-cstr-accessors + (when (and (null (typeset cstr)) + (null (neg cstr))) + (let* ((v (valset cstr)) + (r (range cstr)) + (valset-len (length v)) + (range-len (length r))) + (if (and (= valset-len 1) + (= range-len 0)) + t + (when (and (= valset-len 0) + (= range-len 1)) + (let* ((low (caar r)) + (high (cdar r))) + (and (integerp low) + (integerp high) + (= low high))))))))) + +(defun comp-cstr-imm (cstr) + "Return the immediate value of CSTR. +`comp-cstr-imm-vld-p' *must* be satisfied before calling +`comp-cstr-imm'." + (declare (gv-setter + (lambda (val) + `(with-comp-cstr-accessors + (if (integerp ,val) + (setf (typeset ,cstr) nil + (range ,cstr) (list (cons ,val ,val))) + (setf (typeset ,cstr) nil + (valset ,cstr) (list ,val))))))) + (with-comp-cstr-accessors + (let ((v (valset cstr))) + (if (length= v 1) + (car v) + (caar (range cstr)))))) + +(defun comp-cstr-fixnum-p (cstr) + "Return t if CSTR is certainly a fixnum." + (with-comp-cstr-accessors + (when (null (neg cstr)) + (when-let (range (range cstr)) + (let* ((low (caar range)) + (high (cdar (last range)))) + (unless (or (eq low '-) + (< low most-negative-fixnum) + (eq high '+) + (> high most-positive-fixnum)) + t)))))) + +(defun comp-cstr-symbol-p (cstr) + "Return t if CSTR is certainly a symbol." + (with-comp-cstr-accessors + (and (null (range cstr)) + (null (neg cstr)) + (or (and (null (valset cstr)) + (equal (typeset cstr) '(symbol))) + (and (or (null (typeset cstr)) + (equal (typeset cstr) '(symbol))) + (cl-every #'symbolp (valset cstr))))))) + +(defsubst comp-cstr-cons-p (cstr) + "Return t if CSTR is certainly a cons." + (with-comp-cstr-accessors + (and (null (valset cstr)) + (null (range cstr)) + (null (neg cstr)) + (equal (typeset cstr) '(cons))))) + +(defun comp-cstr-= (dst op1 op2) + "Constraint OP1 being = OP2 setting the result into DST." + (with-comp-cstr-accessors + (cl-flet ((relax-cstr (cstr) + (setf cstr (comp-cstr-shallow-copy cstr)) + ;; If can be any float extend it to all integers. + (when (memq 'float (typeset cstr)) + (setf (range cstr) '((- . +)))) + ;; For each float value that can be represented + ;; precisely as an integer add the integer as well. + (cl-loop + for v in (valset cstr) + do + (when-let* ((ok (floatp v)) + (truncated (ignore-error overflow-error + (truncate v))) + (ok (= v truncated))) + (push (cons truncated truncated) (range cstr)))) + (cl-loop + with vals-to-add + for (l . h) in (range cstr) + ;; If an integer range reduces to single value add + ;; its float value too. + if (eql l h) + do (push (float l) vals-to-add) + ;; Otherwise can be any float. + else + do (cl-pushnew 'float (typeset cstr)) + (cl-return cstr) + finally (setf (valset cstr) + (append vals-to-add (valset cstr)))) + (when (memql 0.0 (valset cstr)) + (cl-pushnew -0.0 (valset cstr))) + (when (memql -0.0 (valset cstr)) + (cl-pushnew 0.0 (valset cstr))) + cstr)) + (comp-cstr-intersection dst (relax-cstr op1) (relax-cstr op2))))) + +(defun comp-cstr-> (dst old-dst src) + "Constraint DST being > than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((,(1+ src) . +)) + (when-let* ((range (range src)) + (low (comp-cstr-smallest-in-range range)) + (okay (integerp low))) + `((,(1+ low) . +)))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + +(defun comp-cstr->= (dst old-dst src) + "Constraint DST being >= than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((,src . +)) + (when-let* ((range (range src)) + (low (comp-cstr-smallest-in-range range)) + (okay (integerp low))) + `((,low . +)))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + +(defun comp-cstr-< (dst old-dst src) + "Constraint DST being < than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((- . ,(1- src))) + (when-let* ((range (range src)) + (low (comp-cstr-greatest-in-range range)) + (okay (integerp low))) + `((- . ,(1- low))))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + +(defun comp-cstr-<= (dst old-dst src) + "Constraint DST being > than SRC. +SRC can be either a comp-cstr or an integer." + (with-comp-cstr-accessors + (let ((ext-range + (if (integerp src) + `((- . ,src)) + (when-let* ((range (range src)) + (low (comp-cstr-greatest-in-range range)) + (okay (integerp low))) + `((- . ,low)))))) + (comp-cstr-set-cmp-range dst old-dst ext-range)))) + +(defun comp-cstr-add (dst srcs) + "Sum SRCS into DST." + (comp-cstr-add-2 dst (cl-first srcs) (cl-second srcs)) + (cl-loop + for src in (nthcdr 2 srcs) + do (comp-cstr-add-2 dst dst src))) + +(defun comp-cstr-sub (dst srcs) + "Subtract SRCS into DST." + (comp-cstr-sub-2 dst (cl-first srcs) (cl-second srcs)) + (cl-loop + for src in (nthcdr 2 srcs) + do (comp-cstr-sub-2 dst dst src))) + +(defun comp-cstr-union-no-range (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +Do not propagate the range component. +DST is returned." + (apply #'comp-cstr-union-1 nil dst srcs)) + +(defun comp-cstr-union (dst &rest srcs) + "Combine SRCS by union set operation setting the result in DST. +DST is returned." + (apply #'comp-cstr-union-1 t dst srcs)) + +(defun comp-cstr-union-make (&rest srcs) + "Combine SRCS by union set operation and return a new constraint." + (apply #'comp-cstr-union (make-comp-cstr) srcs)) + +(defun comp-cstr-intersection (dst &rest srcs) + "Combine SRCS by intersection set operation setting the result in DST. +DST is returned." + (with-comp-cstr-accessors + (let* ((mem-h (comp-cstr-ctxt-intersection-mem comp-ctxt)) + (res (or (gethash srcs mem-h) + (puthash + (mapcar #'comp-cstr-copy srcs) + (apply #'comp-cstr-intersection-no-mem srcs) + mem-h)))) + (setf (typeset dst) (typeset res) + (valset dst) (valset res) + (range dst) (range res) + (neg dst) (neg res)) + res))) + +(defun comp-cstr-intersection-no-hashcons (dst &rest srcs) + "Combine SRCS by intersection set operation setting the result in DST. +Non hash consed values are not propagated as values but rather +promoted to their types. +DST is returned." + (with-comp-cstr-accessors + (apply #'comp-cstr-intersection dst srcs) + (if (and (neg dst) + (valset dst) + (cl-notevery #'symbolp (valset dst))) + (setf (valset dst) () + (typeset dst) '(t) + (range dst) () + (neg dst) nil) + (let (strip-values strip-types) + (cl-loop for v in (valset dst) + unless (symbolp v) + do (push v strip-values) + (push (type-of v) strip-types)) + (when strip-values + (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types) + (valset dst) (cl-set-difference (valset dst) strip-values))) + (cl-loop for (l . h) in (range dst) + when (or (bignump l) (bignump h)) + do (setf (range dst) '((- . +))) + (cl-return)))) + dst)) + +(defun comp-cstr-intersection-make (&rest srcs) + "Combine SRCS by intersection set operation and return a new constraint." + (apply #'comp-cstr-intersection (make-comp-cstr) srcs)) + +(defun comp-cstr-negation (dst src) + "Negate SRC setting the result in DST. +DST is returned." + (with-comp-cstr-accessors + (cond + ((and (null (valset src)) + (null (range src)) + (null (neg src)) + (equal (typeset src) '(t))) + (setf (typeset dst) () + (valset dst) () + (range dst) nil + (neg dst) nil)) + ((and (null (valset src)) + (null (range src)) + (null (neg src)) + (null (typeset src))) + (setf (typeset dst) '(t) + (valset dst) () + (range dst) nil + (neg dst) nil)) + (t (setf (typeset dst) (typeset src) + (valset dst) (valset src) + (range dst) (range src) + (neg dst) (not (neg src))))) + dst)) + +(defun comp-cstr-value-negation (dst src) + "Negate values in SRC setting the result in DST. +DST is returned." + (with-comp-cstr-accessors + (if (or (valset src) (range src)) + (setf (typeset dst) () + (valset dst) (valset src) + (range dst) (range src) + (neg dst) (not (neg src))) + (setf (typeset dst) (typeset src) + (valset dst) () + (range dst) ())) + dst)) + +(defun comp-cstr-negation-make (src) + "Negate SRC and return a new constraint." + (comp-cstr-negation (make-comp-cstr) src)) + +(defun comp-type-spec-to-cstr (type-spec &optional fn) + "Convert a type specifier TYPE-SPEC into a `comp-cstr'. +FN non-nil indicates we are parsing a function lambda list." + (pcase type-spec + ((and (or '&optional '&rest) x) + (if fn + x + (error "Invalid `%s` in type specifier" x))) + ('nil + (make-comp-cstr :typeset ())) + ('fixnum + (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) + ('boolean + (comp-type-spec-to-cstr '(member t nil))) + ('integer + (comp-irange-to-cstr '(- . +))) + ('null (comp-value-to-cstr nil)) + ((pred atom) + (comp-type-to-cstr type-spec)) + (`(or . ,rest) + (apply #'comp-cstr-union-make + (mapcar #'comp-type-spec-to-cstr rest))) + (`(and . ,rest) + (apply #'comp-cstr-intersection-make + (mapcar #'comp-type-spec-to-cstr rest))) + (`(not ,cstr) + (comp-cstr-negation-make (comp-type-spec-to-cstr cstr))) + (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h)) + (comp-irange-to-cstr `(,l . ,h))) + (`(integer * ,(and (pred integerp) h)) + (comp-irange-to-cstr `(- . ,h))) + (`(integer ,(and (pred integerp) l) *) + (comp-irange-to-cstr `(,l . +))) + (`(float ,(pred comp-star-or-num-p) ,(pred comp-star-or-num-p)) + ;; No float range support :/ + (comp-type-to-cstr 'float)) + (`(member . ,rest) + (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest))) + (`(function ,args ,ret) + (make-comp-cstr-f + :args (mapcar (lambda (x) + (comp-type-spec-to-cstr x t)) + args) + :ret (comp-type-spec-to-cstr ret))) + (_ (error "Invalid type specifier")))) + +(defun comp-cstr-to-type-spec (cstr) + "Given CSTR return its type specifier." + (let ((valset (comp-cstr-valset cstr)) + (typeset (comp-cstr-typeset cstr)) + (range (comp-cstr-range cstr)) + (negated (comp-cstr-neg cstr))) + + (when valset + (when (memq nil valset) + (if (memq t valset) + (progn + ;; t and nil are values, convert into `boolean'. + (push 'boolean typeset) + (setf valset (remove t (remove nil valset)))) + ;; Only nil is a value, convert it into a `null' type specifier. + (setf valset (remove nil valset)) + (push 'null typeset)))) + + ;; Form proper integer type specifiers. + (setf range (cl-loop for (l . h) in range + for low = (if (integerp l) l '*) + for high = (if (integerp h) h '*) + if (and (eq low '*) (eq high '*)) + collect 'integer + else + collect `(integer ,low , high)) + valset (cl-remove-duplicates valset)) + + ;; Form the final type specifier. + (let* ((types-ints (append typeset range)) + (res (cond + ((and types-ints valset) + `((member ,@valset) ,@types-ints)) + (types-ints types-ints) + (valset `(member ,@valset)) + (t + ;; Empty type specifier + nil))) + (final + (pcase res + ((or `(member . ,rest) + `(integer ,(pred comp-star-or-num-p) + ,(pred comp-star-or-num-p))) + (if rest + res + (car res))) + ((pred atom) res) + (`(,_first . ,rest) + (if rest + `(or ,@res) + (car res)))))) + (if negated + `(not ,final) + final)))) + +(provide 'comp-cstr) + +;;; comp-cstr.el ends here diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el new file mode 100644 index 00000000000..7bbe63c3e15 --- /dev/null +++ b/lisp/emacs-lisp/comp.el @@ -0,0 +1,4234 @@ +;;; comp.el --- compilation of Lisp code into native code -*- lexical-binding: t -*- + +;; Copyright (C) 2019-2021 Free Software Foundation, Inc. + +;; Author: Andrea Corallo <akrl@sdf.com> +;; Keywords: lisp +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This code is an attempt to make the pig fly. +;; Or, to put it another way to make a 911 out of a turbocharged VW Bug. + +;;; Code: + +(require 'bytecomp) +(require 'cl-extra) +(require 'cl-lib) +(require 'cl-macs) +(require 'cl-seq) +(require 'gv) +(require 'rx) +(require 'subr-x) +(require 'warnings) +(require 'comp-cstr) + +(defgroup comp nil + "Emacs Lisp native compiler." + :group 'lisp) + +(defcustom native-comp-speed 2 + "Optimization level for native compilation, a number between -1 and 3. + -1 functions are kept in bytecode form and no native compilation is performed. + 0 native compilation is performed with no optimizations. + 1 light optimizations. + 2 max optimization level fully adherent to the language semantic. + 3 max optimization level, to be used only when necessary. + Warning: with 3, the compiler is free to perform dangerous optimizations." + :type 'integer + :safe #'integerp + :version "28.1") + +(defcustom native-comp-debug (if (eq 'windows-nt system-type) 1 0) + "Debug level for native compilation, a number between 0 and 3. +This is intended for debugging the compiler itself. + 0 no debug output. + 1 emit debug symbols. + 2 emit debug symbols and dump pseudo C code. + 3 emit debug symbols and dump: pseudo C code, GCC intermediate + passes and libgccjit log file." + :type 'integer + :safe #'natnump + :version "28.1") + +(defcustom native-comp-verbose 0 + "Compiler verbosity for native compilation, a number between 0 and 3. +This is intended for debugging the compiler itself. + 0 no logging. + 1 final LIMPLE is logged. + 2 LAP, final LIMPLE, and some pass info are logged. + 3 max verbosity." + :type 'integer + :risky t + :version "28.1") + +(defcustom native-comp-always-compile nil + "Non-nil means unconditionally (re-)compile all files." + :type 'boolean + :version "28.1") + +(defcustom native-comp-deferred-compilation-deny-list + '() + "List of regexps to exclude matching files from deferred native compilation. +Files whose names match any regexp are excluded from native compilation." + :type '(repeat regexp) + :version "28.1") + +(defcustom native-comp-bootstrap-deny-list + '() + "List of regexps to exclude files from native compilation during bootstrap. +Files whose names match any regexp are excluded from native compilation +during bootstrap." + :type '(repeat regexp) + :version "28.1") + +(defcustom native-comp-never-optimize-functions + '(;; The following two are mandatory for Emacs to be working + ;; correctly (see comment in `advice--add-function'). DO NOT + ;; REMOVE. + macroexpand rename-buffer) + "Primitive functions to exclude from trampoline optimization." + :type '(repeat symbol) + :version "28.1") + +(defcustom native-comp-async-jobs-number 0 + "Default number of subprocesses used for async native compilation. +Value of zero means to use half the number of the CPU's execution units, +or one if there's just one execution unit." + :type 'integer + :risky t + :version "28.1") + +(defcustom native-comp-async-cu-done-functions nil + "List of functions to call after asynchronously compiling one compilation unit. +Called with one argument FILE, the filename used as input to +compilation." + :type 'hook + :version "28.1") + +(defcustom native-comp-async-all-done-hook nil + "Hook run after completing asynchronous compilation of all input files." + :type 'hook + :version "28.1") + +(defcustom native-comp-async-env-modifier-form nil + "Form evaluated before compilation by each asynchronous compilation subprocess. +Used to modify the compiler environment." + :type 'sexp + :risky t + :version "28.1") + +(defcustom native-comp-async-report-warnings-errors t + "Whether to report warnings and errors from asynchronous native compilation. + +When native compilation happens asynchronously, it can produce +warnings and errors, some of which might not be emitted by a +byte-compilation. The typical case for that is native-compiling +a file that is missing some `require' of a necessary feature, +while having it already loaded into the environment when +byte-compiling. + +As asynchronous native compilation always starts from a pristine +environment, it is more sensitive to such omissions, and might be +unable to compile such Lisp source files correctly. + +Set this variable to nil to suppress warnings altogether, or to +the symbol `silent' to log warnings but not pop up the *Warnings* +buffer." + :type '(choice + (const :tag "Do not report warnings" nil) + (const :tag "Report and display warnings" t) + (const :tag "Report but do not display warnings" silent)) + :version "28.1") + +(defcustom native-comp-async-query-on-exit nil + "Whether to query the user about killing async compilations when exiting. +If this is non-nil, Emacs will ask for confirmation to exit and kill the +asynchronous native compilations if any are running. If nil, when you +exit Emacs, it will silently kill those asynchronous compilations even +if `confirm-kill-processes' is non-nil." + :type 'boolean + :version "28.1") + +(defcustom native-comp-driver-options nil + "Options passed verbatim to the native compiler's back-end driver. +Note that not all options are meaningful; typically only the options +affecting the assembler and linker are likely to be useful. + +Passing these options is only available in libgccjit version 9 +and above." + :type '(repeat string) ; FIXME is this right? + :version "28.1") + +(defcustom comp-libgccjit-reproducer nil + "When non-nil produce a libgccjit reproducer. +The reproducer is a file ELNFILENAME_libgccjit_repro.c deposed in +the .eln output directory." + :type 'boolean + :version "28.1") + +(defcustom native-comp-warning-on-missing-source t + "Emit a warning if a byte-code file being loaded has no corresponding source. +The source file is necessary for native code file look-up and deferred +compilation mechanism." + :type 'boolean + :version "28.1") + +(defvar no-native-compile nil + "Non-nil to prevent native-compiling of Emacs Lisp code. +Note that when `no-byte-compile' is set to non-nil it overrides the value of +`no-native-compile'. +This is normally set in local file variables at the end of the +Emacs Lisp file: + +\;; Local Variables:\n;; no-native-compile: t\n;; End:") +;;;###autoload(put 'no-native-compile 'safe-local-variable 'booleanp) + +(defvar native-compile-target-directory nil + "When non-nil force the target directory for the eln files being compiled.") + +(defvar comp-log-time-report nil + "If non-nil, log a time report for each pass.") + +(defvar comp-dry-run nil + "If non-nil, run everything but the C back-end.") + +(defconst comp-valid-source-re (rx ".el" (? ".gz") eos) + "Regexp to match filename of valid input source files.") + +(defconst comp-log-buffer-name "*Native-compile-Log*" + "Name of the native-compiler log buffer.") + +(defconst comp-async-buffer-name "*Async-native-compile-log*" + "Name of the async compilation buffer log.") + +(defvar comp-native-compiling nil + "This gets bound to t during native compilation. +Intended to be used by code that needs to work differently when +native compilation runs.") + +(defvar comp-pass nil + "Every native-compilation pass can bind this to whatever it likes.") + +(defvar comp-curr-allocation-class 'd-default + "Current allocation class. +Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") + +(defconst comp-passes '(comp-spill-lap + comp-limplify + comp-fwprop + comp-call-optim + comp-ipa-pure + comp-add-cstrs + comp-fwprop + comp-tco + comp-fwprop + comp-remove-type-hints + comp-final) + "Passes to be executed in order.") + +(defvar comp-disabled-passes '() + "List of disabled passes. +For internal use by the test suite only.") + +(defvar comp-post-pass-hooks '() + "Alist whose elements are of the form (PASS FUNCTIONS...). +Each function in FUNCTIONS is run after PASS. +Useful to hook into pass checkers.") + +;; FIXME this probably should not be here but... good for now. +(defconst comp-known-type-specifiers + `( + ;; Functions we can trust not to be or if redefined should expose + ;; the same type. Vast majority of these is either pure or + ;; primitive, the original list is the union of pure + + ;; side-effect-free-fns + side-effect-and-error-free-fns: + (% (function ((or number marker) (or number marker)) number)) + (* (function (&rest (or number marker)) number)) + (+ (function (&rest (or number marker)) number)) + (- (function (&rest (or number marker)) number)) + (/ (function ((or number marker) &rest (or number marker)) number)) + (/= (function ((or number marker) (or number marker)) boolean)) + (1+ (function ((or number marker)) number)) + (1- (function ((or number marker)) number)) + (< (function ((or number marker) &rest (or number marker)) boolean)) + (<= (function ((or number marker) &rest (or number marker)) boolean)) + (= (function ((or number marker) &rest (or number marker)) boolean)) + (> (function ((or number marker) &rest (or number marker)) boolean)) + (>= (function ((or number marker) &rest (or number marker)) boolean)) + (abs (function (number) number)) + (acos (function (number) float)) + (append (function (&rest t) t)) + (aref (function (t fixnum) t)) + (arrayp (function (t) boolean)) + (ash (function (integer integer) integer)) + (asin (function (number) float)) + (assq (function (t list) list)) + (atan (function (number &optional number) float)) + (atom (function (t) boolean)) + (bignump (function (t) boolean)) + (bobp (function () boolean)) + (bolp (function () boolean)) + (bool-vector-count-consecutive (function (bool-vector boolean integer) fixnum)) + (bool-vector-count-population (function (bool-vector) fixnum)) + (bool-vector-not (function (bool-vector &optional bool-vector) bool-vector)) + (bool-vector-p (function (t) boolean)) + (bool-vector-subsetp (function (bool-vector bool-vector) boolean)) + (boundp (function (symbol) boolean)) + (buffer-end (function ((or number marker)) integer)) + (buffer-file-name (function (&optional buffer) string)) + (buffer-list (function (&optional frame) list)) + (buffer-local-variables (function (&optional buffer) list)) + (buffer-modified-p (function (&optional buffer) boolean)) + (buffer-size (function (&optional buffer) integer)) + (buffer-string (function () string)) + (buffer-substring (function ((or integer marker) (or integer marker)) string)) + (bufferp (function (t) boolean)) + (byte-code-function-p (function (t) boolean)) + (capitalize (function (or integer string) (or integer string))) + (car (function (list) t)) + (car-less-than-car (function (list list) boolean)) + (car-safe (function (t) t)) + (case-table-p (function (t) boolean)) + (cdr (function (list) t)) + (cdr-safe (function (t) t)) + (ceiling (function (number &optional number) integer)) + (char-after (function (&optional (or marker integer)) fixnum)) + (char-before (function (&optional (or marker integer)) fixnum)) + (char-equal (function (integer integer) boolean)) + (char-or-string-p (function (t) boolean)) + (char-to-string (function (fixnum) string)) + (char-width (function (fixnum) fixnum)) + (characterp (function (t &optional t) boolean)) + (charsetp (function (t) boolean)) + (commandp (function (t &optional t) boolean)) + (compare-strings (function (string (or integer marker null) (or integer marker null) string (or integer marker null) (or integer marker null) &optional t) (or (member t) fixnum))) + (concat (function (&rest sequence) string)) + (cons (function (t t) cons)) + (consp (function (t) boolean)) + (coordinates-in-window-p (function (cons window) boolean)) + (copy-alist (function (list) list)) + (copy-marker (function (&optional (or integer marker) boolean) marker)) + (copy-sequence (function (sequence) sequence)) + (copysign (function (float float) float)) + (cos (function (number) float)) + (count-lines (function ((or integer marker) (or integer marker) &optional t) integer)) + (current-buffer (function () buffer)) + (current-global-map (function () cons)) + (current-indentation (function () integer)) + (current-local-map (function () cons)) + (current-minor-mode-maps (function () cons)) + (current-time (function () cons)) + (current-time-string (function (&optional string boolean) string)) + (current-time-zone (function (&optional string boolean) cons)) + (custom-variable-p (function (symbol) boolean)) + (decode-char (function (cons t) (or fixnum null))) + (decode-time (function (&optional string symbol symbol) cons)) + (default-boundp (function (symbol) boolean)) + (default-value (function (symbol) t)) + (degrees-to-radians (function (number) float)) + (documentation (function ((or function symbol subr) &optional t) (or null string))) + (downcase (function ((or fixnum string)) (or fixnum string))) + (elt (function (sequence integer) t)) + (encode-char (function (fixnum symbol) (or fixnum null))) + (encode-time (function (cons &rest t) cons)) + (eobp (function () boolean)) + (eolp (function () boolean)) + (eq (function (t t) boolean)) + (eql (function (t t) boolean)) + (equal (function (t t) boolean)) + (error-message-string (function (list) string)) + (eventp (function (t) boolean)) + (exp (function (number) float)) + (expt (function (number number) float)) + (fboundp (function (symbol) boolean)) + (fceiling (function (float) float)) + (featurep (function (symbol &optional symbol) boolean)) + (ffloor (function (float) float)) + (file-directory-p (function (string) boolean)) + (file-exists-p (function (string) boolean)) + (file-locked-p (function (string) boolean)) + (file-name-absolute-p (function (string) boolean)) + (file-newer-than-file-p (function (string string) boolean)) + (file-readable-p (function (string) boolean)) + (file-symlink-p (function (string) boolean)) + (file-writable-p (function (string) boolean)) + (fixnump (function (t) boolean)) + (float (function (number) float)) + (float-time (function (&optional cons) float)) + (floatp (function (t) boolean)) + (floor (function (number &optional number) integer)) + (following-char (function () fixnum)) + (format (function (string &rest t) string)) + (format-time-string (function (string &optional cons symbol) string)) + (frame-first-window (function ((or frame window)) window)) + (frame-root-window (function (&optional (or frame window)) window)) + (frame-selected-window (function (&optional (or frame window)) window)) + (frame-visible-p (function (frame) boolean)) + (framep (function (t) boolean)) + (fround (function (float) float)) + (ftruncate (function (float) float)) + (get (function (symbol symbol) t)) + (get-buffer (function ((or buffer string)) (or buffer null))) + (get-buffer-window (function (&optional (or buffer string) (or symbol (integer 0 0))) (or null window))) + (get-file-buffer (function (string) (or null buffer))) + (get-largest-window (function (&optional t t t) window)) + (get-lru-window (function (&optional t t t) window)) + (getenv (function (string &optional frame) (or null string))) + (gethash (function (t hash-table &optional t) t)) + (hash-table-count (function (hash-table) integer)) + (hash-table-p (function (t) boolean)) + (identity (function (t) t)) + (ignore (function (&rest t) null)) + (int-to-string (function (number) string)) + (integer-or-marker-p (function (t) boolean)) + (integerp (function (t) boolean)) + (interactive-p (function () boolean)) + (intern-soft (function ((or string symbol) &optional vector) symbol)) + (invocation-directory (function () string)) + (invocation-name (function () string)) + (isnan (function (float) boolean)) + (keymap-parent (function (cons) (or cons null))) + (keymapp (function (t) boolean)) + (keywordp (function (t) boolean)) + (last (function (list &optional integer) list)) + (lax-plist-get (function (list t) t)) + (ldexp (function (number integer) float)) + (length (function (t) (integer 0 *))) + (length< (function (sequence fixnum) boolean)) + (length= (function (sequence fixnum) boolean)) + (length> (function (sequence fixnum) boolean)) + (line-beginning-position (function (&optional integer) integer)) + (line-end-position (function (&optional integer) integer)) + (list (function (&rest t) list)) + (listp (function (t) boolean)) + (local-variable-if-set-p (function (symbol &optional buffer) boolean)) + (local-variable-p (function (symbol &optional buffer) boolean)) + (locale-info (function ((member codeset days months paper)) (or null string))) + (log (function (number number) float)) + (log10 (function (number) float)) + (logand (function (&rest (or integer marker)) integer)) + (logb (function (number) integer)) + (logcount (function (integer) integer)) + (logior (function (&rest (or integer marker)) integer)) + (lognot (function (integer) integer)) + (logxor (function (&rest (or integer marker)) integer)) + ;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ? + (lsh (function (integer integer) integer)) + (make-byte-code (function ((or fixnum list) string vector integer &optional string t &rest t) vector)) + (make-list (function (integer t) list)) + (make-marker (function () marker)) + (make-string (function (integer fixnum &optional t) string)) + (make-symbol (function (string) symbol)) + (mark (function (&optional t) (or integer null))) + (mark-marker (function () marker)) + (marker-buffer (function (marker) buffer)) + (markerp (function (t) boolean)) + (max (function ((or number marker) &rest (or number marker)) number)) + (max-char (function () fixnum)) + (member (function (t list) list)) + (memory-limit (function () integer)) + (memq (function (t list) list)) + (memql (function (t list) list)) + (min (function ((or number marker) &rest (or number marker)) number)) + (minibuffer-selected-window (function () window)) + (minibuffer-window (function (&optional frame) window)) + (mod (function ((or number marker) (or number marker)) (or (integer 0 *) (float 0 *)))) + (mouse-movement-p (function (t) boolean)) + (multibyte-char-to-unibyte (function (fixnum) fixnum)) + (natnump (function (t) boolean)) + (next-window (function (&optional window t t) window)) + (nlistp (function (t) boolean)) + (not (function (t) boolean)) + (nth (function (integer list) t)) + (nthcdr (function (integer t) t)) + (null (function (t) boolean)) + (number-or-marker-p (function (t) boolean)) + (number-to-string (function (number) string)) + (numberp (function (t) boolean)) + (one-window-p (function (&optional t t) boolean)) + (overlayp (function (t) boolean)) + (parse-colon-path (function (string) cons)) + (plist-get (function (list t) t)) + (plist-member (function (list t) list)) + (point (function () integer)) + (point-marker (function () marker)) + (point-max (function () integer)) + (point-min (function () integer)) + (preceding-char (function () fixnum)) + (previous-window (function (&optional window t t) window)) + (prin1-to-string (function (t &optional t) string)) + (processp (function (t) boolean)) + (proper-list-p (function (t) integer)) + (propertize (function (string &rest t) string)) + (radians-to-degrees (function (number) float)) + (rassoc (function (t list) list)) + (rassq (function (t list) list)) + (read-from-string (function (string &optional integer integer) cons)) + (recent-keys (function (&optional (or cons null)) vector)) + (recursion-depth (function () integer)) + (regexp-opt (function (list) string)) + (regexp-quote (function (string) string)) + (region-beginning (function () integer)) + (region-end (function () integer)) + (reverse (function (sequence) sequence)) + (round (function (number &optional number) integer)) + (safe-length (function (t) integer)) + (selected-frame (function () frame)) + (selected-window (function () window)) + (sequencep (function (t) boolean)) + (sin (function (number) float)) + (sqrt (function (number) float)) + (standard-case-table (function () char-table)) + (standard-syntax-table (function () char-table)) + (string (function (&rest fixnum) string)) + (string-as-multibyte (function (string) string)) + (string-as-unibyte (function (string) string)) + (string-equal (function ((or string symbol) (or string symbol)) boolean)) + (string-lessp (function ((or string symbol) (or string symbol)) boolean)) + (string-make-multibyte (function (string) string)) + (string-make-unibyte (function (string) string)) + (string-search (function (string string &optional integer) (or integer null))) + (string-to-char (function (string) fixnum)) + (string-to-multibyte (function (string) string)) + (string-to-number (function (string &optional integer) number)) + (string-to-syntax (function (string) cons)) + (string< (function ((or string symbol) (or string symbol)) boolean)) + (string= (function ((or string symbol) (or string symbol)) boolean)) + (stringp (function (t) boolean)) + (subrp (function (t) boolean)) + (substring (function ((or string vector) &optional integer integer) (or string vector))) + (sxhash (function (t) integer)) + (sxhash-eq (function (t) integer)) + (sxhash-eql (function (t) integer)) + (sxhash-equal (function (t) integer)) + (symbol-function (function (symbol) t)) + (symbol-name (function (symbol) string)) + (symbol-plist (function (symbol) list)) + (symbol-value (function (symbol) t)) + (symbolp (function (t) boolean)) + (syntax-table (function () char-table)) + (syntax-table-p (function (t) boolean)) + (tan (function (number) float)) + (this-command-keys (function () string)) + (this-command-keys-vector (function () vector)) + (this-single-command-keys (function () vector)) + (this-single-command-raw-keys (function () vector)) + (time-convert (function (t &optional (or boolean integer)) cons)) + (truncate (function (number &optional number) integer)) + (type-of (function (t) symbol)) + (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum + (upcase (function ((or fixnum string)) (or fixnum string))) + (user-full-name (function (&optional integer) (or string null))) + (user-login-name (function (&optional integer) (or string null))) + (user-original-login-name (function (&optional integer) (or string null))) + (user-real-login-name (function () string)) + (user-real-uid (function () integer)) + (user-uid (function () integer)) + (vconcat (function (&rest sequence) vector)) + (vector (function (&rest t) vector)) + (vectorp (function (t) boolean)) + (visible-frame-list (function () list)) + (wholenump (function (t) boolean)) + (window-configuration-p (function (t) boolean)) + (window-live-p (function (t) boolean)) + (window-valid-p (function (t) boolean)) + (windowp (function (t) boolean)) + (zerop (function (number) boolean)) + ;; Type hints + (comp-hint-fixnum (function (t) fixnum)) + (comp-hint-cons (function (t) cons)) + ;; Non returning functions + (throw (function (t t) nil)) + (error (function (string &rest t) nil)) + (signal (function (symbol t) nil))) + "Alist used for type propagation.") + +(defconst comp-known-func-cstr-h + (cl-loop + with comp-ctxt = (make-comp-cstr-ctxt) + with h = (make-hash-table :test #'eq) + for (f type-spec) in comp-known-type-specifiers + for cstr = (comp-type-spec-to-cstr type-spec) + do (puthash f cstr h) + finally return h) + "Hash table function -> `comp-constraint'.") + +(defconst comp-known-predicates + '((arrayp . array) + (atom . atom) + (characterp . fixnum) + (booleanp . boolean) + (bool-vector-p . bool-vector) + (bufferp . buffer) + (natnump . (integer 0 *)) + (char-table-p . char-table) + (hash-table-p . hash-table) + (consp . cons) + (integerp . integer) + (floatp . float) + (functionp . (or function symbol)) + (integerp . integer) + (keywordp . keyword) + (listp . list) + (numberp . number) + (null . null) + (numberp . number) + (sequencep . sequence) + (stringp . string) + (symbolp . symbol) + (vectorp . vector) + (integer-or-marker-p . integer-or-marker)) + "Alist predicate -> matched type specifier.") + +(defconst comp-known-predicates-h + (cl-loop + with comp-ctxt = (make-comp-cstr-ctxt) + with h = (make-hash-table :test #'eq) + for (pred . type-spec) in comp-known-predicates + for cstr = (comp-type-spec-to-cstr type-spec) + do (puthash pred cstr h) + finally return h) + "Hash table function -> `comp-constraint'.") + +(defun comp-known-predicate-p (predicate) + "Return t if PREDICATE is known." + (when (gethash predicate comp-known-predicates-h) t)) + +(defun comp-pred-to-cstr (predicate) + "Given PREDICATE, return the corresponding constraint." + (gethash predicate comp-known-predicates-h)) + +(defconst comp-symbol-values-optimizable '(most-positive-fixnum + most-negative-fixnum) + "Symbol values we can resolve at compile-time.") + +(defconst comp-type-hints '(comp-hint-fixnum + comp-hint-cons) + "List of fake functions used to give compiler hints.") + +(defconst comp-limple-sets '(set + setimm + set-par-to-local + set-args-to-local + set-rest-args-to-local) + "Limple set operators.") + +(defconst comp-limple-assignments `(assume + fetch-handler + ,@comp-limple-sets) + "Limple operators that clobber the first m-var argument.") + +(defconst comp-limple-calls '(call + callref + direct-call + direct-callref) + "Limple operators used to call subrs.") + +(defconst comp-limple-branches '(jump cond-jump) + "Limple operators used for conditional and unconditional branches.") + +(defconst comp-limple-ops `(,@comp-limple-calls + ,@comp-limple-assignments + ,@comp-limple-branches + return) + "All Limple operators.") + +(defvar comp-func nil + "Bound to the current function by most passes.") + +(defvar comp-block nil + "Bound to the current basic block by some passes.") + +(define-error 'native-compiler-error-dyn-func + "can't native compile a non-lexically-scoped function" + 'native-compiler-error) +(define-error 'native-compiler-error-empty-byte + "empty byte compiler output" + 'native-compiler-error) + + +;; Moved early to avoid circularity when comp.el is loaded and +;; `macroexpand' needs to be advised (bug#47049). +;;;###autoload +(defun comp-subr-trampoline-install (subr-name) + "Make SUBR-NAME effectively advice-able when called from native code." + (unless (or (null comp-enable-subr-trampolines) + (memq subr-name native-comp-never-optimize-functions) + (gethash subr-name comp-installed-trampolines-h)) + (cl-assert (subr-primitive-p (symbol-function subr-name))) + (comp--install-trampoline + subr-name + (or (comp-trampoline-search subr-name) + (comp-trampoline-compile subr-name) + ;; Should never happen. + (cl-assert nil))))) + + +(cl-defstruct (comp-vec (:copier nil)) + "A re-sizable vector like object." + (data (make-hash-table :test #'eql) :type hash-table + :documentation "Payload data.") + (beg 0 :type integer) + (end 0 :type natnum)) + +(defsubst comp-vec-copy (vec) + "Return a copy of VEC." + (make-comp-vec :data (copy-hash-table (comp-vec-data vec)) + :beg (comp-vec-beg vec) + :end (comp-vec-end vec))) + +(defsubst comp-vec-length (vec) + "Return the number of elements of VEC." + (- (comp-vec-end vec) (comp-vec-beg vec))) + +(defsubst comp-vec--verify-idx (vec idx) + "Check whether IDX is in bounds for VEC." + (cl-assert (and (< idx (comp-vec-end vec)) + (>= idx (comp-vec-beg vec))))) + +(defsubst comp-vec-aref (vec idx) + "Return the element of VEC whose index is IDX." + (declare (gv-setter (lambda (val) + `(comp-vec--verify-idx ,vec ,idx) + `(puthash ,idx ,val (comp-vec-data ,vec))))) + (comp-vec--verify-idx vec idx) + (gethash idx (comp-vec-data vec))) + +(defsubst comp-vec-append (vec elt) + "Append ELT into VEC. +Returns ELT." + (puthash (comp-vec-end vec) elt (comp-vec-data vec)) + (cl-incf (comp-vec-end vec)) + elt) + +(defsubst comp-vec-prepend (vec elt) + "Prepend ELT into VEC. +Returns ELT." + (puthash (1- (comp-vec-beg vec)) elt (comp-vec-data vec)) + (cl-decf (comp-vec-beg vec)) + elt) + + + +(eval-when-compile + (defconst comp-op-stack-info + (cl-loop with h = (make-hash-table) + for k across byte-code-vector + for v across byte-stack+-info + when k + do (puthash k v h) + finally return h) + "Hash table lap-op -> stack adjustment.")) + +(define-hash-table-test 'comp-imm-equal-test #'equal-including-properties + #'sxhash-equal-including-properties) + +(cl-defstruct comp-data-container + "Data relocation container structure." + (l () :type list + :documentation "Constant objects used by functions.") + (idx (make-hash-table :test 'comp-imm-equal-test) :type hash-table + :documentation "Obj -> position into the previous field.")) + +(cl-defstruct (comp-ctxt (:include comp-cstr-ctxt)) + "Lisp side of the compiler context." + (output nil :type string + :documentation "Target output file-name for the compilation.") + (speed native-comp-speed :type number + :documentation "Default speed for this compilation unit.") + (debug native-comp-debug :type number + :documentation "Default debug level for this compilation unit.") + (driver-options native-comp-driver-options :type list + :documentation "Options for the GCC driver.") + (top-level-forms () :type list + :documentation "List of spilled top level forms.") + (funcs-h (make-hash-table :test #'equal) :type hash-table + :documentation "c-name -> comp-func.") + (sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table + :documentation "symbol-function -> c-name. +This is only for optimizing intra CU calls at speed 3.") + (byte-func-to-func-h (make-hash-table :test #'equal) :type hash-table + :documentation "byte-function -> comp-func. +Needed to replace immediate byte-compiled lambdas with the compiled reference.") + (lambda-fixups-h (make-hash-table :test #'equal) :type hash-table + :documentation "Hash table byte-func -> mvar to fixup.") + (function-docs (make-hash-table :test #'eql) :type (or hash-table vector) + :documentation "Documentation index -> documentation") + (d-default (make-comp-data-container) :type comp-data-container + :documentation "Standard data relocated in use by functions.") + (d-impure (make-comp-data-container) :type comp-data-container + :documentation "Relocated data that cannot be moved into pure space. +This is typically for top-level forms other than defun.") + (d-ephemeral (make-comp-data-container) :type comp-data-container + :documentation "Relocated data not necessary after load.") + (with-late-load nil :type boolean + :documentation "When non-nil support late load.")) + +(cl-defstruct comp-args-base + (min nil :type integer + :documentation "Minimum number of arguments allowed.")) + +(cl-defstruct (comp-args (:include comp-args-base)) + (max nil :type integer + :documentation "Maximum number of arguments allowed.")) + +(cl-defstruct (comp-nargs (:include comp-args-base)) + "Describe args when the function signature is of kind: +(ptrdiff_t nargs, Lisp_Object *args)." + (nonrest nil :type integer + :documentation "Number of non rest arguments.") + (rest nil :type boolean + :documentation "t if rest argument is present.")) + +(cl-defstruct (comp-block (:copier nil) + (:constructor nil)) + "A base class for basic blocks." + (name nil :type symbol) + (insns () :type list + :documentation "List of instructions.") + (closed nil :type boolean + :documentation "t if closed.") + ;; All the following are for SSA and CGF analysis. + ;; Keep in sync with `comp-clean-ssa'!! + (in-edges () :type list + :documentation "List of incoming edges.") + (out-edges () :type list + :documentation "List of out-coming edges.") + (idom nil :type (or null comp-block) + :documentation "Immediate dominator.") + (df (make-hash-table) :type (or null hash-table) + :documentation "Dominance frontier set. Block-name -> block") + (post-num nil :type (or null number) + :documentation "Post order number.") + (final-frame nil :type (or null comp-vec) + :documentation "This is a copy of the frame when leaving the block. +Is in use to help the SSA rename pass.")) + +(cl-defstruct (comp-block-lap (:copier nil) + (:include comp-block) + (:constructor make--comp-block-lap + (addr sp name))) ; Positional + "A basic block created from lap (real code)." + ;; These two slots are used during limplification. + (sp nil :type number + :documentation "When non-nil indicates the sp value while entering +into it.") + (addr nil :type number + :documentation "Start block LAP address.") + (non-ret-insn nil :type list + :documentation "Insn known to perform a non local exit. +`comp-fwprop' may identify and store here basic blocks performing +non local exits and mark it rewrite it later.") + (no-ret nil :type boolean + :documentation "t when the block is known to perform a +non local exit (ends with an `unreachable' insn).")) + +(cl-defstruct (comp-latch (:copier nil) + (:include comp-block)) + "A basic block for a latch loop.") + +(cl-defstruct (comp-block-cstr (:copier nil) + (:include comp-block)) + "A basic block holding only constraints.") + +(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) + "An edge connecting two basic blocks." + (src nil :type (or null comp-block)) + (dst nil :type (or null comp-block)) + (number nil :type number + :documentation "The index number corresponding to this edge in the + edge hash.")) + +(defun make-comp-edge (&rest args) + "Create a `comp-edge' with basic blocks SRC and DST." + (let ((n (funcall (comp-func-edge-cnt-gen comp-func)))) + (puthash + n + (apply #'make--comp-edge :number n args) + (comp-func-edges-h comp-func)))) + +(defun comp-block-preds (basic-block) + "Return the list of predecessors of BASIC-BLOCK." + (mapcar #'comp-edge-src (comp-block-in-edges basic-block))) + +(defun comp-gen-counter () + "Return a sequential number generator." + (let ((n -1)) + (lambda () + (cl-incf n)))) + +(cl-defstruct (comp-func (:copier nil)) + "LIMPLE representation of a function." + (name nil :type symbol + :documentation "Function symbol name. Nil indicates anonymous.") + (c-name nil :type string + :documentation "The function name in the native world.") + (byte-func nil + :documentation "Byte-compiled version.") + (doc nil :type string + :documentation "Doc string.") + (int-spec nil :type list + :documentation "Interactive form.") + (lap () :type list + :documentation "LAP assembly representation.") + (ssa-status nil :type symbol + :documentation "SSA status either: 'nil', 'dirty' or 't'. +Once in SSA form this *must* be set to 'dirty' every time the topology of the +CFG is mutated by a pass.") + (frame-size nil :type integer) + (vframe-size 0 :type integer) + (blocks (make-hash-table :test #'eq) :type hash-table + :documentation "Basic block symbol -> basic block.") + (lap-block (make-hash-table :test #'equal) :type hash-table + :documentation "LAP label -> LIMPLE basic block name.") + (edges-h (make-hash-table) :type hash-table + :documentation "Hash edge-num -> edge connecting basic two blocks.") + (block-cnt-gen (funcall #'comp-gen-counter) :type function + :documentation "Generates block numbers.") + (edge-cnt-gen (funcall #'comp-gen-counter) :type function + :documentation "Generates edges numbers.") + (has-non-local nil :type boolean + :documentation "t if non local jumps are present.") + (speed nil :type number + :documentation "Optimization level (see `native-comp-speed').") + (pure nil :type boolean + :documentation "t if pure nil otherwise.") + (type nil :type (or null comp-mvar) + :documentation "Mvar holding the derived return type.")) + +(cl-defstruct (comp-func-l (:include comp-func)) + "Lexically-scoped function." + (args nil :type comp-args-base + :documentation "Argument specification of the function")) + +(cl-defstruct (comp-func-d (:include comp-func)) + "Dynamically-scoped function." + (lambda-list nil :type list + :documentation "Original lambda-list.")) + +(cl-defstruct (comp-mvar (:constructor make--comp-mvar) + (:include comp-cstr)) + "A meta-variable being a slot in the meta-stack." + (id nil :type (or null number) + :documentation "Unique id when in SSA form.") + (slot nil :type (or fixnum symbol) + :documentation "Slot number in the array if a number or + 'scratch' for scratch slot.")) + +(defun comp-mvar-type-hint-match-p (mvar type-hint) + "Match MVAR against TYPE-HINT. +In use by the back-end." + (cl-ecase type-hint + (cons (comp-cstr-cons-p mvar)) + (fixnum (comp-cstr-fixnum-p mvar)))) + + + +(defun comp-ensure-native-compiler () + "Make sure Emacs has native compiler support and libgccjit can be loaded. +Signal an error otherwise. +To be used by all entry points." + (cond + ((null (featurep 'native-compile)) + (error "Emacs was not compiled with native compiler support (--with-native-compilation)")) + ((null (native-comp-available-p)) + (error "Cannot find libgccjit library")))) + +(defun comp-equality-fun-p (function) + "Equality functions predicate for FUNCTION." + (when (memq function '(eq eql equal)) t)) + +(defun comp-arithm-cmp-fun-p (function) + "Predicate for arithmetic comparison functions." + (when (memq function '(= > < >= <=)) t)) + +(defun comp-set-op-p (op) + "Assignment predicate for OP." + (when (memq op comp-limple-sets) t)) + +(defun comp-assign-op-p (op) + "Assignment predicate for OP." + (when (memq op comp-limple-assignments) t)) + +(defun comp-call-op-p (op) + "Call predicate for OP." + (when (memq op comp-limple-calls) t)) + +(defun comp-branch-op-p (op) + "Branch predicate for OP." + (when (memq op comp-limple-branches) t)) + +(defsubst comp-limple-insn-call-p (insn) + "Limple INSN call predicate." + (comp-call-op-p (car-safe insn))) + +(defun comp-type-hint-p (func) + "Type-hint predicate for function name FUNC." + (when (memq func comp-type-hints) t)) + +(defun comp-func-unique-in-cu-p (func) + "Return t if FUNC is known to be unique in the current compilation unit." + (if (symbolp func) + (cl-loop with h = (make-hash-table :test #'eq) + for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt) + for name = (comp-func-name f) + when (gethash name h) + return nil + do (puthash name t h) + finally return t) + t)) + +(defsubst comp-symbol-func-to-fun (symbol-funcion) + "Given a function called SYMBOL-FUNCION return its `comp-func'." + (gethash (gethash symbol-funcion (comp-ctxt-sym-to-c-name-h + comp-ctxt)) + (comp-ctxt-funcs-h comp-ctxt))) + +(defun comp-function-pure-p (f) + "Return t if F is pure." + (or (get f 'pure) + (when-let ((func (comp-symbol-func-to-fun f))) + (comp-func-pure func)))) + +(defun comp-alloc-class-to-container (alloc-class) + "Given ALLOC-CLASS, return the data container for the current context. +Assume allocation class 'd-default as default." + (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt)) + +(defsubst comp-add-const-to-relocs (obj) + "Keep track of OBJ into the ctxt relocations." + (puthash obj t (comp-data-container-idx (comp-alloc-class-to-container + comp-curr-allocation-class)))) + + +;;; Log routines. + +(defconst comp-limple-lock-keywords + `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face) + (,(rx "#(" (group-n 1 "mvar")) + (1 font-lock-function-name-face)) + (,(rx bol "(" (group-n 1 "phi")) + (1 font-lock-variable-name-face)) + (,(rx bol "(" (group-n 1 (or "return" "unreachable"))) + (1 font-lock-warning-face)) + (,(rx (group-n 1 (or "entry" + (seq (or "entry_" "entry_fallback_" "bb_") + (1+ num) (? (or "_latch" + (seq "_cstrs_" (1+ num)))))))) + (1 font-lock-constant-face)) + (,(rx-to-string + `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops))))) + (1 font-lock-keyword-face))) + "Highlights used by `native-comp-limple-mode'.") + +(define-derived-mode native-comp-limple-mode fundamental-mode "LIMPLE" + "Syntax-highlight LIMPLE IR." + (setf font-lock-defaults '(comp-limple-lock-keywords))) + +(cl-defun comp-log (data &optional (level 1) quoted) + "Log DATA at LEVEL. +LEVEL is a number from 1-3, and defaults to 1; if it is less +than `native-comp-verbose', do nothing. If `noninteractive', log +with `message'. Otherwise, log with `comp-log-to-buffer'." + (when (>= native-comp-verbose level) + (if noninteractive + (cl-typecase data + (atom (message "%s" data)) + (t (dolist (elem data) + (message "%s" elem)))) + (comp-log-to-buffer data quoted)))) + +(cl-defun comp-log-to-buffer (data &optional quoted) + "Log DATA to `comp-log-buffer-name'." + (let* ((print-f (if quoted #'prin1 #'princ)) + (log-buffer + (or (get-buffer comp-log-buffer-name) + (with-current-buffer (get-buffer-create comp-log-buffer-name) + (setf buffer-read-only t) + (current-buffer)))) + (log-window (get-buffer-window log-buffer)) + (inhibit-read-only t) + at-end-p) + (with-current-buffer log-buffer + (unless (eq major-mode 'native-comp-limple-mode) + (native-comp-limple-mode)) + (when (= (point) (point-max)) + (setf at-end-p t)) + (save-excursion + (goto-char (point-max)) + (cl-typecase data + (atom (funcall print-f data log-buffer)) + (t (dolist (elem data) + (funcall print-f elem log-buffer) + (insert "\n")))) + (insert "\n")) + (when (and at-end-p log-window) + ;; When log window's point is at the end, follow the tail. + (with-selected-window log-window + (goto-char (point-max))))))) + +(defun comp-prettyformat-mvar (mvar) + (format "#(mvar %s %s %S)" + (comp-mvar-id mvar) + (comp-mvar-slot mvar) + (comp-cstr-to-type-spec mvar))) + +(defun comp-prettyformat-insn (insn) + (cl-typecase insn + (comp-mvar (comp-prettyformat-mvar insn)) + (atom (prin1-to-string insn)) + (cons (concat "(" (mapconcat #'comp-prettyformat-insn insn " ") ")")))) + +(defun comp-log-func (func verbosity) + "Log function FUNC at VERBOSITY. +VERBOSITY is a number between 0 and 3." + (when (>= native-comp-verbose verbosity) + (comp-log (format "\nFunction: %s\n" (comp-func-name func)) verbosity) + (cl-loop + for block-name being each hash-keys of (comp-func-blocks func) + using (hash-value bb) + do (comp-log (concat "<" (symbol-name block-name) ">") verbosity) + (cl-loop + for insn in (comp-block-insns bb) + do (comp-log (comp-prettyformat-insn insn) verbosity))))) + +(defun comp-log-edges (func) + "Log edges in FUNC." + (let ((edges (comp-func-edges-h func))) + (comp-log (format "\nEdges in function: %s\n" + (comp-func-name func)) + 2) + (maphash (lambda (_ e) + (comp-log (format "n: %d src: %s dst: %s\n" + (comp-edge-number e) + (comp-block-name (comp-edge-src e)) + (comp-block-name (comp-edge-dst e))) + 2)) + edges))) + + + +(defmacro comp-loop-insn-in-block (basic-block &rest body) + "Loop over all insns in BASIC-BLOCK executing BODY. +Inside BODY, `insn' and `insn-cell'can be used to read or set the +current instruction or its cell." + (declare (debug (form body)) + (indent defun)) + `(cl-symbol-macrolet ((insn (car insn-cell))) + (let ((insn-cell (comp-block-insns ,basic-block))) + (while insn-cell + ,@body + (setf insn-cell (cdr insn-cell)))))) + +;;; spill-lap pass specific code. + +(defun comp-lex-byte-func-p (f) + "Return t if F is a lexically-scoped byte compiled function." + (and (byte-code-function-p f) + (fixnump (aref f 0)))) + +(defun comp-spill-decl-spec (function-name spec) + "Return the declared specifier SPEC for FUNCTION-NAME." + (plist-get (cdr (assq function-name byte-to-native-plist-environment)) + spec)) + +(defun comp-spill-speed (function-name) + "Return the speed for FUNCTION-NAME." + (or (comp-spill-decl-spec function-name 'speed) + (comp-ctxt-speed comp-ctxt))) + +;; Autoloaded as might be used by `disassemble-internal'. +;;;###autoload +(defun comp-c-func-name (name prefix &optional first) + "Given NAME, return a name suitable for the native code. +Add PREFIX in front of it. If FIRST is not nil, pick the first +available name ignoring compilation context and potential name +clashes." + ;; Unfortunately not all symbol names are valid as C function names... + ;; Nassi's algorithm here: + (let* ((orig-name (if (symbolp name) (symbol-name name) name)) + (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0) + for j from 0 by 2 + for i across orig-name + for byte = (format "%x" i) + do (aset str j (aref byte 0)) + (aset str (1+ j) (aref byte 1)) + finally return str)) + (human-readable (string-replace + "-" "_" orig-name)) + (human-readable (replace-regexp-in-string + (rx (not (any "0-9a-z_"))) "" human-readable))) + (if (null first) + ;; Prevent C namespace conflicts. + (cl-loop + with h = (comp-ctxt-funcs-h comp-ctxt) + for i from 0 + for c-sym = (concat prefix crypted "_" human-readable "_" + (number-to-string i)) + unless (gethash c-sym h) + return c-sym) + ;; When called out of a compilation context (ex disassembling) + ;; pick the first one. + (concat prefix crypted "_" human-readable "_0")))) + +(defun comp-decrypt-arg-list (x function-name) + "Decrypt argument list X for FUNCTION-NAME." + (unless (fixnump x) + (signal 'native-compiler-error-dyn-func function-name)) + (let ((rest (not (= (logand x 128) 0))) + (mandatory (logand x 127)) + (nonrest (ash x -8))) + (if (and (null rest) + (< nonrest 9)) ;; SUBR_MAX_ARGS + (make-comp-args :min mandatory + :max nonrest) + (make-comp-nargs :min mandatory + :nonrest nonrest + :rest rest)))) + +(defsubst comp-byte-frame-size (byte-compiled-func) + "Return the frame size to be allocated for BYTE-COMPILED-FUNC." + (aref byte-compiled-func 3)) + +(defun comp-add-func-to-ctxt (func) + "Add FUNC to the current compiler context." + (let ((name (comp-func-name func)) + (c-name (comp-func-c-name func))) + (puthash name c-name (comp-ctxt-sym-to-c-name-h comp-ctxt)) + (puthash c-name func (comp-ctxt-funcs-h comp-ctxt)))) + +(cl-defgeneric comp-spill-lap-function (input) + "Byte-compile INPUT and spill lap for further stages.") + +(cl-defmethod comp-spill-lap-function ((function-name symbol)) + "Byte-compile FUNCTION-NAME, spilling data from the byte compiler." + (unless (comp-ctxt-output comp-ctxt) + (setf (comp-ctxt-output comp-ctxt) + (make-temp-file (comp-c-func-name function-name "freefn-") + nil ".eln"))) + (let* ((f (symbol-function function-name)) + (c-name (comp-c-func-name function-name "F")) + (func (make-comp-func-l :name function-name + :c-name c-name + :doc (documentation f t) + :int-spec (interactive-form f) + :speed (comp-spill-speed function-name) + :pure (comp-spill-decl-spec function-name + 'pure)))) + (when (byte-code-function-p f) + (signal 'native-compiler-error + "can't native compile an already byte-compiled function")) + (setf (comp-func-byte-func func) + (byte-compile (comp-func-name func))) + (let ((lap (byte-to-native-lambda-lap + (gethash (aref (comp-func-byte-func func) 1) + byte-to-native-lambdas-h)))) + (cl-assert lap) + (comp-log lap 2 t) + (let ((arg-list (aref (comp-func-byte-func func) 0))) + (setf (comp-func-l-args func) + (comp-decrypt-arg-list arg-list function-name) + (comp-func-lap func) + lap + (comp-func-frame-size func) + (comp-byte-frame-size (comp-func-byte-func func)))) + (setf (comp-ctxt-top-level-forms comp-ctxt) + (list (make-byte-to-native-func-def :name function-name + :c-name c-name))) + (comp-add-func-to-ctxt func)))) + +(cl-defmethod comp-spill-lap-function ((form list)) + "Byte-compile FORM, spilling data from the byte compiler." + (unless (eq (car-safe form) 'lambda) + (signal 'native-compiler-error + "Cannot native-compile, form is not a lambda")) + (unless (comp-ctxt-output comp-ctxt) + (setf (comp-ctxt-output comp-ctxt) + (make-temp-file "comp-lambda-" nil ".eln"))) + (let* ((byte-code (byte-compile form)) + (c-name (comp-c-func-name "anonymous-lambda" "F")) + (func (if (comp-lex-byte-func-p byte-code) + (make-comp-func-l :c-name c-name + :doc (documentation form t) + :int-spec (interactive-form form) + :speed (comp-ctxt-speed comp-ctxt)) + (make-comp-func-d :c-name c-name + :doc (documentation form t) + :int-spec (interactive-form form) + :speed (comp-ctxt-speed comp-ctxt))))) + (let ((lap (byte-to-native-lambda-lap + (gethash (aref byte-code 1) + byte-to-native-lambdas-h)))) + (cl-assert lap) + (comp-log lap 2 t) + (if (comp-func-l-p func) + (setf (comp-func-l-args func) + (comp-decrypt-arg-list (aref byte-code 0) byte-code)) + (setf (comp-func-d-lambda-list func) (cadr form))) + (setf (comp-func-lap func) lap + (comp-func-frame-size func) (comp-byte-frame-size + byte-code)) + (setf (comp-func-byte-func func) byte-code + (comp-ctxt-top-level-forms comp-ctxt) + (list (make-byte-to-native-func-def :name '--anonymous-lambda + :c-name c-name))) + (comp-add-func-to-ctxt func)))) + +(defun comp-intern-func-in-ctxt (_ obj) + "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'." + (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) + (let* ((lap (byte-to-native-lambda-lap obj)) + (top-l-form (cl-loop + for form in (comp-ctxt-top-level-forms comp-ctxt) + when (and (byte-to-native-func-def-p form) + (eq (byte-to-native-func-def-byte-func form) + byte-func)) + return form)) + (name (when top-l-form + (byte-to-native-func-def-name top-l-form))) + (c-name (comp-c-func-name (or name "anonymous-lambda") "F")) + (func (if (comp-lex-byte-func-p byte-func) + (make-comp-func-l + :args (comp-decrypt-arg-list (aref byte-func 0) + name)) + (make-comp-func-d :lambda-list (aref byte-func 0))))) + (setf (comp-func-name func) name + (comp-func-byte-func func) byte-func + (comp-func-doc func) (documentation byte-func t) + (comp-func-int-spec func) (interactive-form byte-func) + (comp-func-c-name func) c-name + (comp-func-lap func) lap + (comp-func-frame-size func) (comp-byte-frame-size byte-func) + (comp-func-speed func) (comp-spill-speed name) + (comp-func-pure func) (comp-spill-decl-spec name 'pure)) + + ;; Store the c-name to have it retrievable from + ;; `comp-ctxt-top-level-forms'. + (when top-l-form + (setf (byte-to-native-func-def-c-name top-l-form) c-name)) + (unless name + (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) + (comp-add-func-to-ctxt func) + (comp-log (format "Function %s:\n" name) 1) + (comp-log lap 1 t)))) + +(cl-defmethod comp-spill-lap-function ((filename string)) + "Byte-compile FILENAME, spilling data from the byte compiler." + (byte-compile-file filename) + (when (or (null byte-native-qualities) + (alist-get 'no-native-compile byte-native-qualities)) + (throw 'no-native-compile nil)) + (unless byte-to-native-top-level-forms + (signal 'native-compiler-error-empty-byte filename)) + (unless (comp-ctxt-output comp-ctxt) + (setf (comp-ctxt-output comp-ctxt) (comp-el-to-eln-filename + filename + (or native-compile-target-directory + (when byte+native-compile + (car (last native-comp-eln-load-path))))))) + (setf (comp-ctxt-speed comp-ctxt) (alist-get 'native-comp-speed + byte-native-qualities) + (comp-ctxt-debug comp-ctxt) (alist-get 'native-comp-debug + byte-native-qualities) + (comp-ctxt-driver-options comp-ctxt) (alist-get 'native-comp-driver-options + byte-native-qualities) + (comp-ctxt-top-level-forms comp-ctxt) + (cl-loop + for form in (reverse byte-to-native-top-level-forms) + collect + (if (and (byte-to-native-func-def-p form) + (eq -1 + (comp-spill-speed (byte-to-native-func-def-name form)))) + (let ((byte-code (byte-to-native-func-def-byte-func form))) + (remhash byte-code byte-to-native-lambdas-h) + (make-byte-to-native-top-level + :form `(defalias + ',(byte-to-native-func-def-name form) + ,byte-code + nil) + :lexical (comp-lex-byte-func-p byte-code))) + form))) + (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h)) + +(defun comp-spill-lap (input) + "Byte-compile and spill the LAP representation for INPUT. +If INPUT is a symbol, it is the function-name to be compiled. +If INPUT is a string, it is the filename to be compiled." + (let ((byte-native-compiling t) + (byte-to-native-lambdas-h (make-hash-table :test #'eq)) + (byte-to-native-top-level-forms ()) + (byte-to-native-plist-environment ())) + (comp-spill-lap-function input))) + + +;;; Limplification pass specific code. + +(cl-defstruct (comp-limplify (:copier nil)) + "Support structure used during function limplification." + (frame nil :type (or null comp-vec) + :documentation "Meta-stack used to flat LAP.") + (curr-block nil :type comp-block + :documentation "Current block being limplified.") + (sp -1 :type number + :documentation "Current stack pointer while walking LAP. +Points to the next slot to be filled.") + (pc 0 :type number + :documentation "Current program counter while walking LAP.") + (label-to-addr nil :type hash-table + :documentation "LAP hash table -> address.") + (pending-blocks () :type list + :documentation "List of blocks waiting for limplification.")) + +(defconst comp-lap-eob-ops + '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop byte-return byte-pushcatch + byte-switch byte-pushconditioncase) + "LAP end of basic blocks op codes.") + +(defun comp-lap-eob-p (inst) + "Return t if INST closes the current basic blocks, nil otherwise." + (when (memq (car inst) comp-lap-eob-ops) + t)) + +(defun comp-lap-fall-through-p (inst) + "Return t if INST falls through, nil otherwise." + (when (not (memq (car inst) '(byte-goto byte-return))) + t)) + +(defsubst comp-sp () + "Current stack pointer." + (declare (gv-setter (lambda (val) + `(setf (comp-limplify-sp comp-pass) ,val)))) + (comp-limplify-sp comp-pass)) + +(defmacro comp-with-sp (sp &rest body) + "Execute BODY setting the stack pointer to SP. +Restore the original value afterwards." + (declare (debug (form body)) + (indent defun)) + (let ((sym (gensym))) + `(let ((,sym (comp-sp))) + (setf (comp-sp) ,sp) + (progn ,@body) + (setf (comp-sp) ,sym)))) + +(defsubst comp-slot-n (n) + "Slot N into the meta-stack." + (comp-vec-aref (comp-limplify-frame comp-pass) n)) + +(defsubst comp-slot () + "Current slot into the meta-stack pointed by sp." + (comp-slot-n (comp-sp))) + +(defsubst comp-slot+1 () + "Slot into the meta-stack pointed by sp + 1." + (comp-slot-n (1+ (comp-sp)))) + +(defsubst comp-label-to-addr (label) + "Find the address of LABEL." + (or (gethash label (comp-limplify-label-to-addr comp-pass)) + (signal 'native-ice (list "label not found" label)))) + +(defsubst comp-mark-curr-bb-closed () + "Mark the current basic block as closed." + (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)) + +(defun comp-bb-maybe-add (lap-addr &optional sp) + "If necessary create a pending basic block for LAP-ADDR with stack depth SP. +The basic block is returned regardless it was already declared or not." + (let ((bb (or (cl-loop ; See if the block was already limplified. + for bb being the hash-value in (comp-func-blocks comp-func) + when (and (comp-block-lap-p bb) + (equal (comp-block-lap-addr bb) lap-addr)) + return bb) + (cl-find-if (lambda (bb) ; Look within the pendings blocks. + (and (comp-block-lap-p bb) + (= (comp-block-lap-addr bb) lap-addr))) + (comp-limplify-pending-blocks comp-pass))))) + (if bb + (progn + (unless (or (null sp) (= sp (comp-block-lap-sp bb))) + (signal 'native-ice (list "incoherent stack pointers" + sp (comp-block-lap-sp bb)))) + bb) + (car (push (make--comp-block-lap lap-addr sp (comp-new-block-sym)) + (comp-limplify-pending-blocks comp-pass)))))) + +(defsubst comp-call (func &rest args) + "Emit a call for function FUNC with ARGS." + `(call ,func ,@args)) + +(defun comp-callref (func nargs stack-off) + "Emit a call using narg abi for FUNC. +NARGS is the number of arguments. +STACK-OFF is the index of the first slot frame involved." + `(callref ,func ,@(cl-loop repeat nargs + for sp from stack-off + collect (comp-slot-n sp)))) + +(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) + "`comp-mvar' initializer." + (let ((mvar (make--comp-mvar :slot slot))) + (when const-vld + (comp-add-const-to-relocs constant) + (setf (comp-cstr-imm mvar) constant)) + (when type + (setf (comp-mvar-typeset mvar) (list type))) + mvar)) + +(defun comp-new-frame (size vsize &optional ssa) + "Return a clean frame of meta variables of size SIZE and VSIZE. +If SSA is non-nil, populate it with m-var in ssa form." + (cl-loop with v = (make-comp-vec :beg (- vsize) :end size) + for i from (- vsize) below size + for mvar = (if ssa + (make-comp-ssa-mvar :slot i) + (make-comp-mvar :slot i)) + do (setf (comp-vec-aref v i) mvar) + finally return v)) + +(defun comp-emit (insn) + "Emit INSN into basic block BB." + (let ((bb (comp-limplify-curr-block comp-pass))) + (cl-assert (not (comp-block-closed bb))) + (push insn (comp-block-insns bb)))) + +(defun comp-emit-set-call (call) + "Emit CALL assigning the result to the current slot frame. +If the callee function is known to have a return type, propagate it." + (cl-assert call) + (comp-emit (list 'set (comp-slot) call))) + +(defun comp-copy-slot (src-n &optional dst-n) + "Set slot number DST-N to slot number SRC-N as source. +If DST-N is specified, use it; otherwise assume it to be the current slot." + (comp-with-sp (or dst-n (comp-sp)) + (let ((src-slot (comp-slot-n src-n))) + (cl-assert src-slot) + (comp-emit `(set ,(comp-slot) ,src-slot))))) + +(defsubst comp-emit-annotation (str) + "Emit annotation STR." + (comp-emit `(comment ,str))) + +(defsubst comp-emit-setimm (val) + "Set constant VAL to current slot." + (comp-add-const-to-relocs val) + ;; Leave relocation index nil on purpose, will be fixed-up in final + ;; by `comp-finalize-relocs'. + (comp-emit `(setimm ,(comp-slot) ,val))) + +(defun comp-make-curr-block (block-name entry-sp &optional addr) + "Create a basic block with BLOCK-NAME and set it as current block. +ENTRY-SP is the sp value when entering. +Add block to the current function and return it." + (let ((bb (make--comp-block-lap addr entry-sp block-name))) + (setf (comp-limplify-curr-block comp-pass) bb + (comp-limplify-pc comp-pass) addr + (comp-limplify-sp comp-pass) (when (comp-block-lap-p bb) + (comp-block-lap-sp bb))) + (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) + bb)) + +(defun comp-latch-make-fill (target) + "Create a latch pointing to TARGET and fill it. +Return the created latch." + (let ((latch (make-comp-latch :name (comp-new-block-sym "latch"))) + (curr-bb (comp-limplify-curr-block comp-pass))) + ;; See `comp-make-curr-block'. + (setf (comp-limplify-curr-block comp-pass) latch) + (when (< (comp-func-speed comp-func) 3) + ;; At speed 3 the programmer is responsible to manually + ;; place `comp-maybe-gc-or-quit'. + (comp-emit '(call comp-maybe-gc-or-quit))) + ;; See `comp-emit-uncond-jump'. + (comp-emit `(jump ,(comp-block-name target))) + (comp-mark-curr-bb-closed) + (puthash (comp-block-name latch) latch (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) curr-bb) + latch)) + +(defun comp-emit-uncond-jump (lap-label) + "Emit an unconditional branch to LAP-LABEL." + (cl-destructuring-bind (label-num . stack-depth) lap-label + (when stack-depth + (cl-assert (= (1- stack-depth) (comp-sp)))) + (let* ((target-addr (comp-label-to-addr label-num)) + (target (comp-bb-maybe-add target-addr + (comp-sp))) + (latch (when (< target-addr (comp-limplify-pc comp-pass)) + (comp-latch-make-fill target))) + (eff-target-name (comp-block-name (or latch target)))) + (comp-emit `(jump ,eff-target-name)) + (comp-mark-curr-bb-closed)))) + +(defun comp-emit-cond-jump (a b target-offset lap-label negated) + "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. +TARGET-OFFSET is the positive offset on the SP when branching to the target +block. +If NEGATED is non null, negate the tested condition. +Return value is the fall-through block name." + (cl-destructuring-bind (label-num . label-sp) lap-label + (let* ((bb (comp-block-name (comp-bb-maybe-add + (1+ (comp-limplify-pc comp-pass)) + (comp-sp)))) ; Fall through block. + (target-sp (+ target-offset (comp-sp))) + (target-addr (comp-label-to-addr label-num)) + (target (comp-bb-maybe-add target-addr target-sp)) + (latch (when (< target-addr (comp-limplify-pc comp-pass)) + (comp-latch-make-fill target))) + (eff-target-name (comp-block-name (or latch target)))) + (when label-sp + (cl-assert (= (1- label-sp) (+ target-offset (comp-sp))))) + (comp-emit (if negated + (list 'cond-jump a b bb eff-target-name) + (list 'cond-jump a b eff-target-name bb))) + (comp-mark-curr-bb-closed) + bb))) + +(defun comp-emit-handler (lap-label handler-type) + "Emit a nonlocal-exit handler to LAP-LABEL of type HANDLER-TYPE." + (cl-destructuring-bind (label-num . label-sp) lap-label + (cl-assert (= (- label-sp 2) (comp-sp))) + (setf (comp-func-has-non-local comp-func) t) + (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp-sp))) + (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) + (1+ (comp-sp)))) + (pop-bb (make--comp-block-lap nil (comp-sp) (comp-new-block-sym)))) + (comp-emit (list 'push-handler + handler-type + (comp-slot+1) + (comp-block-name pop-bb) + (comp-block-name guarded-bb))) + (comp-mark-curr-bb-closed) + ;; Emit the basic block to pop the handler if we got the non local. + (puthash (comp-block-name pop-bb) pop-bb (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) pop-bb) + (comp-emit `(fetch-handler ,(comp-slot+1))) + (comp-emit `(jump ,(comp-block-name handler-bb))) + (comp-mark-curr-bb-closed)))) + +(defun comp-limplify-listn (n) + "Limplify list N." + (comp-with-sp (+ (comp-sp) n -1) + (comp-emit-set-call (comp-call 'cons + (comp-slot) + (make-comp-mvar :constant nil)))) + (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp) + do (comp-with-sp sp + (comp-emit-set-call (comp-call 'cons + (comp-slot) + (comp-slot+1)))))) + +(defun comp-new-block-sym (&optional postfix) + "Return a unique symbol postfixing POSTFIX naming the next new basic block." + (intern (format (if postfix "bb_%s_%s" "bb_%s") + (funcall (comp-func-block-cnt-gen comp-func)) + postfix))) + +(defun comp-fill-label-h () + "Fill label-to-addr hash table for the current function." + (setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql)) + (cl-loop for insn in (comp-func-lap comp-func) + for addr from 0 + do (pcase insn + (`(TAG ,label . ,_) + (puthash label addr (comp-limplify-label-to-addr comp-pass)))))) + +(defun comp-jump-table-optimizable (jmp-table) + "Return t if JMP-TABLE can be optimized out." + (cl-loop + with labels = (cl-loop for target-label being each hash-value of jmp-table + collect target-label) + with x = (car labels) + for l in (cdr-safe labels) + unless (= l x) + return nil + finally return t)) + +(defun comp-emit-switch (var last-insn) + "Emit a Limple for a lap jump table given VAR and LAST-INSN." + ;; FIXME this not efficient for big jump tables. We should have a second + ;; strategy for this case. + (pcase last-insn + (`(setimm ,_ ,jmp-table) + (unless (comp-jump-table-optimizable jmp-table) + (cl-loop + for test being each hash-keys of jmp-table + using (hash-value target-label) + with len = (hash-table-count jmp-table) + with test-func = (hash-table-test jmp-table) + for n from 1 + for last = (= n len) + for m-test = (make-comp-mvar :constant test) + for target-name = (comp-block-name (comp-bb-maybe-add + (comp-label-to-addr target-label) + (comp-sp))) + for ff-bb = (if last + (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp-sp)) + (make--comp-block-lap nil + (comp-sp) + (comp-new-block-sym))) + for ff-bb-name = (comp-block-name ff-bb) + if (eq test-func 'eq) + do (comp-emit (list 'cond-jump var m-test target-name ff-bb-name)) + else + ;; Store the result of the comparison into the scratch slot before + ;; emitting the conditional jump. + do (comp-emit (list 'set (make-comp-mvar :slot 'scratch) + (comp-call test-func var m-test))) + (comp-emit (list 'cond-jump + (make-comp-mvar :slot 'scratch) + (make-comp-mvar :constant nil) + ff-bb-name target-name)) + unless last + ;; All fall through are artificially created here except the last one. + do (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) ff-bb)))) + (_ (signal 'native-ice + "missing previous setimm while creating a switch")))) + +(defun comp-emit-set-call-subr (subr-name sp-delta) + "Emit a call for SUBR-NAME. +SP-DELTA is the stack adjustment." + (let ((subr (symbol-function subr-name)) + (nargs (1+ (- sp-delta)))) + (let* ((arity (func-arity subr)) + (minarg (car arity)) + (maxarg (cdr arity))) + (when (eq maxarg 'unevalled) + (signal 'native-ice (list "subr contains unevalled args" subr-name))) + (if (eq maxarg 'many) + ;; callref case. + (comp-emit-set-call (comp-callref subr-name nargs (comp-sp))) + ;; Normal call. + (unless (and (>= maxarg nargs) (<= minarg nargs)) + (signal 'native-ice + (list "incoherent stack adjustment" nargs maxarg minarg))) + (let* ((subr-name subr-name) + (slots (cl-loop for i from 0 below maxarg + collect (comp-slot-n (+ i (comp-sp)))))) + (comp-emit-set-call (apply #'comp-call (cons subr-name slots)))))))) + +(eval-when-compile + (defun comp-op-to-fun (x) + "Given the LAP op strip \"byte-\" to have the subr name." + (intern (replace-regexp-in-string "byte-" "" x))) + + (defun comp-body-eff (body op-name sp-delta) + "Given the original BODY, compute the effective one. +When BODY is `auto', guess function name from the LAP byte-code +name. Otherwise expect lname fnname." + (pcase (car body) + ('auto + `((comp-emit-set-call-subr ',(comp-op-to-fun op-name) ,sp-delta))) + ((pred symbolp) + `((comp-emit-set-call-subr ',(car body) ,sp-delta))) + (_ body)))) + +(defmacro comp-op-case (&rest cases) + "Expand CASES into the corresponding `pcase' expansion. +This is responsible for generating the proper stack adjustment, when known, +and the annotation emission." + (declare (debug (body)) + (indent defun)) + `(pcase op + ,@(cl-loop for (op . body) in cases + for sp-delta = (gethash op comp-op-stack-info) + for op-name = (symbol-name op) + if body + collect `(',op + ;; Log all LAP ops except the TAG one. + ;; ,(unless (eq op 'TAG) + ;; `(comp-emit-annotation + ;; ,(concat "LAP op " op-name))) + ;; Emit the stack adjustment if present. + ,(when (and sp-delta (not (eq 0 sp-delta))) + `(cl-incf (comp-sp) ,sp-delta)) + ,@(comp-body-eff body op-name sp-delta)) + else + collect `(',op (signal 'native-ice + (list "unsupported LAP op" ',op-name)))) + (_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op)))))) + +(defun comp-limplify-lap-inst (insn) + "Limplify LAP instruction INSN pushing it in the proper basic block." + (let ((op (car insn)) + (arg (if (consp (cdr insn)) + (cadr insn) + (cdr insn)))) + (comp-op-case + (TAG + (cl-destructuring-bind (_TAG label-num . label-sp) insn + ;; Paranoid? + (when label-sp + (cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass)))) + (comp-emit-annotation (format "LAP TAG %d" label-num)))) + (byte-stack-ref + (comp-copy-slot (- (comp-sp) arg 1))) + (byte-varref + (comp-emit-set-call (comp-call 'symbol-value (make-comp-mvar + :constant arg)))) + (byte-varset + (comp-emit (comp-call 'set_internal + (make-comp-mvar :constant arg) + (comp-slot+1)))) + (byte-varbind ;; Verify + (comp-emit (comp-call 'specbind + (make-comp-mvar :constant arg) + (comp-slot+1)))) + (byte-call + (cl-incf (comp-sp) (- arg)) + (comp-emit-set-call (comp-callref 'funcall (1+ arg) (comp-sp)))) + (byte-unbind + (comp-emit (comp-call 'helper_unbind_n + (make-comp-mvar :constant arg)))) + (byte-pophandler + (comp-emit '(pop-handler))) + (byte-pushconditioncase + (comp-emit-handler (cddr insn) 'condition-case)) + (byte-pushcatch + (comp-emit-handler (cddr insn) 'catcher)) + (byte-nth auto) + (byte-symbolp auto) + (byte-consp auto) + (byte-stringp auto) + (byte-listp auto) + (byte-eq auto) + (byte-memq auto) + (byte-not + (comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp)) + (make-comp-mvar :constant nil)))) + (byte-car auto) + (byte-cdr auto) + (byte-cons auto) + (byte-list1 + (comp-limplify-listn 1)) + (byte-list2 + (comp-limplify-listn 2)) + (byte-list3 + (comp-limplify-listn 3)) + (byte-list4 + (comp-limplify-listn 4)) + (byte-length auto) + (byte-aref auto) + (byte-aset auto) + (byte-symbol-value auto) + (byte-symbol-function auto) + (byte-set auto) + (byte-fset auto) + (byte-get auto) + (byte-substring auto) + (byte-concat2 + (comp-emit-set-call (comp-callref 'concat 2 (comp-sp)))) + (byte-concat3 + (comp-emit-set-call (comp-callref 'concat 3 (comp-sp)))) + (byte-concat4 + (comp-emit-set-call (comp-callref 'concat 4 (comp-sp)))) + (byte-sub1 1-) + (byte-add1 1+) + (byte-eqlsign =) + (byte-gtr >) + (byte-lss <) + (byte-leq <=) + (byte-geq >=) + (byte-diff -) + (byte-negate + (comp-emit-set-call (comp-call 'negate (comp-slot)))) + (byte-plus +) + (byte-max auto) + (byte-min auto) + (byte-mult *) + (byte-point auto) + (byte-goto-char auto) + (byte-insert auto) + (byte-point-max auto) + (byte-point-min auto) + (byte-char-after auto) + (byte-following-char auto) + (byte-preceding-char preceding-char) + (byte-current-column auto) + (byte-indent-to + (comp-emit-set-call (comp-call 'indent-to + (comp-slot) + (make-comp-mvar :constant nil)))) + (byte-scan-buffer-OBSOLETE) + (byte-eolp auto) + (byte-eobp auto) + (byte-bolp auto) + (byte-bobp auto) + (byte-current-buffer auto) + (byte-set-buffer auto) + (byte-save-current-buffer + (comp-emit (comp-call 'record_unwind_current_buffer))) + (byte-set-mark-OBSOLETE) + (byte-interactive-p-OBSOLETE) + (byte-forward-char auto) + (byte-forward-word auto) + (byte-skip-chars-forward auto) + (byte-skip-chars-backward auto) + (byte-forward-line auto) + (byte-char-syntax auto) + (byte-buffer-substring auto) + (byte-delete-region auto) + (byte-narrow-to-region + (comp-emit-set-call (comp-call 'narrow-to-region + (comp-slot) + (comp-slot+1)))) + (byte-widen + (comp-emit-set-call (comp-call 'widen))) + (byte-end-of-line auto) + (byte-constant2) ; TODO + ;; Branches. + (byte-goto + (comp-emit-uncond-jump (cddr insn))) + (byte-goto-if-nil + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 + (cddr insn) nil)) + (byte-goto-if-not-nil + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 + (cddr insn) t)) + (byte-goto-if-nil-else-pop + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 + (cddr insn) nil)) + (byte-goto-if-not-nil-else-pop + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 + (cddr insn) t)) + (byte-return + (comp-emit `(return ,(comp-slot+1)))) + (byte-discard 'pass) + (byte-dup + (comp-copy-slot (1- (comp-sp)))) + (byte-save-excursion + (comp-emit (comp-call 'record_unwind_protect_excursion))) + (byte-save-window-excursion-OBSOLETE) + (byte-save-restriction + (comp-emit (comp-call 'helper_save_restriction))) + (byte-catch) ;; Obsolete + (byte-unwind-protect + (comp-emit (comp-call 'helper_unwind_protect (comp-slot+1)))) + (byte-condition-case) ;; Obsolete + (byte-temp-output-buffer-setup-OBSOLETE) + (byte-temp-output-buffer-show-OBSOLETE) + (byte-unbind-all) ;; Obsolete + (byte-set-marker auto) + (byte-match-beginning auto) + (byte-match-end auto) + (byte-upcase auto) + (byte-downcase auto) + (byte-string= string-equal) + (byte-string< string-lessp) + (byte-equal auto) + (byte-nthcdr auto) + (byte-elt auto) + (byte-member auto) + (byte-assq auto) + (byte-nreverse auto) + (byte-setcar auto) + (byte-setcdr auto) + (byte-car-safe auto) + (byte-cdr-safe auto) + (byte-nconc auto) + (byte-quo /) + (byte-rem %) + (byte-numberp auto) + (byte-integerp auto) + (byte-listN + (cl-incf (comp-sp) (- 1 arg)) + (comp-emit-set-call (comp-callref 'list arg (comp-sp)))) + (byte-concatN + (cl-incf (comp-sp) (- 1 arg)) + (comp-emit-set-call (comp-callref 'concat arg (comp-sp)))) + (byte-insertN + (cl-incf (comp-sp) (- 1 arg)) + (comp-emit-set-call (comp-callref 'insert arg (comp-sp)))) + (byte-stack-set + (comp-copy-slot (1+ (comp-sp)) (- (comp-sp) arg -1))) + (byte-stack-set2 (cl-assert nil)) ;; TODO + (byte-discardN + (cl-incf (comp-sp) (- arg))) + (byte-switch + ;; Assume to follow the emission of a setimm. + ;; This is checked into comp-emit-switch. + (comp-emit-switch (comp-slot+1) + (cl-first (comp-block-insns + (comp-limplify-curr-block comp-pass))))) + (byte-constant + (comp-emit-setimm arg)) + (byte-discardN-preserve-tos + (cl-incf (comp-sp) (- arg)) + (comp-copy-slot (+ arg (comp-sp))))))) + +(defun comp-emit-narg-prologue (minarg nonrest rest) + "Emit the prologue for a narg function." + (cl-loop for i below minarg + do (comp-emit `(set-args-to-local ,(comp-slot-n i))) + (comp-emit '(inc-args))) + (cl-loop for i from minarg below nonrest + for bb = (intern (format "entry_%s" i)) + for fallback = (intern (format "entry_fallback_%s" i)) + do (comp-emit `(cond-jump-narg-leq ,i ,fallback ,bb)) + (comp-make-curr-block bb (comp-sp)) + (comp-emit `(set-args-to-local ,(comp-slot-n i))) + (comp-emit '(inc-args)) + finally (comp-emit '(jump entry_rest_args))) + (when (/= minarg nonrest) + (cl-loop for i from minarg below nonrest + for bb = (intern (format "entry_fallback_%s" i)) + for next-bb = (if (= (1+ i) nonrest) + 'entry_rest_args + (intern (format "entry_fallback_%s" (1+ i)))) + do (comp-with-sp i + (comp-make-curr-block bb (comp-sp)) + (comp-emit-setimm nil) + (comp-emit `(jump ,next-bb))))) + (comp-make-curr-block 'entry_rest_args (comp-sp)) + (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest))) + (setf (comp-sp) nonrest) + (when (and (> nonrest 8) (null rest)) + (cl-decf (comp-sp)))) + +(defun comp-limplify-finalize-function (func) + "Reverse insns into all basic blocks of FUNC." + (cl-loop for bb being the hash-value in (comp-func-blocks func) + do (setf (comp-block-insns bb) + (nreverse (comp-block-insns bb)))) + (comp-log-func func 2) + func) + +(cl-defgeneric comp-prepare-args-for-top-level (function) + "Given FUNCTION, return the two arguments for comp--register-...") + +(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-l)) + "Lexically-scoped FUNCTION." + (let ((args (comp-func-l-args function))) + (cons (make-comp-mvar :constant (comp-args-base-min args)) + (make-comp-mvar :constant (if (comp-args-p args) + (comp-args-max args) + 'many))))) + +(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-d)) + "Dynamically scoped FUNCTION." + (cons (make-comp-mvar :constant (func-arity (comp-func-byte-func function))) + (let ((comp-curr-allocation-class 'd-default)) + ;; Lambda-lists must stay in the same relocation class of + ;; the object referenced by code to respect uninterned + ;; symbols. + (make-comp-mvar :constant (comp-func-d-lambda-list function))))) + +(cl-defgeneric comp-emit-for-top-level (form for-late-load) + "Emit the Limple code for top level FORM.") + +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-func-def) + for-late-load) + (let* ((name (byte-to-native-func-def-name form)) + (c-name (byte-to-native-func-def-c-name form)) + (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt))) + (args (comp-prepare-args-for-top-level f))) + (cl-assert (and name f)) + (comp-emit + `(set ,(make-comp-mvar :slot 1) + ,(comp-call (if for-late-load + 'comp--late-register-subr + 'comp--register-subr) + (make-comp-mvar :constant name) + (make-comp-mvar :constant c-name) + (car args) + (cdr args) + (setf (comp-func-type f) + (make-comp-mvar :constant nil)) + (make-comp-mvar + :constant + (list + (let* ((h (comp-ctxt-function-docs comp-ctxt)) + (i (hash-table-count h))) + (puthash i (comp-func-doc f) h) + i) + (comp-func-int-spec f))) + ;; This is the compilation unit it-self passed as + ;; parameter. + (make-comp-mvar :slot 0)))))) + +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level) + for-late-load) + (unless for-late-load + (comp-emit + (comp-call 'eval + (let ((comp-curr-allocation-class 'd-impure)) + (make-comp-mvar :constant + (byte-to-native-top-level-form form))) + (make-comp-mvar :constant + (byte-to-native-top-level-lexical form)))))) + +(defun comp-emit-lambda-for-top-level (func) + "Emit the creation of subrs for lambda FUNC. +These are stored in the reloc data array." + (let ((args (comp-prepare-args-for-top-level func))) + (let ((comp-curr-allocation-class 'd-impure)) + (comp-add-const-to-relocs (comp-func-byte-func func))) + (comp-emit + (comp-call 'comp--register-lambda + ;; mvar to be fixed-up when containers are + ;; finalized. + (or (gethash (comp-func-byte-func func) + (comp-ctxt-lambda-fixups-h comp-ctxt)) + (puthash (comp-func-byte-func func) + (make-comp-mvar :constant nil) + (comp-ctxt-lambda-fixups-h comp-ctxt))) + (make-comp-mvar :constant (comp-func-c-name func)) + (car args) + (cdr args) + (setf (comp-func-type func) + (make-comp-mvar :constant nil)) + (make-comp-mvar + :constant + (list + (let* ((h (comp-ctxt-function-docs comp-ctxt)) + (i (hash-table-count h))) + (puthash i (comp-func-doc func) h) + i) + (comp-func-int-spec func))) + ;; This is the compilation unit it-self passed as + ;; parameter. + (make-comp-mvar :slot 0))))) + +(defun comp-limplify-top-level (for-late-load) + "Create a Limple function to modify the global environment at load. +When FOR-LATE-LOAD is non-nil, the emitted function modifies only +function definition. + +Synthesize a function called `top_level_run' that gets one single +parameter (the compilation unit itself). To define native +functions, `top_level_run' will call back `comp--register-subr' +into the C code forwarding the compilation unit." + ;; Once an .eln is loaded and Emacs is dumped 'top_level_run' has no + ;; reasons to be executed ever again. Therefore all objects can be + ;; just ephemeral. + (let* ((comp-curr-allocation-class 'd-ephemeral) + (func (make-comp-func-l :name (if for-late-load + 'late-top-level-run + 'top-level-run) + :c-name (if for-late-load + "late_top_level_run" + "top_level_run") + :args (make-comp-args :min 1 :max 1) + ;; Frame is 2 wide: Slot 0 is the + ;; compilation unit being loaded + ;; (incoming parameter). Slot 1 is + ;; the last function being + ;; registered. + :frame-size 2 + :speed (comp-ctxt-speed comp-ctxt))) + (comp-func func) + (comp-pass (make-comp-limplify + :curr-block (make--comp-block-lap -1 0 'top-level) + :frame (comp-new-frame 1 0)))) + (comp-make-curr-block 'entry (comp-sp)) + (comp-emit-annotation (if for-late-load + "Late top level" + "Top level")) + ;; Assign the compilation unit incoming as parameter to the slot frame 0. + (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0)) + (maphash (lambda (_ func) + (comp-emit-lambda-for-top-level func)) + (comp-ctxt-byte-func-to-func-h comp-ctxt)) + (mapc (lambda (x) (comp-emit-for-top-level x for-late-load)) + (comp-ctxt-top-level-forms comp-ctxt)) + (comp-emit `(return ,(make-comp-mvar :slot 1))) + (comp-limplify-finalize-function func))) + +(defun comp-addr-to-bb-name (addr) + "Search for a block starting at ADDR into pending or limplified blocks." + ;; FIXME Actually we could have another hash for this. + (cl-flet ((pred (bb) + (equal (comp-block-lap-addr bb) addr))) + (if-let ((pending (cl-find-if #'pred + (comp-limplify-pending-blocks comp-pass)))) + (comp-block-name pending) + (cl-loop for bb being the hash-value in (comp-func-blocks comp-func) + when (pred bb) + return (comp-block-name bb))))) + +(defun comp-limplify-block (bb) + "Limplify basic-block BB and add it to the current function." + (setf (comp-limplify-curr-block comp-pass) bb + (comp-limplify-sp comp-pass) (comp-block-lap-sp bb) + (comp-limplify-pc comp-pass) (comp-block-lap-addr bb)) + (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) + (cl-loop + for inst-cell on (nthcdr (comp-limplify-pc comp-pass) + (comp-func-lap comp-func)) + for inst = (car inst-cell) + for next-inst = (car-safe (cdr inst-cell)) + do (comp-limplify-lap-inst inst) + (cl-incf (comp-limplify-pc comp-pass)) + when (comp-lap-fall-through-p inst) + do (pcase next-inst + (`(TAG ,_label . ,label-sp) + (when label-sp + (cl-assert (= (1- label-sp) (comp-sp)))) + (let* ((stack-depth (if label-sp + (1- label-sp) + (comp-sp))) + (next-bb (comp-block-name (comp-bb-maybe-add + (comp-limplify-pc comp-pass) + stack-depth)))) + (unless (comp-block-closed bb) + (comp-emit `(jump ,next-bb)))) + (cl-return))) + until (comp-lap-eob-p inst))) + +(defun comp-limplify-function (func) + "Limplify a single function FUNC." + (let* ((frame-size (comp-func-frame-size func)) + (comp-func func) + (comp-pass (make-comp-limplify + :frame (comp-new-frame frame-size 0)))) + (comp-fill-label-h) + ;; Prologue + (comp-make-curr-block 'entry (comp-sp)) + (comp-emit-annotation (concat "Lisp function: " + (symbol-name (comp-func-name func)))) + ;; Dynamic functions have parameters bound by the trampoline. + (when (comp-func-l-p func) + (let ((args (comp-func-l-args func))) + (if (comp-args-p args) + (cl-loop for i below (comp-args-max args) + do (cl-incf (comp-sp)) + (comp-emit `(set-par-to-local ,(comp-slot) ,i))) + (comp-emit-narg-prologue (comp-args-base-min args) + (comp-nargs-nonrest args) + (comp-nargs-rest args))))) + (comp-emit '(jump bb_0)) + ;; Body + (comp-bb-maybe-add 0 (comp-sp)) + (cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass)) + while next-bb + do (comp-limplify-block next-bb)) + ;; Sanity check against block duplication. + (cl-loop with addr-h = (make-hash-table) + for bb being the hash-value in (comp-func-blocks func) + for addr = (when (comp-block-lap-p bb) + (comp-block-lap-addr bb)) + when addr + do (cl-assert (null (gethash addr addr-h))) + (puthash addr t addr-h)) + (comp-limplify-finalize-function func))) + +(defun comp-limplify (_) + "Compute LIMPLE IR for forms in `comp-ctxt'." + (maphash (lambda (_ f) (comp-limplify-function f)) + (comp-ctxt-funcs-h comp-ctxt)) + (comp-add-func-to-ctxt (comp-limplify-top-level nil)) + (when (comp-ctxt-with-late-load comp-ctxt) + (comp-add-func-to-ctxt (comp-limplify-top-level t)))) + + +;;; add-cstrs pass specific code. + +;; This pass is responsible for adding constraints, these are +;; generated from: +;; +;; - Conditional branches: each branch taken or non taken can be used +;; in the CFG to infer information on the tested variables. +;; +;; - Range propagation under test and branch (when the test is an +;; arithmetic comparison). +;; +;; - Type constraint under test and branch (when the test is a +;; known predicate). +;; +;; - Function calls: function calls to function assumed to be not +;; redefinable can be used to add constrains on the function +;; arguments. Ex: if we execute successfully (= x y) we know that +;; afterwards both x and y must satisfy the (or number marker) +;; type specifier. + + +(defsubst comp-mvar-used-p (mvar) + "Non-nil when MVAR is used as lhs in the current function." + (declare (gv-setter (lambda (val) + `(puthash ,mvar ,val comp-pass)))) + (gethash mvar comp-pass)) + +(defun comp-collect-mvars (form) + "Add rhs m-var present in FORM into `comp-pass'." + (cl-loop for x in form + if (consp x) + do (comp-collect-mvars x) + else + when (comp-mvar-p x) + do (setf (comp-mvar-used-p x) t))) + +(defun comp-collect-rhs () + "Collect all lhs mvars into `comp-pass'." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn in (comp-block-insns b) + for (op . args) = insn + if (comp-assign-op-p op) + do (comp-collect-mvars (cdr args)) + else + do (comp-collect-mvars args)))) + +(defun comp-negate-arithm-cmp-fun (function) + "Negate FUNCTION. +Return nil if we don't want to emit constraints for its negation." + (cl-ecase function + (= nil) + (> '<=) + (< '>=) + (>= '<) + (<= '>))) + +(defun comp-reverse-arithm-fun (function) + "Reverse FUNCTION." + (cl-case function + (= '=) + (> '<) + (< '>) + (>= '<=) + (<= '>=) + (t function))) + +(defun comp-emit-assume (kind lhs rhs bb negated) + "Emit an assume of kind KIND for mvar LHS being RHS. +When NEGATED is non-nil, the assumption is negated. +The assume is emitted at the beginning of the block BB." + (let ((lhs-slot (comp-mvar-slot lhs))) + (cl-assert lhs-slot) + (pcase kind + ((or 'and 'and-nhc) + (if (comp-mvar-p rhs) + (let ((tmp-mvar (if negated + (make-comp-mvar :slot (comp-mvar-slot rhs)) + rhs))) + (push `(assume ,(make-comp-mvar :slot lhs-slot) + (,kind ,lhs ,tmp-mvar)) + (comp-block-insns bb)) + (if negated + (push `(assume ,tmp-mvar (not ,rhs)) + (comp-block-insns bb)))) + ;; If is only a constraint we can negate it directly. + (push `(assume ,(make-comp-mvar :slot lhs-slot) + (,kind ,lhs ,(if negated + (comp-cstr-negation-make rhs) + rhs))) + (comp-block-insns bb)))) + ((pred comp-arithm-cmp-fun-p) + (when-let ((kind (if negated + (comp-negate-arithm-cmp-fun kind) + kind))) + (push `(assume ,(make-comp-mvar :slot lhs-slot) + (,kind ,lhs + ,(if-let* ((vld (comp-cstr-imm-vld-p rhs)) + (val (comp-cstr-imm rhs)) + (ok (and (integerp val) + (not (memq kind '(= !=)))))) + val + (make-comp-mvar :slot (comp-mvar-slot rhs))))) + (comp-block-insns bb)))) + (_ (cl-assert nil))) + (setf (comp-func-ssa-status comp-func) 'dirty))) + +(defun comp-maybe-add-vmvar (op cmp-res insns-seq) + "If CMP-RES is clobbering OP emit a new constrained mvar and return it. +Return OP otherwise." + (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) + (new-mvar (make-comp-mvar + :slot + (- (cl-incf (comp-func-vframe-size comp-func)))))) + (progn + (push `(assume ,new-mvar ,op) (cdr insns-seq)) + new-mvar) + op)) + +(defun comp-add-new-block-between (bb-symbol bb-a bb-b) + "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B." + (cl-loop + with new-bb = (make-comp-block-cstr :name bb-symbol + :insns `((jump ,(comp-block-name bb-b)))) + with new-edge = (make-comp-edge :src bb-a :dst new-bb) + for ed in (comp-block-in-edges bb-b) + when (eq (comp-edge-src ed) bb-a) + do + ;; Connect `ed' to `new-bb' and disconnect it from `bb-a'. + (cl-assert (memq ed (comp-block-out-edges bb-a))) + (setf (comp-edge-src ed) new-bb + (comp-block-out-edges bb-a) (delq ed (comp-block-out-edges bb-a))) + (push ed (comp-block-out-edges new-bb)) + ;; Connect `bb-a' `new-bb' with `new-edge'. + (push new-edge (comp-block-out-edges bb-a)) + (push new-edge (comp-block-in-edges new-bb)) + (setf (comp-func-ssa-status comp-func) 'dirty) + ;; Add `new-edge' to the current function and return it. + (cl-return (puthash bb-symbol new-bb (comp-func-blocks comp-func))) + finally (cl-assert nil))) + +;; Cheap substitute to a copy propagation pass... +(defun comp-cond-cstrs-target-mvar (mvar exit-insn bb) + "Given MVAR, search in BB the original mvar MVAR got assigned from. +Keep on searching till EXIT-INSN is encountered." + (cl-flet ((targetp (x) + ;; Ret t if x is an mvar and target the correct slot number. + (and (comp-mvar-p x) + (eql (comp-mvar-slot mvar) (comp-mvar-slot x))))) + (cl-loop + with res = nil + for insn in (comp-block-insns bb) + when (eq insn exit-insn) + do (cl-return (and (comp-mvar-p res) res)) + do (pcase insn + (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs) + (setf res rhs))) + finally (cl-assert nil)))) + +(defun comp-add-cond-cstrs-target-block (curr-bb target-bb-sym) + "Return the appropriate basic block to add constraint assumptions into. +CURR-BB is the current basic block. +TARGET-BB-SYM is the symbol name of the target block." + (let* ((target-bb (gethash target-bb-sym + (comp-func-blocks comp-func))) + (target-bb-in-edges (comp-block-in-edges target-bb))) + (cl-assert target-bb-in-edges) + (if (length= target-bb-in-edges 1) + ;; If block has only one predecessor is already suitable for + ;; adding constraint assumptions. + target-bb + (cl-loop + ;; Search for the first suitable basic block name. + for i from 0 + for new-name = (intern (format "%s_cstrs_%d" (symbol-name target-bb-sym) + i)) + until (null (gethash new-name (comp-func-blocks comp-func))) + finally + ;; Add it. + (cl-return (comp-add-new-block-between new-name curr-bb target-bb)))))) + +(defun comp-add-cond-cstrs-simple () + "`comp-add-cstrs' worker function for each selected function." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do + (cl-loop + named in-the-basic-block + for insn-seq on (comp-block-insns b) + do + (pcase insn-seq + (`((set ,(and (pred comp-mvar-p) tmp-mvar) ,(pred comp-mvar-p)) + ;; (comment ,_comment-str) + (cond-jump ,tmp-mvar ,obj2 . ,blocks)) + (cl-loop + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for negated in '(nil t) + when (comp-mvar-used-p tmp-mvar) + do + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume 'and tmp-mvar obj2 block-target negated)) + finally (cl-return-from in-the-basic-block))) + (`((cond-jump ,obj1 ,obj2 . ,blocks)) + (cl-loop + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for negated in '(nil t) + when (comp-mvar-used-p obj1) + do + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume 'and obj1 obj2 block-target negated)) + finally (cl-return-from in-the-basic-block))))))) + +(defun comp-add-cond-cstrs () + "`comp-add-cstrs' worker function for each selected function." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do + (cl-loop + named in-the-basic-block + with prev-insns-seq + for insns-seq on (comp-block-insns b) + do + (pcase insns-seq + (`((set ,(and (pred comp-mvar-p) cmp-res) + (,(pred comp-call-op-p) + ,(and (or (pred comp-equality-fun-p) + (pred comp-arithm-cmp-fun-p)) + fun) + ,op1 ,op2)) + ;; (comment ,_comment-str) + (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) + (cl-loop + with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) + with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for negated in '(t nil) + for kind = (cl-case fun + (equal 'and-nhc) + (eql 'and-nhc) + (eq 'and) + (t fun)) + when (or (comp-mvar-used-p target-mvar1) + (comp-mvar-used-p target-mvar2)) + do + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (when (comp-mvar-used-p target-mvar1) + (comp-emit-assume kind target-mvar1 + (comp-maybe-add-vmvar op2 cmp-res prev-insns-seq) + block-target negated)) + (when (comp-mvar-used-p target-mvar2) + (comp-emit-assume (comp-reverse-arithm-fun kind) + target-mvar2 + (comp-maybe-add-vmvar op1 cmp-res prev-insns-seq) + block-target negated))) + finally (cl-return-from in-the-basic-block))) + (`((set ,(and (pred comp-mvar-p) cmp-res) + (,(pred comp-call-op-p) + ,(and (pred comp-known-predicate-p) fun) + ,op)) + ;; (comment ,_comment-str) + (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) + (cl-loop + with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) + with cstr = (comp-pred-to-cstr fun) + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for negated in '(t nil) + when (comp-mvar-used-p target-mvar) + do + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume 'and target-mvar cstr block-target negated)) + finally (cl-return-from in-the-basic-block))) + ;; Match predicate on the negated branch (unless). + (`((set ,(and (pred comp-mvar-p) cmp-res) + (,(pred comp-call-op-p) + ,(and (pred comp-known-predicate-p) fun) + ,op)) + (set ,neg-cmp-res (call eq ,cmp-res ,(pred comp-cstr-null-p))) + (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks)) + (cl-loop + with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) + with cstr = (comp-pred-to-cstr fun) + for branch-target-cell on blocks + for branch-target = (car branch-target-cell) + for negated in '(nil t) + when (comp-mvar-used-p target-mvar) + do + (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (setf (car branch-target-cell) (comp-block-name block-target)) + (comp-emit-assume 'and target-mvar cstr block-target negated)) + finally (cl-return-from in-the-basic-block)))) + (setf prev-insns-seq insns-seq)))) + +(defsubst comp-insert-insn (insn insn-cell) + "Insert INSN as second insn of INSN-CELL." + (let ((next-cell (cdr insn-cell)) + (new-cell `(,insn))) + (setf (cdr insn-cell) new-cell + (cdr new-cell) next-cell + (comp-func-ssa-status comp-func) 'dirty))) + +(defun comp-emit-call-cstr (mvar call-cell cstr) + "Emit a constraint CSTR for MVAR after CALL-CELL." + (let* ((new-mvar (make-comp-mvar :slot (comp-mvar-slot mvar))) + ;; Have new-mvar as LHS *and* RHS to ensure monotonicity and + ;; fwprop convergence!! + (insn `(assume ,new-mvar (and ,new-mvar ,mvar ,cstr)))) + (comp-insert-insn insn call-cell))) + +(defun comp-lambda-list-gen (lambda-list) + "Return a generator to iterate over LAMBDA-LIST." + (lambda () + (cl-case (car lambda-list) + (&optional + (setf lambda-list (cdr lambda-list)) + (prog1 + (car lambda-list) + (setf lambda-list (cdr lambda-list)))) + (&rest + (cadr lambda-list)) + (t + (prog1 + (car lambda-list) + (setf lambda-list (cdr lambda-list))))))) + +(defun comp-add-call-cstr () + "Add args assumptions for each function of which the type specifier is known." + (cl-loop + for bb being each hash-value of (comp-func-blocks comp-func) + do + (comp-loop-insn-in-block bb + (when-let ((match + (pcase insn + (`(set ,lhs (,(pred comp-call-op-p) ,f . ,args)) + (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) + (cl-values f cstr-f lhs args))) + (`(,(pred comp-call-op-p) ,f . ,args) + (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) + (cl-values f cstr-f nil args)))))) + (cl-multiple-value-bind (f cstr-f lhs args) match + (cl-loop + with gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f)) + for arg in args + for cstr = (funcall gen) + for target = (comp-cond-cstrs-target-mvar arg insn bb) + unless (comp-cstr-p cstr) + do (signal 'native-ice + (list "Incoherent type specifier for function" f)) + when (and target + ;; No need to add call constraints if this is t + ;; (bug#45812 bug#45705 bug#45751). + (not (equal comp-cstr-t cstr)) + (or (null lhs) + (not (eql (comp-mvar-slot lhs) + (comp-mvar-slot target))))) + do (comp-emit-call-cstr target insn-cell cstr))))))) + +(defun comp-add-cstrs (_) + "Rewrite conditional branches adding appropriate 'assume' insns. +This is introducing and placing 'assume' insns in use by fwprop +to propagate conditional branch test information on target basic +blocks." + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 1) + ;; No point to run this on dynamic scope as + ;; this pass is effective only on local + ;; variables. + (comp-func-l-p f) + (not (comp-func-has-non-local f))) + (let ((comp-func f) + (comp-pass (make-hash-table :test #'eq))) + (comp-collect-rhs) + (comp-add-cond-cstrs-simple) + (comp-add-cond-cstrs) + (comp-add-call-cstr) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) + + +;;; pure-func pass specific code. + +;; Simple IPA pass to infer function purity of functions not +;; explicitly declared as such. This is effective only at speed 3 to +;; avoid optimizing-out functions and preventing their redefinition +;; being effective. + +(defun comp-collect-calls (f) + "Return a list with all the functions called by F." + (cl-loop + with h = (make-hash-table :test #'eq) + for b being each hash-value of (comp-func-blocks f) + do (cl-loop + for insn in (comp-block-insns b) + do (pcase insn + (`(set ,_lval (,(pred comp-call-op-p) ,f . ,_rest)) + (puthash f t h)) + (`(,(pred comp-call-op-p) ,f . ,_rest) + (puthash f t h)))) + finally return (cl-loop + for f being each hash-key of h + collect (if (stringp f) + (comp-func-name + (gethash f + (comp-ctxt-funcs-h comp-ctxt))) + f)))) + +(defun comp-pure-infer-func (f) + "If all functions called by F are pure then F is pure too." + (when (and (cl-every (lambda (x) + (or (comp-function-pure-p x) + (eq x (comp-func-name f)))) + (comp-collect-calls f)) + (not (eq (comp-func-pure f) t))) + (comp-log (format "%s inferred to be pure" (comp-func-name f))) + (setf (comp-func-pure f) t))) + +(defun comp-ipa-pure (_) + "Infer function purity." + (cl-loop + with pure-n = 0 + for n from 1 + while + (/= pure-n + (setf pure-n + (cl-loop + for f being each hash-value of (comp-ctxt-funcs-h comp-ctxt) + when (and (>= (comp-func-speed f) 3) + (comp-func-l-p f) + (not (comp-func-pure f))) + do (comp-pure-infer-func f) + count (comp-func-pure f)))) + finally (comp-log (format "ipa-pure iterated %d times" n)))) + + +;;; SSA pass specific code. +;; After limplification no edges are present between basic blocks and an +;; implicit phi is present for every slot at the beginning of every basic block. +;; This pass is responsible for building all the edges and replace all m-vars +;; plus placing the needed phis. +;; Because the number of phis placed is (supposed) to be the minimum necessary +;; this form is called 'minimal SSA form'. +;; This pass should be run every time basic blocks or m-var are shuffled. + +(cl-defun make-comp-ssa-mvar (&rest rest &key _slot _constant _type) + "Same as `make-comp-mvar' but set the `id' slot." + (let ((mvar (apply #'make-comp-mvar rest))) + (setf (comp-mvar-id mvar) (sxhash-eq mvar)) + mvar)) + +(defun comp-clean-ssa (f) + "Clean-up SSA for function F." + (setf (comp-func-edges-h f) (make-hash-table)) + (cl-loop + for b being each hash-value of (comp-func-blocks f) + do (setf (comp-block-in-edges b) () + (comp-block-out-edges b) () + (comp-block-idom b) nil + (comp-block-df b) (make-hash-table) + (comp-block-post-num b) nil + (comp-block-final-frame b) nil + ;; Prune all phis. + (comp-block-insns b) (cl-loop for insn in (comp-block-insns b) + unless (eq 'phi (car insn)) + collect insn)))) + +(defun comp-compute-edges () + "Compute the basic block edges for the current function." + (cl-loop with blocks = (comp-func-blocks comp-func) + for bb being each hash-value of blocks + for last-insn = (car (last (comp-block-insns bb))) + for (op first second third forth) = last-insn + do (cl-case op + (jump + (make-comp-edge :src bb :dst (gethash first blocks))) + (cond-jump + (make-comp-edge :src bb :dst (gethash third blocks)) + (make-comp-edge :src bb :dst (gethash forth blocks))) + (cond-jump-narg-leq + (make-comp-edge :src bb :dst (gethash second blocks)) + (make-comp-edge :src bb :dst (gethash third blocks))) + (push-handler + (make-comp-edge :src bb :dst (gethash third blocks)) + (make-comp-edge :src bb :dst (gethash forth blocks))) + (return) + (unreachable) + (otherwise + (signal 'native-ice + (list "block does not end with a branch" + bb + (comp-func-name comp-func))))) + ;; Update edge refs into blocks. + finally + (cl-loop + for edge being the hash-value in (comp-func-edges-h comp-func) + do + (push edge + (comp-block-out-edges (comp-edge-src edge))) + (push edge + (comp-block-in-edges (comp-edge-dst edge)))) + (comp-log-edges comp-func))) + +(defun comp-collect-rev-post-order (basic-block) + "Walk BASIC-BLOCK children and return their name in reversed post-order." + (let ((visited (make-hash-table)) + (acc ())) + (cl-labels ((collect-rec (bb) + (let ((name (comp-block-name bb))) + (unless (gethash name visited) + (puthash name t visited) + (cl-loop for e in (comp-block-out-edges bb) + for dst-block = (comp-edge-dst e) + do (collect-rec dst-block)) + (push name acc))))) + (collect-rec basic-block) + acc))) + +(defun comp-compute-dominator-tree () + "Compute immediate dominators for each basic block in current function." + ;; Originally based on: "A Simple, Fast Dominance Algorithm" + ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). + (cl-flet ((intersect (b1 b2) + (let ((finger1 (comp-block-post-num b1)) + (finger2 (comp-block-post-num b2))) + (while (not (= finger1 finger2)) + (while (< finger1 finger2) + (setf b1 (comp-block-idom b1) + finger1 (comp-block-post-num b1))) + (while (< finger2 finger1) + (setf b2 (comp-block-idom b2) + finger2 (comp-block-post-num b2)))) + b1)) + (first-processed (l) + (if-let ((p (cl-find-if (lambda (p) (comp-block-idom p)) l))) + p + (signal 'native-ice "cant't find first preprocessed")))) + + (when-let ((blocks (comp-func-blocks comp-func)) + (entry (gethash 'entry blocks)) + ;; No point to go on if the only bb is 'entry'. + (bb0 (gethash 'bb_0 blocks))) + (cl-loop + with rev-bb-list = (comp-collect-rev-post-order entry) + with changed = t + while changed + initially (progn + (comp-log "Computing dominator tree...\n" 2) + (setf (comp-block-idom entry) entry) + ;; Set the post order number. + (cl-loop for name in (reverse rev-bb-list) + for b = (gethash name blocks) + for i from 0 + do (setf (comp-block-post-num b) i))) + do (cl-loop + for name in (cdr rev-bb-list) + for b = (gethash name blocks) + for preds = (comp-block-preds b) + for new-idom = (first-processed preds) + initially (setf changed nil) + do (cl-loop for p in (delq new-idom preds) + when (comp-block-idom p) + do (setf new-idom (intersect p new-idom))) + unless (eq (comp-block-idom b) new-idom) + do (setf (comp-block-idom b) (unless (and (comp-block-lap-p new-idom) + (comp-block-lap-no-ret + new-idom)) + new-idom) + changed t)))))) + +(defun comp-compute-dominator-frontiers () + "Compute the dominator frontier for each basic block in `comp-func'." + ;; Originally based on: "A Simple, Fast Dominance Algorithm" + ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). + (cl-loop with blocks = (comp-func-blocks comp-func) + for b-name being each hash-keys of blocks + using (hash-value b) + for preds = (comp-block-preds b) + when (length> preds 1) ; All joins + do (cl-loop for p in preds + for runner = p + do (while (not (eq runner (comp-block-idom b))) + (puthash b-name b (comp-block-df runner)) + (setf runner (comp-block-idom runner)))))) + +(defun comp-log-block-info () + "Log basic blocks info for the current function." + (maphash (lambda (name bb) + (let ((dom (comp-block-idom bb)) + (df (comp-block-df bb))) + (comp-log (format "block: %s idom: %s DF %s\n" + name + (when dom (comp-block-name dom)) + (cl-loop for b being each hash-keys of df + collect b)) + 3))) + (comp-func-blocks comp-func))) + +(defun comp-place-phis () + "Place phi insns into the current function." + ;; Originally based on: Static Single Assignment Book + ;; Algorithm 3.1: Standard algorithm for inserting phi-functions + (cl-flet ((add-phi (slot-n bb) + ;; Add a phi func for slot SLOT-N at the top of BB. + (push `(phi ,slot-n) (comp-block-insns bb))) + (slot-assigned-p (slot-n bb) + ;; Return t if a SLOT-N was assigned within BB. + (cl-loop for insn in (comp-block-insns bb) + for op = (car insn) + when (or (and (comp-assign-op-p op) + (eql slot-n (comp-mvar-slot (cadr insn)))) + ;; fetch-handler is after a non local + ;; therefore clobbers all frame!!! + (eq op 'fetch-handler)) + return t))) + + (cl-loop for i from (- (comp-func-vframe-size comp-func)) + below (comp-func-frame-size comp-func) + ;; List of blocks with a definition of mvar i + for defs-v = (cl-loop with blocks = (comp-func-blocks comp-func) + for b being each hash-value of blocks + when (slot-assigned-p i b) + collect b) + ;; Set of basic blocks where phi is added. + for f = () + ;; Worklist, set of basic blocks that contain definitions of v. + for w = defs-v + do + (while w + (let ((x (pop w))) + (cl-loop for y being each hash-value of (comp-block-df x) + unless (cl-find y f) + do (add-phi i y) + (push y f) + ;; Adding a phi implies mentioning the + ;; corresponding slot so in case adjust w. + (unless (cl-find y defs-v) + (push y w)))))))) + +(defun comp-dom-tree-walker (bb pre-lambda post-lambda) + "Dominator tree walker function starting from basic block BB. +PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." + (when pre-lambda + (funcall pre-lambda bb)) + (when-let ((out-edges (comp-block-out-edges bb))) + (cl-loop for ed in out-edges + for child = (comp-edge-dst ed) + when (eq bb (comp-block-idom child)) + ;; Current block is the immediate dominator then recur. + do (comp-dom-tree-walker child pre-lambda post-lambda))) + (when post-lambda + (funcall post-lambda bb))) + +(cl-defstruct (comp-ssa (:copier nil)) + "Support structure used while SSA renaming." + (frame (comp-new-frame (comp-func-frame-size comp-func) + (comp-func-vframe-size comp-func) t) + :type comp-vec + :documentation "`comp-vec' of m-vars.")) + +(defun comp-ssa-rename-insn (insn frame) + (cl-loop + for slot-n from (- (comp-func-vframe-size comp-func)) + below (comp-func-frame-size comp-func) + do + (cl-flet ((targetp (x) + ;; Ret t if x is an mvar and target the correct slot number. + (and (comp-mvar-p x) + (eql slot-n (comp-mvar-slot x)))) + (new-lvalue () + ;; If is an assignment make a new mvar and put it as l-value. + (let ((mvar (make-comp-ssa-mvar :slot slot-n))) + (setf (comp-vec-aref frame slot-n) mvar + (cadr insn) mvar)))) + (pcase insn + (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) + (let ((mvar (comp-vec-aref frame slot-n))) + (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn)))) + (new-lvalue)) + (`(fetch-handler . ,_) + ;; Clobber all no matter what! + (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) + (`(phi ,n) + (when (equal n slot-n) + (new-lvalue))) + (_ + (let ((mvar (comp-vec-aref frame slot-n))) + (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) + +(defun comp-ssa-rename () + "Entry point to rename into SSA within the current function." + (comp-log "Renaming\n" 2) + (let ((visited (make-hash-table))) + (cl-labels ((ssa-rename-rec (bb in-frame) + (unless (gethash bb visited) + (puthash bb t visited) + (cl-loop for insn in (comp-block-insns bb) + do (comp-ssa-rename-insn insn in-frame)) + (setf (comp-block-final-frame bb) + (copy-sequence in-frame)) + (when-let ((out-edges (comp-block-out-edges bb))) + (cl-loop + for ed in out-edges + for child = (comp-edge-dst ed) + ;; Provide a copy of the same frame to all children. + do (ssa-rename-rec child (comp-vec-copy in-frame))))))) + + (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func)) + (comp-new-frame (comp-func-frame-size comp-func) + (comp-func-vframe-size comp-func) + t))))) + +(defun comp-finalize-phis () + "Fixup r-values into phis in all basic blocks." + (cl-flet ((finalize-phi (args b) + ;; Concatenate into args all incoming m-vars for this phi. + (setcdr args + (cl-loop with slot-n = (comp-mvar-slot (car args)) + for e in (comp-block-in-edges b) + for b = (comp-edge-src e) + for in-frame = (comp-block-final-frame b) + collect (list (comp-vec-aref in-frame slot-n) + (comp-block-name b)))))) + + (cl-loop for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop for (op . args) in (comp-block-insns b) + when (eq op 'phi) + do (finalize-phi args b))))) + +(defun comp-remove-unreachable-blocks () + "Remove unreachable basic blocks. +Return t when one or more block was removed, nil otherwise." + (cl-loop + with ret + for bb being each hash-value of (comp-func-blocks comp-func) + for bb-name = (comp-block-name bb) + when (and (not (eq 'entry bb-name)) + (null (comp-block-idom bb))) + do + (comp-log (format "Removing block: %s" bb-name) 1) + (remhash bb-name (comp-func-blocks comp-func)) + (setf (comp-func-ssa-status comp-func) t + ret t) + finally return ret)) + +(defun comp-ssa () + "Port all functions into minimal SSA form." + (maphash (lambda (_ f) + (let* ((comp-func f) + (ssa-status (comp-func-ssa-status f))) + (unless (eq ssa-status t) + (cl-loop + when (eq ssa-status 'dirty) + do (comp-clean-ssa f) + do (comp-compute-edges) + (comp-compute-dominator-tree) + until (null (comp-remove-unreachable-blocks))) + (comp-compute-dominator-frontiers) + (comp-log-block-info) + (comp-place-phis) + (comp-ssa-rename) + (comp-finalize-phis) + (comp-log-func comp-func 3) + (setf (comp-func-ssa-status f) t)))) + (comp-ctxt-funcs-h comp-ctxt))) + + +;;; propagate pass specific code. +;; A very basic propagation pass follows. +;; This propagates values and types plus ref property in the control flow graph. +;; This is also responsible for removing function calls to pure functions if +;; possible. + +(defconst comp-fwprop-max-insns-scan 4500 + ;; Chosen as ~ the greatest required value for full convergence + ;; native compiling all Emacs code-base. + "Max number of scanned insn before giving-up.") + +(defun comp-copy-insn (insn) + "Deep copy INSN." + ;; Adapted from `copy-tree'. + (if (consp insn) + (let (result) + (while (consp insn) + (let ((newcar (car insn))) + (if (or (consp (car insn)) (comp-mvar-p (car insn))) + (setf newcar (comp-copy-insn (car insn)))) + (push newcar result)) + (setf insn (cdr insn))) + (nconc (nreverse result) + (if (comp-mvar-p insn) (comp-copy-insn insn) insn))) + (if (comp-mvar-p insn) + (copy-comp-mvar insn) + insn))) + +(defmacro comp-apply-in-env (func &rest args) + "Apply FUNC to ARGS in the current compilation environment." + `(let ((env (cl-loop + for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt) + for func-name = (comp-func-name f) + for byte-code = (comp-func-byte-func f) + when func-name + collect `(,func-name . ,(symbol-function func-name)) + and do + (setf (symbol-function func-name) byte-code)))) + (unwind-protect + (apply ,func ,@args) + (cl-loop + for (func-name . def) in env + do (setf (symbol-function func-name) def))))) + +(defun comp-fwprop-prologue () + "Prologue for the propagate pass. +Here goes everything that can be done not iteratively (read once). +Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or invoked? + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn in (comp-block-insns b) + do (pcase insn + (`(setimm ,lval ,v) + (setf (comp-cstr-imm lval) v)))))) + +(defun comp-mvar-propagate (lval rval) + "Propagate into LVAL properties of RVAL." + (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval) + (comp-mvar-valset lval) (comp-mvar-valset rval) + (comp-mvar-range lval) (comp-mvar-range rval) + (comp-mvar-neg lval) (comp-mvar-neg rval))) + +(defun comp-function-foldable-p (f args) + "Given function F called with ARGS, return non-nil when optimizable." + (and (comp-function-pure-p f) + (cl-every #'comp-cstr-imm-vld-p args))) + +(defun comp-function-call-maybe-fold (insn f args) + "Given INSN, when F is pure if all ARGS are known, remove the function call. +Return non-nil if the function is folded successfully." + (cl-flet ((rewrite-insn-as-setimm (insn value) + ;; See `comp-emit-setimm'. + (comp-add-const-to-relocs value) + (setf (car insn) 'setimm + (cddr insn) `(,value)))) + (cond + ((eq f 'symbol-value) + (when-let* ((arg0 (car args)) + (const (comp-cstr-imm-vld-p arg0)) + (ok-to-optim (member (comp-cstr-imm arg0) + comp-symbol-values-optimizable))) + (rewrite-insn-as-setimm insn (symbol-value (comp-cstr-imm + (car args)))))) + ((comp-function-foldable-p f args) + (ignore-errors + ;; No point to complain here in case of error because we + ;; should do basic block pruning in order to be sure that this + ;; is not dead-code. This is now left to gcc, to be + ;; implemented only if we want a reliable diagnostic here. + (let* ((f (if-let (f-in-ctxt (comp-symbol-func-to-fun f)) + ;; If the function is IN the compilation ctxt + ;; and know to be pure. + (comp-func-byte-func f-in-ctxt) + f)) + (value (comp-apply-in-env f (mapcar #'comp-cstr-imm args)))) + (rewrite-insn-as-setimm insn value))))))) + +(defun comp-fwprop-call (insn lval f args) + "Propagate on a call INSN into LVAL. +F is the function being called with arguments ARGS. +Fold the call in case." + (unless (comp-function-call-maybe-fold insn f args) + (when (and (eq 'funcall f) + (comp-cstr-imm-vld-p (car args))) + (setf f (comp-cstr-imm (car args)) + args (cdr args))) + (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) + (let ((cstr (comp-cstr-f-ret cstr-f))) + (when (comp-cstr-empty-p cstr) + ;; Store it to be rewritten as non local exit. + (setf (comp-block-lap-non-ret-insn comp-block) insn)) + (setf (comp-mvar-range lval) (comp-cstr-range cstr) + (comp-mvar-valset lval) (comp-cstr-valset cstr) + (comp-mvar-typeset lval) (comp-cstr-typeset cstr) + (comp-mvar-neg lval) (comp-cstr-neg cstr)))) + (cl-case f + (+ (comp-cstr-add lval args)) + (- (comp-cstr-sub lval args)) + (1+ (comp-cstr-add lval `(,(car args) ,comp-cstr-one))) + (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one)))))) + +(defun comp-fwprop-insn (insn) + "Propagate within INSN." + (pcase insn + (`(set ,lval ,rval) + (pcase rval + (`(,(or 'call 'callref) ,f . ,args) + (comp-fwprop-call insn lval f args)) + (`(,(or 'direct-call 'direct-callref) ,f . ,args) + (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) + (comp-fwprop-call insn lval f args))) + (_ + (comp-mvar-propagate lval rval)))) + (`(assume ,lval ,(and (pred comp-mvar-p) rval)) + (comp-mvar-propagate lval rval)) + (`(assume ,lval (,kind . ,operands)) + (cl-case kind + (and + (apply #'comp-cstr-intersection lval operands)) + (and-nhc + (apply #'comp-cstr-intersection-no-hashcons lval operands)) + (not + ;; Prevent double negation! + (unless (comp-cstr-neg (car operands)) + (comp-cstr-value-negation lval (car operands)))) + (> + (comp-cstr-> lval (car operands) (cadr operands))) + (>= + (comp-cstr->= lval (car operands) (cadr operands))) + (< + (comp-cstr-< lval (car operands) (cadr operands))) + (<= + (comp-cstr-<= lval (car operands) (cadr operands))) + (= + (comp-cstr-= lval (car operands) (cadr operands))))) + (`(setimm ,lval ,v) + (setf (comp-cstr-imm lval) v)) + (`(phi ,lval . ,rest) + (let* ((from-latch (cl-some + (lambda (x) + (let* ((bb-name (cadr x)) + (bb (gethash bb-name + (comp-func-blocks comp-func)))) + (or (comp-latch-p bb) + (when (comp-block-cstr-p bb) + (comp-latch-p (car (comp-block-preds bb))))))) + rest)) + (prop-fn (if from-latch + #'comp-cstr-union-no-range + #'comp-cstr-union)) + (rvals (mapcar #'car rest))) + (apply prop-fn lval rvals))))) + +(defun comp-fwprop* () + "Propagate for set* and phi operands. +Return t if something was changed." + (cl-loop named outer + with modified = nil + with i = 0 + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + with comp-block = b + for insn in (comp-block-insns b) + for orig-insn = (unless modified + ;; Save consing after 1st change. + (comp-copy-insn insn)) + do + (comp-fwprop-insn insn) + (cl-incf i) + when (and (null modified) (not (equal insn orig-insn))) + do (setf modified t)) + when (> i comp-fwprop-max-insns-scan) + do (cl-return-from outer nil) + finally return modified)) + +(defun comp-rewrite-non-locals () + "Make explicit in LIMPLE non-local exits if identified." + (cl-loop + for bb being each hash-value of (comp-func-blocks comp-func) + for non-local-insn = (and (comp-block-lap-p bb) + (comp-block-lap-non-ret-insn bb)) + when non-local-insn + do + ;; Rework the current block. + (let* ((insn-seq (memq non-local-insn (comp-block-insns bb)))) + (setf (comp-block-lap-non-ret-insn bb) () + (comp-block-lap-no-ret bb) t + (comp-block-out-edges bb) () + ;; Prune unnecessary insns! + (cdr insn-seq) '((unreachable)) + (comp-func-ssa-status comp-func) 'dirty)))) + +(defun comp-fwprop (_) + "Forward propagate types and consts within the lattice." + (comp-ssa) + (comp-dead-code) + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 2) + ;; FIXME remove the following condition when tested. + (not (comp-func-has-non-local f))) + (let ((comp-func f)) + (comp-fwprop-prologue) + (cl-loop + for i from 1 to 100 + while (comp-fwprop*) + finally + (when (= i 100) + (display-warning + 'comp + (format "fwprop pass jammed into %s?" (comp-func-name f)))) + (comp-log (format "Propagation run %d times\n" i) 2)) + (comp-rewrite-non-locals) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) + + +;;; Call optimizer pass specific code. +;; This pass is responsible for the following optimizations: +;; - Call to subrs that are in defined in the C source and are passing through +;; funcall trampoline gets optimized into normal indirect calls. +;; This makes effectively this calls equivalent to all the subrs that got +;; dedicated byte-code ops. +;; Triggered at native-comp-speed >= 2. +;; - Recursive calls gets optimized into direct calls. +;; Triggered at native-comp-speed >= 2. +;; - Intra compilation unit procedure calls gets optimized into direct calls. +;; This can be a big win and even allow gcc to inline but does not make +;; function in the compilation unit re-definable safely without recompiling +;; the full compilation unit. +;; For this reason this is triggered only at native-comp-speed == 3. + +(defun comp-func-in-unit (func) + "Given FUNC return the `comp-fun' definition in the current context. +FUNCTION can be a function-name or byte compiled function." + (if (symbolp func) + (comp-symbol-func-to-fun func) + (cl-assert (byte-code-function-p func)) + (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt)))) + +(defun comp-call-optim-form-call (callee args) + (cl-flet ((fill-args (args total) + ;; Fill missing args to reach TOTAL + (append args (cl-loop repeat (- total (length args)) + collect (make-comp-mvar :constant nil))))) + (when (and callee + (or (symbolp callee) + (gethash callee (comp-ctxt-byte-func-to-func-h comp-ctxt))) + (not (memq callee native-comp-never-optimize-functions))) + (let* ((f (if (symbolp callee) + (symbol-function callee) + (cl-assert (byte-code-function-p callee)) + callee)) + (subrp (subrp f)) + (comp-func-callee (comp-func-in-unit callee))) + (cond + ((and subrp (not (subr-native-elisp-p f))) + ;; Trampoline removal. + (let* ((callee (intern (subr-name f))) ; Fix aliased names. + (maxarg (cdr (subr-arity f))) + (call-type (if (if subrp + (not (numberp maxarg)) + (comp-nargs-p comp-func-callee)) + 'callref + 'call)) + (args (if (eq call-type 'callref) + args + (fill-args args maxarg)))) + `(,call-type ,callee ,@args))) + ;; Intra compilation unit procedure call optimization. + ;; Attention speed 3 triggers this for non self calls too!! + ((and comp-func-callee + (comp-func-c-name comp-func-callee) + (or (and (>= (comp-func-speed comp-func) 3) + (comp-func-unique-in-cu-p callee)) + (and (>= (comp-func-speed comp-func) 2) + ;; Anonymous lambdas can't be redefined so are + ;; always safe to optimize. + (byte-code-function-p callee)))) + (let* ((func-args (comp-func-l-args comp-func-callee)) + (nargs (comp-nargs-p func-args)) + (call-type (if nargs 'direct-callref 'direct-call)) + (args (if (eq call-type 'direct-callref) + args + (fill-args args (comp-args-max func-args))))) + `(,call-type ,(comp-func-c-name comp-func-callee) ,@args))) + ((comp-type-hint-p callee) + `(call ,callee ,@args))))))) + +(defun comp-call-optim-func () + "Perform the trampoline call optimization for the current function." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (comp-loop-insn-in-block b + (pcase insn + (`(set ,lval (callref funcall ,f . ,rest)) + (when-let ((ok (comp-cstr-imm-vld-p f)) + (new-form (comp-call-optim-form-call + (comp-cstr-imm f) rest))) + (setf insn `(set ,lval ,new-form)))) + (`(callref funcall ,f . ,rest) + (when-let ((ok (comp-cstr-imm-vld-p f)) + (new-form (comp-call-optim-form-call + (comp-cstr-imm f) rest))) + (setf insn new-form))))))) + +(defun comp-call-optim (_) + "Try to optimize out funcall trampoline usage when possible." + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 2) + (comp-func-l-p f)) + (let ((comp-func f)) + (comp-call-optim-func)))) + (comp-ctxt-funcs-h comp-ctxt))) + + +;;; Dead code elimination pass specific code. +;; This simple pass try to eliminate insns became useful after propagation. +;; Even if gcc would take care of this is good to perform this here +;; in the hope of removing memory references. +;; +;; This pass can be run as last optim. + +(defun comp-collect-mvar-ids (insn) + "Collect the m-var unique identifiers into INSN." + (cl-loop for x in insn + if (consp x) + append (comp-collect-mvar-ids x) + else + when (comp-mvar-p x) + collect (comp-mvar-id x))) + +(defun comp-dead-assignments-func () + "Clean-up dead assignments into current function. +Return the list of m-var ids nuked." + (let ((l-vals ()) + (r-vals ())) + ;; Collect used r and l-values. + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn in (comp-block-insns b) + for (op arg0 . rest) = insn + if (comp-assign-op-p op) + do (push (comp-mvar-id arg0) l-vals) + (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) + else + do (setf r-vals (nconc (comp-collect-mvar-ids insn) r-vals)))) + ;; Every l-value appearing that does not appear as r-value has no right to + ;; exist and gets nuked. + (let ((nuke-list (cl-set-difference l-vals r-vals))) + (comp-log (format "Function %s\nl-vals %s\nr-vals %s\nNuking ids: %s\n" + (comp-func-name comp-func) + l-vals + r-vals + nuke-list) + 3) + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (comp-loop-insn-in-block b + (cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn + (when (and (comp-assign-op-p op) + (memq (comp-mvar-id arg0) nuke-list)) + (setf insn + (if (comp-limple-insn-call-p arg1) + arg1 + `(comment ,(format "optimized out: %s" + insn)))))))) + nuke-list))) + +(defun comp-dead-code () + "Dead code elimination." + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 2) + ;; FIXME remove the following condition when tested. + (not (comp-func-has-non-local f))) + (cl-loop + for comp-func = f + for i from 1 + while (comp-dead-assignments-func) + finally (comp-log (format "dead code rm run %d times\n" i) 2) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) + + +;;; Tail Call Optimization pass specific code. + +(defun comp-form-tco-call-seq (args) + "Generate a TCO sequence for ARGS." + `(,@(cl-loop for arg in args + for i from 0 + collect `(set ,(make-comp-mvar :slot i) ,arg)) + (jump bb_0))) + +(defun comp-tco-func () + "Try to pattern match and perform TCO within the current function." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + named in-the-basic-block + for insns-seq on (comp-block-insns b) + do (pcase insns-seq + (`((set ,l-val (direct-call ,func . ,args)) + ;; (comment ,_comment) + (return ,ret-val)) + (when (and (string= func (comp-func-c-name comp-func)) + (eq l-val ret-val)) + (let ((tco-seq (comp-form-tco-call-seq args))) + (setf (car insns-seq) (car tco-seq) + (cdr insns-seq) (cdr tco-seq) + (comp-func-ssa-status comp-func) 'dirty) + (cl-return-from in-the-basic-block)))))))) + +(defun comp-tco (_) + "Simple peephole pass performing self TCO." + (maphash (lambda (_ f) + (when (and (>= (comp-func-speed f) 3) + (comp-func-l-p f) + (not (comp-func-has-non-local f))) + (let ((comp-func f)) + (comp-tco-func) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) + + +;;; Type hint removal pass specific code. + +;; This must run after all SSA prop not to have the type hint +;; information overwritten. + +(defun comp-remove-type-hints-func () + "Remove type hints from the current function. +These are substituted with a normal 'set' op." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (comp-loop-insn-in-block b + (pcase insn + (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val)) + (setf insn `(set ,l-val ,r-val))))))) + +(defun comp-remove-type-hints (_) + "Dead code elimination." + (maphash (lambda (_ f) + (when (>= (comp-func-speed f) 2) + (let ((comp-func f)) + (comp-remove-type-hints-func) + (comp-log-func comp-func 3)))) + (comp-ctxt-funcs-h comp-ctxt))) + + +;;; Final pass specific code. + +(defun comp-args-to-lambda-list (args) + "Return a lambda list for ARGS." + (cl-loop + with res + repeat (comp-args-base-min args) + do (push t res) + finally + (if (comp-args-p args) + (cl-loop + with n = (- (comp-args-max args) (comp-args-min args)) + initially (unless (zerop n) + (push '&optional res)) + repeat n + do (push t res)) + (cl-loop + with n = (- (comp-nargs-nonrest args) (comp-nargs-min args)) + initially (unless (zerop n) + (push '&optional res)) + repeat n + do (push t res) + finally (when (comp-nargs-rest args) + (push '&rest res) + (push 't res)))) + (cl-return (reverse res)))) + +(defun comp-compute-function-type (_ func) + "Compute type specifier for `comp-func' FUNC. +Set it into the `type' slot." + (when (and (comp-func-l-p func) + (comp-mvar-p (comp-func-type func))) + (let* ((comp-func (make-comp-func)) + (res-mvar (apply #'comp-cstr-union + (make-comp-cstr) + (cl-loop + with res = nil + for bb being the hash-value in (comp-func-blocks + func) + do (cl-loop + for insn in (comp-block-insns bb) + ;; Collect over every exit point the returned + ;; mvars and union results. + do (pcase insn + (`(return ,mvar) + (push mvar res)))) + finally return res))) + (type `(function ,(comp-args-to-lambda-list (comp-func-l-args func)) + ,(comp-cstr-to-type-spec res-mvar)))) + (comp-add-const-to-relocs type) + ;; Fix it up. + (setf (comp-cstr-imm (comp-func-type func)) type)))) + +(defun comp-finalize-container (cont) + "Finalize data container CONT." + (setf (comp-data-container-l cont) + (cl-loop with h = (comp-data-container-idx cont) + for obj each hash-keys of h + for i from 0 + do (puthash obj i h) + ;; Prune byte-code objects coming from lambdas. + ;; These are not anymore necessary as they will be + ;; replaced at load time by native-elisp-subrs. + ;; Note: we leave the objects in the idx hash table + ;; to still be able to retrieve the correct index + ;; from the corresponding m-var. + collect (if (gethash obj + (comp-ctxt-byte-func-to-func-h comp-ctxt)) + 'lambda-fixup + obj)))) + +(defun comp-finalize-relocs () + "Finalize data containers for each relocation class. +Remove immediate duplicates within relocation classes. +Update all insn accordingly." + ;; Symbols imported by C inlined functions. We do this here because + ;; is better to add all objs to the relocation containers before we + ;; compacting them. + (mapc #'comp-add-const-to-relocs '(nil t consp listp)) + + (let* ((d-default (comp-ctxt-d-default comp-ctxt)) + (d-default-idx (comp-data-container-idx d-default)) + (d-impure (comp-ctxt-d-impure comp-ctxt)) + (d-impure-idx (comp-data-container-idx d-impure)) + (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt)) + (d-ephemeral-idx (comp-data-container-idx d-ephemeral))) + ;; We never want compiled lambdas ending up in pure space. A copy must + ;; be already present in impure (see `comp-emit-lambda-for-top-level'). + (cl-loop for obj being each hash-keys of d-default-idx + when (gethash obj (comp-ctxt-lambda-fixups-h comp-ctxt)) + do (cl-assert (gethash obj d-impure-idx)) + (remhash obj d-default-idx)) + ;; Remove entries in d-impure already present in d-default. + (cl-loop for obj being each hash-keys of d-impure-idx + when (gethash obj d-default-idx) + do (remhash obj d-impure-idx)) + ;; Remove entries in d-ephemeral already present in d-default or + ;; d-impure. + (cl-loop for obj being each hash-keys of d-ephemeral-idx + when (or (gethash obj d-default-idx) (gethash obj d-impure-idx)) + do (remhash obj d-ephemeral-idx)) + ;; Fix-up indexes in each relocation class and fill corresponding + ;; reloc lists. + (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral)) + ;; Make a vector from the function documentation hash table. + (cl-loop with h = (comp-ctxt-function-docs comp-ctxt) + with v = (make-vector (hash-table-count h) nil) + for idx being each hash-keys of h + for doc = (gethash idx h) + do (setf (aref v idx) doc) + finally + do (setf (comp-ctxt-function-docs comp-ctxt) v)) + ;; And now we conclude with the following: We need to pass to + ;; `comp--register-lambda' the index in the impure relocation + ;; array to store revived lambdas, but given we know it only now + ;; we fix it up as last. + (cl-loop for f being each hash-keys of (comp-ctxt-lambda-fixups-h comp-ctxt) + using (hash-value mvar) + with reverse-h = (make-hash-table) ;; Make sure idx is unique. + for idx = (gethash f d-impure-idx) + do + (cl-assert (null (gethash idx reverse-h))) + (cl-assert (fixnump idx)) + (setf (comp-mvar-valset mvar) () + (comp-mvar-range mvar) (list (cons idx idx))) + (puthash idx t reverse-h)))) + +(defun comp-compile-ctxt-to-file (name) + "Compile as native code the current context naming it NAME. +Prepare every function for final compilation and drive the C back-end." + (let ((dir (file-name-directory name))) + (comp-finalize-relocs) + (maphash (lambda (_ f) + (comp-log-func f 1)) + (comp-ctxt-funcs-h comp-ctxt)) + (unless (file-exists-p dir) + ;; In case it's created in the meanwhile. + (ignore-error file-already-exists + (make-directory dir t))) + (comp--compile-ctxt-to-file name))) + +(defun comp-final1 () + (let (compile-result) + (comp--init-ctxt) + (unwind-protect + (setf compile-result + (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt))) + (and (comp--release-ctxt) + compile-result)))) + +(defvar comp-async-compilation nil + "Non-nil while executing an asynchronous native compilation.") + +(defun comp-final (_) + "Final pass driving the C back-end for code emission." + (maphash #'comp-compute-function-type (comp-ctxt-funcs-h comp-ctxt)) + (unless comp-dry-run + ;; Always run the C side of the compilation as a sub-process + ;; unless during bootstrap or async compilation (bug#45056). GCC + ;; leaks memory but also interfere with the ability of Emacs to + ;; detect when a sub-process completes (TODO understand why). + (if (or byte+native-compile comp-async-compilation) + (comp-final1) + ;; Call comp-final1 in a child process. + (let* ((output (comp-ctxt-output comp-ctxt)) + (print-escape-newlines t) + (print-length nil) + (print-level nil) + (print-quoted t) + (print-gensym t) + (print-circle t) + (print-escape-multibyte t) + (expr `((require 'comp) + (setf native-comp-verbose ,native-comp-verbose + comp-libgccjit-reproducer ,comp-libgccjit-reproducer + comp-ctxt ,comp-ctxt + native-comp-eln-load-path ',native-comp-eln-load-path + native-comp-driver-options + ',native-comp-driver-options + load-path ',load-path) + ,native-comp-async-env-modifier-form + (message "Compiling %s..." ',output) + (comp-final1))) + (temp-file (make-temp-file + (concat "emacs-int-comp-" + (file-name-base output) "-") + nil ".el"))) + (with-temp-file temp-file + (insert ";; -*-coding: nil; -*-\n") + (mapc (lambda (e) + (insert (prin1-to-string e))) + expr)) + (with-temp-buffer + (unwind-protect + (if (zerop + (call-process (expand-file-name invocation-name + invocation-directory) + nil t t "--batch" "-l" temp-file)) + (progn + (delete-file temp-file) + output) + (signal 'native-compiler-error (buffer-string))) + (comp-log-to-buffer (buffer-string)))))))) + + +;;; Compiler type hints. +;; Public entry points to be used by user code to give comp +;; suggestions about types. These are used to implement CL style +;; `cl-the' and hopefully parameter type declaration. +;; Note: types will propagates. +;; WARNING: At speed >= 2 type checking is not performed anymore and suggestions +;; are assumed just to be true. Use with extreme caution... + +(defun comp-hint-fixnum (x) + (declare (gv-setter (lambda (val) `(setf ,x ,val)))) + x) + +(defun comp-hint-cons (x) + (declare (gv-setter (lambda (val) `(setf ,x ,val)))) + x) + + +;; Primitive function advice machinery + +(defun comp-eln-load-path-eff () + "Return a list of effective eln load directories. +Account for `native-comp-eln-load-path' and `comp-native-version-dir'." + (mapcar (lambda (dir) + (expand-file-name comp-native-version-dir + (file-name-as-directory + (expand-file-name dir invocation-directory)))) + native-comp-eln-load-path)) + +(defun comp-trampoline-filename (subr-name) + "Given SUBR-NAME return the filename containing the trampoline." + (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln")) + +(defun comp-make-lambda-list-from-subr (subr) + "Given SUBR return the equivalent lambda-list." + (pcase-let ((`(,min . ,max) (subr-arity subr)) + (lambda-list '())) + (cl-loop repeat min + do (push (gensym "arg") lambda-list)) + (if (numberp max) + (cl-loop + initially (push '&optional lambda-list) + repeat (- max min) + do (push (gensym "arg") lambda-list)) + (push '&rest lambda-list) + (push (gensym "arg") lambda-list)) + (reverse lambda-list))) + +(defun comp-trampoline-search (subr-name) + "Search a trampoline file for SUBR-NAME. +Return the trampoline if found or nil otherwise." + (cl-loop + with rel-filename = (comp-trampoline-filename subr-name) + for dir in (comp-eln-load-path-eff) + for filename = (expand-file-name rel-filename dir) + when (file-exists-p filename) + do (cl-return (native-elisp-load filename)))) + +(defun comp-trampoline-compile (subr-name) + "Synthesize compile and return a trampoline for SUBR-NAME." + (let* ((lambda-list (comp-make-lambda-list-from-subr + (symbol-function subr-name))) + ;; The synthesized trampoline must expose the exact same ABI of + ;; the primitive we are replacing in the function reloc table. + (form `(lambda ,lambda-list + (let ((f #',subr-name)) + (,(if (memq '&rest lambda-list) #'apply 'funcall) + f + ,@(cl-loop + for arg in lambda-list + unless (memq arg '(&optional &rest)) + collect arg))))) + ;; Use speed 0 to maximize compilation speed and not to + ;; optimize away funcall calls! + (byte-optimize nil) + (native-comp-speed 1) + (lexical-binding t)) + (comp--native-compile + form nil + (cl-loop + for dir in (comp-eln-load-path-eff) + for f = (expand-file-name + (comp-trampoline-filename subr-name) + dir) + unless (file-exists-p dir) + do (ignore-errors + (make-directory dir t) + (cl-return f)) + when (file-writable-p f) + do (cl-return f) + finally (error "Cannot find suitable directory for output in \ +`native-comp-eln-load-path'"))))) + + +;; Some entry point support code. + +;;;###autoload +(defun comp-clean-up-stale-eln (file) + "Given FILE remove all its *.eln files in `native-comp-eln-load-path' +sharing the original source filename (including FILE)." + (when (string-match (rx "-" (group-n 1 (1+ hex)) "-" (1+ hex) ".eln" eos) + file) + (cl-loop + with filename-hash = (match-string 1 file) + with regexp = (rx-to-string + `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos)) + for dir in (comp-eln-load-path-eff) + do (cl-loop + for f in (when (file-exists-p dir) + (directory-files dir t regexp t)) + ;; We may not be able to delete the file if we have no write + ;; permission. + do (ignore-error file-error + (comp-delete-or-replace-file f)))))) + +(defun comp-delete-or-replace-file (oldfile &optional newfile) + "Replace OLDFILE with NEWFILE. +When NEWFILE is nil just delete OLDFILE. +Takes the necessary steps when dealing with OLDFILE being a +shared library that might be currently loaded into a running Emacs +session." + (cond ((eq 'windows-nt system-type) + (ignore-errors (delete-file oldfile)) + (while + (condition-case _ + (progn + ;; oldfile maybe recreated by another Emacs in + ;; between the following two rename-file calls + (if (file-exists-p oldfile) + (rename-file oldfile (make-temp-file-internal + (file-name-sans-extension oldfile) + nil ".eln.old" nil) + t)) + (when newfile + (rename-file newfile oldfile nil)) + ;; Keep on trying. + nil) + (file-already-exists + ;; Done + t)))) + ;; Remove the old eln instead of copying the new one into it + ;; to get a new inode and prevent crashes in case the old one + ;; is currently loaded. + (t (delete-file oldfile) + (when newfile + (rename-file newfile oldfile))))) + +(defvar comp-files-queue () + "List of Emacs Lisp files to be compiled.") + +(defvar comp-async-compilations (make-hash-table :test #'equal) + "Hash table file-name -> async compilation process.") + +(defun comp-async-runnings () + "Return the number of async compilations currently running. +This function has the side effect of cleaning-up finished +processes from `comp-async-compilations'" + (cl-loop + for file-name in (cl-loop + for file-name being each hash-key of comp-async-compilations + for prc = (gethash file-name comp-async-compilations) + unless (process-live-p prc) + collect file-name) + do (remhash file-name comp-async-compilations)) + (hash-table-count comp-async-compilations)) + +(declare-function w32-get-nproc "w32.c") +(defvar comp-num-cpus nil) +(defun comp-effective-async-max-jobs () + "Compute the effective number of async jobs." + (if (zerop native-comp-async-jobs-number) + (or comp-num-cpus + (setf comp-num-cpus + ;; FIXME: we already have a function to determine + ;; the number of processors, see get_native_system_info in w32.c. + ;; The result needs to be exported to Lisp. + (max 1 (/ (cond ((eq 'windows-nt system-type) + (w32-get-nproc)) + ((executable-find "nproc") + (string-to-number + (shell-command-to-string "nproc"))) + ((eq 'berkeley-unix system-type) + (string-to-number + (shell-command-to-string "sysctl -n hw.ncpu"))) + (t 1)) + 2)))) + native-comp-async-jobs-number)) + +(defvar comp-last-scanned-async-output nil) +(make-variable-buffer-local 'comp-last-scanned-async-output) +(defun comp-accept-and-process-async-output (process) + "Accept PROCESS output and check for diagnostic messages." + (if native-comp-async-report-warnings-errors + (let ((warning-suppress-types + (if (eq native-comp-async-report-warnings-errors 'silent) + (cons '(comp) warning-suppress-types) + warning-suppress-types))) + (with-current-buffer (process-buffer process) + (save-excursion + (accept-process-output process) + (goto-char (or comp-last-scanned-async-output (point-min))) + (while (re-search-forward "^.*?\\(?:Error\\|Warning\\): .*$" + nil t) + (display-warning 'comp (match-string 0))) + (setq comp-last-scanned-async-output (point-max))))) + (accept-process-output process))) + +(defun comp-run-async-workers () + "Start compiling files from `comp-files-queue' asynchronously. +When compilation is finished, run `native-comp-async-all-done-hook' and +display a message." + (if (or comp-files-queue + (> (comp-async-runnings) 0)) + (unless (>= (comp-async-runnings) (comp-effective-async-max-jobs)) + (cl-loop + for (source-file . load) = (pop comp-files-queue) + while source-file + do (cl-assert (string-match-p comp-valid-source-re source-file) nil + "`comp-files-queue' should be \".el\" files: %s" + source-file) + when (or native-comp-always-compile + load ; Always compile when the compilation is + ; commanded for late load. + (file-newer-than-file-p + source-file (comp-el-to-eln-filename source-file))) + do (let* ((expr `((require 'comp) + ,(when (boundp 'backtrace-line-length) + `(setf backtrace-line-length ,backtrace-line-length)) + (setf native-compile-target-directory ,native-compile-target-directory + native-comp-speed ,native-comp-speed + native-comp-debug ,native-comp-debug + native-comp-verbose ,native-comp-verbose + comp-libgccjit-reproducer ,comp-libgccjit-reproducer + comp-async-compilation t + native-comp-eln-load-path ',native-comp-eln-load-path + native-comp-driver-options + ',native-comp-driver-options + load-path ',load-path + warning-fill-column most-positive-fixnum) + ,native-comp-async-env-modifier-form + (message "Compiling %s..." ,source-file) + (comp--native-compile ,source-file ,(and load t)))) + (source-file1 source-file) ;; Make the closure works :/ + (temp-file (make-temp-file + (concat "emacs-async-comp-" + (file-name-base source-file) "-") + nil ".el")) + (expr-strings (let ((print-length nil) + (print-level nil)) + (mapcar #'prin1-to-string expr))) + (_ (progn + (with-temp-file temp-file + (mapc #'insert expr-strings)) + (comp-log "\n") + (mapc #'comp-log expr-strings))) + (load1 load) + (process (make-process + :name (concat "Compiling: " source-file) + :buffer (with-current-buffer + (get-buffer-create + comp-async-buffer-name) + (setf buffer-read-only t) + (current-buffer)) + :command (list + (expand-file-name invocation-name + invocation-directory) + "--batch" "-l" temp-file) + :sentinel + (lambda (process _event) + (run-hook-with-args + 'native-comp-async-cu-done-functions + source-file) + (comp-accept-and-process-async-output process) + (ignore-errors (delete-file temp-file)) + (let ((eln-file (comp-el-to-eln-filename + source-file1))) + (when (and load1 + (zerop (process-exit-status + process)) + (file-exists-p eln-file)) + (native-elisp-load eln-file + (eq load1 'late)))) + (comp-run-async-workers)) + :noquery (not native-comp-async-query-on-exit)))) + (puthash source-file process comp-async-compilations)) + when (>= (comp-async-runnings) (comp-effective-async-max-jobs)) + do (cl-return))) + ;; No files left to compile and all processes finished. + (run-hooks 'native-comp-async-all-done-hook) + (with-current-buffer (get-buffer-create comp-async-buffer-name) + (save-excursion + (let ((buffer-read-only nil)) + (goto-char (point-max)) + (insert "Compilation finished.\n")))) + ;; `comp-deferred-pending-h' should be empty at this stage. + ;; Reset it anyway. + (clrhash comp-deferred-pending-h))) + +(defun comp--native-compile (function-or-file &optional with-late-load output) + "Compile FUNCTION-OR-FILE into native code. +When WITH-LATE-LOAD is non-nil, mark the compilation unit for late +load once it finishes compiling. +This serves as internal implementation of `native-compile' but +allowing for WITH-LATE-LOAD to be controlled is in use also for +the deferred compilation mechanism." + (comp-ensure-native-compiler) + (unless (or (functionp function-or-file) + (stringp function-or-file)) + (signal 'native-compiler-error + (list "Not a function symbol or file" function-or-file))) + (catch 'no-native-compile + (let* ((data function-or-file) + (comp-native-compiling t) + (byte-native-qualities nil) + ;; Have byte compiler signal an error when compilation fails. + (byte-compile-debug t) + (comp-ctxt (make-comp-ctxt :output output + :with-late-load with-late-load))) + (comp-log "\n \n" 1) + (condition-case err + (cl-loop + with report = nil + for t0 = (current-time) + for pass in comp-passes + unless (memq pass comp-disabled-passes) + do + (comp-log (format "(%s) Running pass %s:\n" + function-or-file pass) + 2) + (setf data (funcall pass data)) + (push (cons pass (float-time (time-since t0))) report) + (cl-loop for f in (alist-get pass comp-post-pass-hooks) + do (funcall f data)) + finally + (when comp-log-time-report + (comp-log (format "Done compiling %s" data) 0) + (cl-loop for (pass . time) in (reverse report) + do (comp-log (format "Pass %s took: %fs." pass time) 0)))) + (native-compiler-skip) + (t + (let ((err-val (cdr err))) + ;; If we are doing an async native compilation print the + ;; error in the correct format so is parsable and abort. + (if (and comp-async-compilation + (not (eq (car err) 'native-compiler-error))) + (progn + (message (if err-val + "%s: Error: %s %s" + "%s: Error %s") + function-or-file + (get (car err) 'error-message) + (car-safe err-val)) + (kill-emacs -1)) + ;; Otherwise re-signal it adding the compilation input. + (signal (car err) (if (consp err-val) + (cons function-or-file err-val) + (list function-or-file err-val))))))) + (if (stringp function-or-file) + data + ;; So we return the compiled function. + (native-elisp-load data))))) + +(defun native-compile-async-skip-p (file load selector) + "Return non-nil if FILE's compilation should be skipped. + +LOAD and SELECTOR work as described in `native--compile-async'." + ;; Make sure we are not already compiling `file' (bug#40838). + (or (gethash file comp-async-compilations) + (cond + ((null selector) nil) + ((functionp selector) (not (funcall selector file))) + ((stringp selector) (not (string-match-p selector file))) + (t (error "SELECTOR must be a function a regexp or nil"))) + ;; Also exclude files from deferred compilation if + ;; any of the regexps in + ;; `native-comp-deferred-compilation-deny-list' matches. + (and (eq load 'late) + (cl-some (lambda (re) + (string-match-p re file)) + native-comp-deferred-compilation-deny-list)))) + +(defun native--compile-async (files &optional recursively load selector) + "Compile FILES asynchronously. +FILES is one filename or a list of filenames or directories. + +If optional argument RECURSIVELY is non-nil, recurse into +subdirectories of given directories. + +If optional argument LOAD is non-nil, request to load the file +after compiling. + +The optional argument SELECTOR has the following valid values: + +nil -- Select all files. +a string -- A regular expression selecting files with matching names. +a function -- A function selecting files with matching names. + +The variable `native-comp-async-jobs-number' specifies the number +of (commands) to run simultaneously. + +LOAD can also be the symbol `late'. This is used internally if +the byte code has already been loaded when this function is +called. It means that we request the special kind of load +necessary in that situation, called \"late\" loading. + +During a \"late\" load, instead of executing all top-level forms +of the original files, only function definitions are +loaded (paying attention to have these effective only if the +bytecode definition was not changed in the meantime)." + (comp-ensure-native-compiler) + (unless (member load '(nil t late)) + (error "LOAD must be nil, t or 'late")) + (unless (listp files) + (setf files (list files))) + (let (file-list) + (dolist (path files) + (cond ((file-directory-p path) + (dolist (file (if recursively + (directory-files-recursively + path comp-valid-source-re) + (directory-files path t comp-valid-source-re))) + (push file file-list))) + ((file-exists-p path) (push path file-list)) + (t (signal 'native-compiler-error + (list "Path not a file nor directory" path))))) + (dolist (file file-list) + (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=))) + ;; Most likely the byte-compiler has requested a deferred + ;; compilation, so update `comp-files-queue' to reflect that. + (unless (or (null load) + (eq load (cdr entry))) + (cl-substitute (cons file load) (car entry) comp-files-queue + :key #'car :test #'string=)) + + (unless (native-compile-async-skip-p file load selector) + (let* ((out-filename (comp-el-to-eln-filename file)) + (out-dir (file-name-directory out-filename))) + (unless (file-exists-p out-dir) + (make-directory out-dir t)) + (if (file-writable-p out-filename) + (setf comp-files-queue + (append comp-files-queue `((,file . ,load)))) + (display-warning 'comp + (format "No write access for %s skipping." + out-filename))))))) + (when (zerop (comp-async-runnings)) + (comp-run-async-workers)))) + + +;;; Compiler entry points. + +;;;###autoload +(defun comp-lookup-eln (filename) + "Given a Lisp source FILENAME return the corresponding .eln file if found. +Search happens in `native-comp-eln-load-path'." + (cl-loop + with eln-filename = (comp-el-to-eln-rel-filename filename) + for dir in native-comp-eln-load-path + for f = (expand-file-name eln-filename + (expand-file-name comp-native-version-dir + (expand-file-name + dir + invocation-directory))) + when (file-exists-p f) + do (cl-return f))) + +;;;###autoload +(defun native-compile (function-or-file &optional output) + "Compile FUNCTION-OR-FILE into native code. +This is the synchronous entry-point for the Emacs Lisp native +compiler. +FUNCTION-OR-FILE is a function symbol, a form, or the filename of +an Emacs Lisp source file. +If OUTPUT is non-nil, use it as the filename for the compiled +object. +If FUNCTION-OR-FILE is a filename, return the filename of the +compiled object. If FUNCTION-OR-FILE is a function symbol or a +form, return the compiled function." + (comp--native-compile function-or-file nil output)) + +;;;###autoload +(defun batch-native-compile () + "Perform native compilation on remaining command-line arguments. +Use this from the command line, with ‘-batch’; +it won’t work in an interactive Emacs. +Native compilation equivalent to `batch-byte-compile'." + (comp-ensure-native-compiler) + (cl-loop for file in command-line-args-left + if (or (null byte+native-compile) + (cl-notany (lambda (re) (string-match re file)) + native-comp-bootstrap-deny-list)) + do (comp--native-compile file) + else + do (byte-compile-file file))) + +;;;###autoload +(defun batch-byte+native-compile () + "Like `batch-native-compile', but used for bootstrap. +Generate .elc files in addition to the .eln files. +Force the produced .eln to be outputted in the eln system +directory (the last entry in `native-comp-eln-load-path') unless +`native-compile-target-directory' is non-nil. If the environment +variable 'NATIVE_DISABLED' is set, only byte compile." + (comp-ensure-native-compiler) + (if (equal (getenv "NATIVE_DISABLED") "1") + (batch-byte-compile) + (cl-assert (length= command-line-args-left 1)) + (let ((byte+native-compile t) + (byte-to-native-output-file nil)) + (batch-native-compile) + (pcase byte-to-native-output-file + (`(,tempfile . ,target-file) + (rename-file tempfile target-file t)))))) + +;;;###autoload +(defun native-compile-async (files &optional recursively load selector) + "Compile FILES asynchronously. +FILES is one file or a list of filenames or directories. + +If optional argument RECURSIVELY is non-nil, recurse into +subdirectories of given directories. + +If optional argument LOAD is non-nil, request to load the file +after compiling. + +The optional argument SELECTOR has the following valid values: + +nil -- Select all files. +a string -- A regular expression selecting files with matching names. +a function -- A function selecting files with matching names. + +The variable `native-comp-async-jobs-number' specifies the number +of (commands) to run simultaneously." + ;; Normalize: we only want to pass t or nil, never e.g. `late'. + (let ((load (not (not load)))) + (native--compile-async files recursively load selector))) + +(provide 'comp) + +;; LocalWords: limplified limplified limplification limplify Limple LIMPLE libgccjit elc eln + +;;; comp.el ends here diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index a9baef39a9a..d2e4891acee 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -51,7 +51,7 @@ This is useful for ChangeLogs." "\\(©\\|@copyright{}\\|[Cc]opyright\\s *:?\\s *\\(?:(C)\\)?\ \\|[Cc]opyright\\s *:?\\s *©\\)\ \\s *[^0-9\n]*\\s *\ -\\([1-9]\\([-0-9, ';/*%#\n\t]\\|\\s<\\|\\s>\\)*[0-9]+\\)" +\\([1-9]\\([-0-9, ';/*%#\n\t–]\\|\\s<\\|\\s>\\)*[0-9]+\\)" "What your copyright notice looks like. The second \\( \\) construct must match the years." :type 'regexp) @@ -69,7 +69,7 @@ someone else or to a group for which you do not work." ;;;###autoload(put 'copyright-names-regexp 'safe-local-variable 'stringp) (defcustom copyright-years-regexp - "\\(\\s *\\)\\([1-9]\\([-0-9, ';/*%#\n\t]\\|\\s<\\|\\s>\\)*[0-9]+\\)" + "\\(\\s *\\)\\([1-9]\\([-0-9, ';/*%#\n\t–]\\|\\s<\\|\\s>\\)*[0-9]+\\)" "Match additional copyright notice years. The second \\( \\) construct must match the years." :type 'regexp) @@ -144,11 +144,16 @@ This function sets the match-data that `copyright-update-year' uses." (with-demoted-errors "Can't update copyright: %s" ;; (1) Need the extra \\( \\) around copyright-regexp because we ;; goto (match-end 1) below. See note (2) below. - (copyright-re-search (concat "\\(" copyright-regexp - "\\)\\([ \t]*\n\\)?.*\\(?:" - copyright-names-regexp "\\)") - (copyright-limit) - t))) + (let ((regexp (concat "\\(" copyright-regexp + "\\)\\([ \t]*\n\\)?.*\\(?:" + copyright-names-regexp "\\)"))) + (when (copyright-re-search regexp (copyright-limit) t) + ;; We may accidentally have landed in the middle of a + ;; copyright line, so re-perform the search without the + ;; search. (Otherwise we may be inserting the new year in the + ;; middle of the list of years.) + (goto-char (match-beginning 0)) + (copyright-re-search regexp nil t))))) (defun copyright-find-end () "Possibly adjust the search performed by `copyright-find-copyright'. @@ -197,8 +202,8 @@ skips to the end of all the years." (point)))) 100) 1) - (or (eq (char-after (+ (point) size -1)) ?-) - (eq (char-after (+ (point) size -2)) ?-))) + (or (memq (char-after (+ (point) size -1)) '(?- ?–)) + (memq (char-after (+ (point) size -2)) '(?- ?–)))) ;; This is a range so just replace the end part. (delete-char size) ;; Insert a comma with the preferred number of spaces. @@ -287,7 +292,7 @@ independently replaces consecutive years with a range." (setq year (string-to-number (match-string 0))) (and (setq sep (char-before)) (/= (char-syntax sep) ?\s) - (/= sep ?-) + (not (memq sep '(?- ?–))) (insert " ")) (when (< year 100) (insert (if (>= year 50) "19" "20")) @@ -297,7 +302,7 @@ independently replaces consecutive years with a range." ;; If the previous thing was a range, don't try to tack more on. ;; Ie not 2000-2005 -> 2000-2005-2007 ;; TODO should merge into existing range if possible. - (if (eq sep ?-) + (if (memq sep '(?- ?–)) (setq prev-year nil year nil) (if (and prev-year (= year (1+ prev-year))) @@ -306,7 +311,7 @@ independently replaces consecutive years with a range." (> prev-year first-year)) (goto-char range-end) (delete-region range-start range-end) - (insert (format "-%d" prev-year)) + (insert (format "%c%d" sep prev-year)) (goto-char p)) (setq first-year year range-start (point))))) diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index e106815817e..d24ea355a51 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -183,8 +183,7 @@ Return t if the current element is now a valid match; otherwise return nil." Like `minibuffer-complete-word' but for `completing-read-multiple'." (interactive) (crm--completion-command beg end - (completion-in-region--single-word - beg end minibuffer-completion-table minibuffer-completion-predicate))) + (completion-in-region--single-word beg end))) (defun crm-complete-and-exit () "If all of the minibuffer elements are valid completions then exit. diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index d9da0db4551..2007f79634d 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -182,7 +182,11 @@ the debugger will not be entered." (equal "initial_terminal" (terminal-name))))) ;; Don't let `inhibit-message' get in our way (especially important if ;; `non-interactive-frame' evaluated to a non-nil value. - (inhibit-message nil)) + (inhibit-message nil) + ;; We may be entering the debugger from a context that has + ;; let-bound `inhibit-read-only', which means that all + ;; buffers would be read/write while the debugger is running. + (inhibit-read-only nil)) (unless non-interactive-frame (message "Entering debugger...")) (let (debugger-value @@ -213,7 +217,7 @@ the debugger will not be entered." last-input-event last-command-event last-nonmenu-event last-event-frame overriding-local-map - load-read-function + (load-read-function #'read) ;; If we are inside a minibuffer, allow nesting ;; so that we don't get an error from the `e' command. (enable-recursive-minibuffers @@ -321,7 +325,7 @@ the debugger will not be entered." (make-obsolete 'debugger-insert-backtrace "use a `backtrace-mode' buffer or `backtrace-to-string'." - "Emacs 27.1") + "27.1") (defun debugger-insert-backtrace (frames do-xrefs) "Format and insert the backtrace FRAMES at point. diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 54528b2fb91..43d6dfd3c81 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -141,6 +141,9 @@ KEYWORD-ARGS: :after-hook FORM A single lisp form which is evaluated after the mode hooks have been run. It should not be quoted. + :interactive BOOLEAN + Whether the derived mode should be `interactive' or not. + The default is t. BODY: forms to execute just before running the hooks for the new mode. Do not use `interactive' here. @@ -194,6 +197,7 @@ See Info node `(elisp)Derived Modes' for more details. (declare-syntax t) (hook (derived-mode-hook-name child)) (group nil) + (interactive t) (after-hook nil)) ;; Process the keyword args. @@ -203,6 +207,7 @@ See Info node `(elisp)Derived Modes' for more details. (:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil)) (:syntax-table (setq syntax (pop body)) (setq declare-syntax nil)) (:after-hook (setq after-hook (pop body))) + (:interactive (setq interactive (pop body))) (_ (pop body)))) (setq docstring (derived-mode-make-docstring @@ -246,7 +251,7 @@ No problems result if this variable is not bound. (defun ,child () ,docstring - (interactive) + ,(and interactive '(interactive)) ; Run the parent. (delay-mode-hooks diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 0d2890999a4..712fa511707 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -43,6 +43,8 @@ ;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt. (require 'byte-compile "bytecomp") +(declare-function comp-c-func-name "comp.el") + (defvar disassemble-column-1-indent 8 "*") (defvar disassemble-column-2-indent 10 "*") @@ -73,8 +75,9 @@ redefine OBJECT if it is a symbol." (disassemble-internal object indent nil))) nil) - -(defun disassemble-internal (obj indent interactive-p) +(declare-function native-comp-unit-file "data.c") +(declare-function subr-native-comp-unit "data.c") +(cl-defun disassemble-internal (obj indent interactive-p) (let ((macro 'nil) (name (when (symbolp obj) (prog1 obj @@ -82,7 +85,29 @@ redefine OBJECT if it is a symbol." args) (setq obj (autoload-do-load obj name)) (if (subrp obj) - (error "Can't disassemble #<subr %s>" name)) + (if (and (fboundp 'subr-native-elisp-p) + (subr-native-elisp-p obj)) + (progn + (require 'comp) + (call-process "objdump" nil (current-buffer) t "-S" + (native-comp-unit-file (subr-native-comp-unit obj))) + (goto-char (point-min)) + (re-search-forward (concat "^.*" + (regexp-quote + (concat "<" + (when (eq system-type 'darwin) + "_") + (comp-c-func-name + (subr-name obj) "F" t) + ">:")))) + (beginning-of-line) + (delete-region (point-min) (point)) + (when (re-search-forward "^.*<.*>:" nil t 2) + (delete-region (match-beginning 0) (point-max))) + (asm-mode) + (setq buffer-read-only t) + (cl-return-from disassemble-internal)) + (error "Can't disassemble #<subr %s>" name))) (if (eq (car-safe obj) 'macro) ;Handle macros. (setq macro t obj (cdr obj))) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 2916ae4adea..d9b5ea74f6e 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -84,18 +84,22 @@ replacing its case-insensitive matches with the literal string in LIGHTER." (defconst easy-mmode--arg-docstring " -If called interactively, toggle `%s'. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +This is a minor mode. If called interactively, toggle the `%s' +mode. If the prefix argument is positive, enable the mode, and +if it is zero or negative, disable the mode. If called from Lisp, toggle the mode if ARG is `toggle'. Enable the mode if ARG is nil, omitted, or is a positive number. Disable the mode if ARG is a negative number. +To check whether the minor mode is enabled in the current buffer, +evaluate `%S'. + The mode's hook is called both when the mode is enabled and when it is disabled.") -(defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym) +(defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym + getter) (let ((doc (or doc (format "Toggle %s on or off. \\{%s}" mode-pretty-name keymap-sym)))) @@ -104,7 +108,8 @@ it is disabled.") (let* ((fill-prefix nil) (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column)) (fill-column (if (integerp docs-fc) docs-fc 65)) - (argdoc (format easy-mmode--arg-docstring mode-pretty-name)) + (argdoc (format easy-mmode--arg-docstring mode-pretty-name + getter)) (filled (if (fboundp 'fill-region) (with-temp-buffer (insert argdoc) @@ -116,9 +121,9 @@ it is disabled.") doc nil nil 1))))) ;;;###autoload -(defalias 'easy-mmode-define-minor-mode 'define-minor-mode) +(defalias 'easy-mmode-define-minor-mode #'define-minor-mode) ;;;###autoload -(defmacro define-minor-mode (mode doc &optional init-value lighter keymap &rest body) +(defmacro define-minor-mode (mode doc &rest body) "Define a new minor mode MODE. This defines the toggle command MODE and (by default) a control variable MODE (you can override this with the :variable keyword, see below). @@ -139,56 +144,57 @@ documenting what its argument does. If the word \"ARG\" does not appear in DOC, a paragraph is added to DOC explaining usage of the mode argument. -Optional INIT-VALUE is the initial value of the mode's variable. - Note that the minor mode function won't be called by setting - this option, so the value *reflects* the minor mode's natural - initial state, rather than *setting* it. - In the vast majority of cases it should be nil. -Optional LIGHTER is displayed in the mode line when the mode is on. -Optional KEYMAP is the default keymap bound to the mode keymap. - If non-nil, it should be a variable name (whose value is a keymap), - or an expression that returns either a keymap or a list of - (KEY . BINDING) pairs where KEY and BINDING are suitable for - `define-key'. If you supply a KEYMAP argument that is not a - symbol, this macro defines the variable MODE-map and gives it - the value that KEYMAP specifies. - 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. 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): + provide at least one keyword argument (e.g. `:lighter nil`). + 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. :global GLOBAL If non-nil specifies that the minor mode is not meant to be buffer-local, so don't make the variable MODE buffer-local. By default, the mode is buffer-local. -:init-value VAL Same as the INIT-VALUE argument. +:init-value VAL the initial value of the mode's variable. + Note that the minor mode function won't be called by setting + this option, so the value *reflects* the minor mode's natural + initial state, rather than *setting* it. + In the vast majority of cases it should be nil. Not used if you also specify :variable. -:lighter SPEC Same as the LIGHTER argument. -:keymap MAP Same as the KEYMAP argument. -:require SYM Same as in `defcustom'. +:lighter SPEC Text displayed in the mode line when the mode is on. +:keymap MAP Keymap bound to the mode keymap. Defaults to `MODE-map'. + If non-nil, it should be a variable name (whose value is + a keymap), or an expression that returns either a keymap or + a list of (KEY . BINDING) pairs where KEY and BINDING are + suitable for `define-key'. If you supply a KEYMAP argument + that is not a symbol, this macro defines the variable MODE-map + and gives it the value that KEYMAP specifies. +:interactive VAL Whether this mode should be a command or not. The default + is to make it one; use nil to avoid that. If VAL is a list, + it's interpreted as a list of major modes this minor mode + is useful in. :variable PLACE The location to use instead of the variable MODE to store the state of the mode. This can be simply a different named variable, or a generalized variable. PLACE can also be of the form (GET . SET), where GET is an expression that returns the current state, and SET is - a function that takes one argument, the new state, and - sets it. If you specify a :variable, this function does - not define a MODE variable (nor any of the terms used + a function that takes one argument, the new state, which should + be assigned to PLACE. If you specify a :variable, this function + does not define a MODE variable (nor any of the terms used in :variable). - :after-hook A single lisp form which is evaluated after the mode hooks have been run. It should not be quoted. For example, you could write (define-minor-mode foo-mode \"If enabled, foo on you!\" :lighter \" Foo\" :require \\='foo :global t :group \\='hassle :version \"27.5\" - ...BODY CODE...)" + ...BODY CODE...) + +For backward compatibility with the Emacs<21 calling convention, +the keywords can also be preceded by the obsolete triplet +INIT-VALUE LIGHTER KEYMAP. + +\(fn MODE DOC [KEYWORD VAL ... &rest BODY])" (declare (doc-string 2) (debug (&define name string-or-null-p [&optional [¬ keywordp] sexp @@ -197,23 +203,15 @@ For example, you could write [&rest [keywordp sexp]] def-body))) - ;; Allow skipping the first three args. - (cond - ((keywordp init-value) - (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)) - ((keywordp keymap) (push keymap body) (setq keymap nil))) - (let* ((last-message (make-symbol "last-message")) (mode-name (symbol-name mode)) - (pretty-name (easy-mmode-pretty-mode-name mode lighter)) + (init-value nil) + (keymap nil) + (lighter nil) + (pretty-name nil) (globalp nil) (set nil) (initialize nil) - (group nil) (type nil) (extra-args nil) (extra-keywords nil) @@ -221,13 +219,26 @@ For example, you could write (setter `(setq ,mode)) ;The beginning of the exp to set the mode var. (getter mode) ;The exp to get the mode value. (modefun mode) ;The minor mode function name we're defining. - (require t) (after-hook nil) (hook (intern (concat mode-name "-hook"))) (hook-on (intern (concat mode-name "-on-hook"))) (hook-off (intern (concat mode-name "-off-hook"))) + (interactive t) + (warnwrap (if (or (null body) (keywordp (car body))) #'identity + (lambda (exp) + (macroexp-warn-and-return + "Use keywords rather than deprecated positional arguments to `define-minor-mode'" + exp)))) keyw keymap-sym tmp) + ;; Allow BODY to start with the old INIT-VALUE LIGHTER KEYMAP triplet. + (unless (keywordp (car body)) + (setq init-value (pop body)) + (unless (keywordp (car body)) + (setq lighter (pop body)) + (unless (keywordp (car body)) + (setq keymap (pop body))))) + ;; Check keys. (while (keywordp (setq keyw (car body))) (setq body (cdr body)) @@ -241,10 +252,9 @@ For example, you could write (:extra-args (setq extra-args (pop body))) (:set (setq set (list :set (pop body)))) (:initialize (setq initialize (list :initialize (pop body)))) - (:group (setq group (nconc group (list :group (pop body))))) (:type (setq type (list :type (pop body)))) - (:require (setq require (pop body))) (:keymap (setq keymap (pop body))) + (:interactive (setq interactive (pop body))) (:variable (setq variable (pop body)) (if (not (and (setq tmp (cdr-safe variable)) (or (symbolp tmp) @@ -258,13 +268,14 @@ For example, you could write (:after-hook (setq after-hook (pop body))) (_ (push keyw extra-keywords) (push (pop body) extra-keywords)))) + (setq pretty-name (easy-mmode-pretty-mode-name mode lighter)) (setq keymap-sym (if (and keymap (symbolp keymap)) keymap (intern (concat mode-name "-map")))) (unless set (setq set '(:set #'custom-set-minor-mode))) (unless initialize - (setq initialize '(:initialize 'custom-initialize-default))) + (setq initialize '(:initialize #'custom-initialize-default))) ;; TODO? Mark booleans as safe if booleanp? Eg abbrev-mode. (unless type (setq type '(:type 'boolean))) @@ -295,47 +306,73 @@ or call the function `%s'.")))) ,(format base-doc-string pretty-name mode mode) ,@set ,@initialize - ,@group ,@type - ,@(unless (eq require t) `(:require ,require)) ,@(nreverse extra-keywords))))) ;; The actual function. - (defun ,modefun (&optional arg ,@extra-args) - ,(easy-mmode--mode-docstring doc pretty-name keymap-sym) - ;; Use `toggle' rather than (if ,mode 0 1) so that using - ;; repeat-command still does the toggling correctly. - (interactive (list (if current-prefix-arg - (prefix-numeric-value current-prefix-arg) - 'toggle))) - (let ((,last-message (current-message))) - (,@setter - (cond ((eq arg 'toggle) - (not ,getter)) - ((and (numberp arg) - (< arg 1)) - nil) - (t - t))) - ,@body - ;; The on/off hooks are here for backward compatibility only. - (run-hooks ',hook (if ,getter ',hook-on ',hook-off)) - (if (called-interactively-p 'any) - (progn - ,(if (and globalp (not variable)) - `(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)))) - (let ((local ,(if globalp "" " in current buffer"))) - (message ,(format "%s %%sabled%%s" pretty-name) - (if ,getter "en" "dis") local))))) - ,@(when after-hook `(,after-hook))) - (force-mode-line-update) - ;; Return the new setting. - ,getter) + ,(funcall + warnwrap + `(defun ,modefun (&optional arg ,@extra-args) + ,(easy-mmode--mode-docstring doc pretty-name keymap-sym + getter) + ,(when interactive + ;; Use `toggle' rather than (if ,mode 0 1) so that using + ;; repeat-command still does the toggling correctly. + (if (consp interactive) + `(interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 'toggle)) + ,@interactive) + '(interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 'toggle))))) + (let ((,last-message (current-message))) + (,@setter + (cond ((eq arg 'toggle) + (not ,getter)) + ((and (numberp arg) + (< arg 1)) + nil) + (t + t))) + ;; Keep minor modes list up to date. + ,@(if globalp + ;; When running this byte-compiled code in earlier + ;; Emacs versions, these variables may not be defined + ;; there. So check defensively, even if they're + ;; always defined in Emacs 28 and up. + `((when (boundp 'global-minor-modes) + (setq global-minor-modes + (delq ',modefun global-minor-modes)) + (when ,getter + (push ',modefun global-minor-modes)))) + ;; Ditto check. + `((when (boundp 'local-minor-modes) + (setq local-minor-modes + (delq ',modefun local-minor-modes)) + (when ,getter + (push ',modefun local-minor-modes))))) + ,@body + ;; The on/off hooks are here for backward compatibility only. + (run-hooks ',hook (if ,getter ',hook-on ',hook-off)) + (if (called-interactively-p 'any) + (progn + ,(if (and globalp (not variable)) + `(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)))) + (let ((local ,(if globalp "" " in current buffer"))) + (message ,(format "%s %%sabled%%s" pretty-name) + (if ,getter "en" "dis") local))))) + ,@(when after-hook `(,after-hook))) + (force-mode-line-update) + ;; Return the new setting. + ,getter)) ;; Autoloading a define-minor-mode autoloads everything ;; up-to-here. @@ -377,9 +414,9 @@ No problems result if this variable is not bound. ;;; ;;;###autoload -(defalias 'easy-mmode-define-global-mode 'define-globalized-minor-mode) +(defalias 'easy-mmode-define-global-mode #'define-globalized-minor-mode) ;;;###autoload -(defalias 'define-global-minor-mode 'define-globalized-minor-mode) +(defalias 'define-global-minor-mode #'define-globalized-minor-mode) ;;;###autoload (defmacro define-globalized-minor-mode (global-mode mode turn-on &rest body) "Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE. @@ -460,8 +497,11 @@ on if the hook has explicitly disabled it. ,(concat (format "Toggle %s in all buffers.\n" pretty-name) (internal--format-docstring-line "With prefix ARG, enable %s if ARG is positive; otherwise, \ -disable it. If called from Lisp, enable the mode if ARG is omitted or nil.\n\n" +disable it.\n\n" pretty-global-name) + "If called from Lisp, toggle the mode if ARG is `toggle'. +Enable the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number.\n\n" (internal--format-docstring-line "%s is enabled in all buffers where `%s' would do it.\n\n" pretty-name turn-on) @@ -481,12 +521,12 @@ disable it. If called from Lisp, enable the mode if ARG is omitted or nil.\n\n" (if ,global-mode (progn (add-hook 'after-change-major-mode-hook - ',MODE-enable-in-buffers) - (add-hook 'find-file-hook ',MODE-check-buffers) - (add-hook 'change-major-mode-hook ',MODE-cmhh)) - (remove-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers) - (remove-hook 'find-file-hook ',MODE-check-buffers) - (remove-hook 'change-major-mode-hook ',MODE-cmhh)) + #',MODE-enable-in-buffers) + (add-hook 'find-file-hook #',MODE-check-buffers) + (add-hook 'change-major-mode-hook #',MODE-cmhh)) + (remove-hook 'after-change-major-mode-hook #',MODE-enable-in-buffers) + (remove-hook 'find-file-hook #',MODE-check-buffers) + (remove-hook 'change-major-mode-hook #',MODE-cmhh)) ;; Go through existing buffers. (dolist (buf (buffer-list)) @@ -526,7 +566,7 @@ list." ;; A function which checks whether MODE has been disabled in the major ;; mode hook which has just been run. - (add-hook ',minor-MODE-hook ',MODE-set-explicitly) + (add-hook ',minor-MODE-hook #',MODE-set-explicitly) ;; List of buffers left to process. (defvar ,MODE-buffers nil) @@ -553,13 +593,13 @@ list." (defun ,MODE-check-buffers () (,MODE-enable-in-buffers) - (remove-hook 'post-command-hook ',MODE-check-buffers)) + (remove-hook 'post-command-hook #',MODE-check-buffers)) (put ',MODE-check-buffers 'definition-name ',global-mode) ;; The function that catches kill-all-local-variables. (defun ,MODE-cmhh () (add-to-list ',MODE-buffers (current-buffer)) - (add-hook 'post-command-hook ',MODE-check-buffers)) + (add-hook 'post-command-hook #',MODE-check-buffers)) (put ',MODE-cmhh 'definition-name ',global-mode)))) (defun easy-mmode--globalized-predicate-p (predicate) diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index 5303da3746c..360e685ea00 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -23,6 +23,9 @@ ;;; Commentary: +;; The `easy-menu-define' macro provides a convenient way to define +;; pop-up menus and/or menu bar menus. +;; ;; This is compatible with easymenu.el by Per Abrahamsen ;; but it is much simpler as it doesn't try to support other Emacs versions. ;; The code was mostly derived from lmenu.el. @@ -32,7 +35,6 @@ (defsubst easy-menu-intern (s) (if (stringp s) (intern s) s)) -;;;###autoload (defmacro easy-menu-define (symbol maps doc menu) "Define a pop-up menu and/or menu bar menu specified by MENU. If SYMBOL is non-nil, define SYMBOL as a function to pop up the @@ -140,7 +142,7 @@ solely of dashes is displayed as a menu separator. Alternatively, a menu item can be a list with the same format as MENU. This is a submenu." - (declare (indent defun) (debug (symbolp body))) + (declare (indent defun) (debug (symbolp body)) (doc-string 3)) `(progn ,(if symbol `(defvar ,symbol nil ,doc)) (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu))) @@ -163,7 +165,6 @@ This is expected to be bound to a mouse event." "")) (cons menu props))))) -;;;###autoload (defun easy-menu-do-define (symbol maps doc menu) ;; We can't do anything that might differ between Emacs dialects in ;; `easy-menu-define' in order to make byte compiled files @@ -174,19 +175,24 @@ This is expected to be bound to a mouse event." (set symbol keymap) (defalias symbol (lambda (event) (:documentation doc) (interactive "@e") - ;; FIXME: XEmacs uses popup-menu which calls the binding - ;; while x-popup-menu only returns the selection. (x-popup-menu event - (or (and (symbolp symbol) + (or (and (symbolp keymap) (funcall - (or (plist-get (get symbol 'menu-prop) + (or (plist-get (get keymap 'menu-prop) :filter) - 'identity) - (symbol-function symbol))) - symbol))))) + #'identity) + (symbol-function keymap))) + keymap)))) + ;; These symbols are commands, but not interesting for users + ;; to `M-x TAB'. + (function-put symbol 'completion-predicate #'ignore)) (dolist (map (if (keymapp maps) (list maps) maps)) (define-key map - (vector 'menu-bar (easy-menu-intern (car menu))) + (vector 'menu-bar (if (symbolp (car menu)) + (car menu) + ;; If a string, then use the downcased + ;; version for greater backwards compatibility. + (intern (downcase (car menu))))) (easy-menu-binding keymap (car menu)))))) (defun easy-menu-filter-return (menu &optional name) @@ -212,7 +218,6 @@ If NAME is provided, it is used for the keymap." If it holds a list, this is expected to be a list of keys already seen in the menu we're processing. Else it means we're not processing a menu.") -;;;###autoload (defun easy-menu-create-menu (menu-name menu-items) "Create a menu called MENU-NAME with items described in MENU-ITEMS. MENU-NAME is a string, the name of the menu. MENU-ITEMS is a list of items @@ -250,7 +255,7 @@ possibly preceded by keyword pairs as described in `easy-menu-define'." ;; anyway, so we'd better not convert it at all (it will ;; be converted on the fly by easy-menu-filter-return). menu-items - (append menu (mapcar 'easy-menu-convert-item menu-items)))) + (append menu (mapcar #'easy-menu-convert-item menu-items)))) (when prop (setq menu (easy-menu-make-symbol menu 'noexp)) (put menu 'menu-prop prop)) @@ -468,7 +473,6 @@ When non-nil, NOEXP indicates that CALLBACK cannot be an expression (eval `(lambda () (interactive) ,callback) t))) command)) -;;;###autoload (defun easy-menu-change (path name items &optional before map) "Change menu found at PATH as item NAME to contain ITEMS. PATH is a list of strings for locating the menu that @@ -488,14 +492,16 @@ To implement dynamic menus, either call this from `menu-bar-update-hook' or use a menu filter." (easy-menu-add-item map path (easy-menu-create-menu name items) before)) -(define-obsolete-function-alias 'easy-menu-remove #'ignore "28.1" +(defalias 'easy-menu-remove #'ignore "Remove MENU from the current menu bar. Contrary to XEmacs, this is a nop on Emacs since menus are automatically \(de)activated when the corresponding keymap is (de)activated. \(fn MENU)") +(make-obsolete 'easy-menu-remove "this was always a no-op in Emacs \ +and can be safely removed." "28.1") -(define-obsolete-function-alias 'easy-menu-add #'ignore "28.1" +(defalias 'easy-menu-add #'ignore "Add the menu to the menubar. On Emacs this is a nop, because menus are already automatically activated when the corresponding keymap is activated. On XEmacs @@ -505,6 +511,8 @@ You should call this once the menu and keybindings are set up completely and menu filter functions can be expected to work. \(fn MENU &optional MAP)") +(make-obsolete 'easy-menu-add "this was always a no-op in Emacs \ +and can be safely removed." "28.1") (defun add-submenu (menu-path submenu &optional before in-menu) "Add submenu SUBMENU in the menu at MENU-PATH. @@ -657,7 +665,7 @@ In some cases we use that to select between the local and global maps." (let* ((name (if path (format "%s" (car (reverse path))))) (newmap (make-sparse-keymap name))) (define-key (or map (current-local-map)) - (apply 'vector (mapcar 'easy-menu-intern path)) + (apply #'vector (mapcar #'easy-menu-intern path)) (if name (cons name newmap) newmap)) newmap)))) (or (keymapp map) (error "Malformed menu in easy-menu: (%s)" map)) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 5d595851b9f..7def9ff96a7 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -55,6 +55,7 @@ (require 'backtrace) (require 'macroexp) (require 'cl-lib) +(require 'seq) (eval-when-compile (require 'pcase)) ;;; Options @@ -100,10 +101,6 @@ variable. You may wish to make it local to each buffer with `emacs-lisp-mode-hook'." :type 'boolean) -;; edebug-all-defs and edebug-all-forms need to be autoloaded -;; because the byte compiler binds them; as a result, if edebug -;; is first loaded for a require in a compilation, they will be left unbound. - ;;;###autoload (defcustom edebug-all-forms nil "Non-nil means evaluation of all forms will instrument for Edebug. @@ -244,19 +241,30 @@ If the result is non-nil, then break. Errors are ignored." ;;; Form spec utilities. -(defun get-edebug-spec (symbol) +(defun edebug-get-spec (symbol) + "Return the Edebug spec of a given Lisp expression's head SYMBOL. +The argument is usually a symbol, but it doesn't have to be." ;; Get the spec of symbol resolving all indirection. (let ((spec nil) (indirect symbol)) (while - (progn - (and (symbolp indirect) - (setq indirect - (function-get indirect 'edebug-form-spec 'macro)))) + (and (symbolp indirect) + (setq indirect + (function-get indirect 'edebug-form-spec 'macro))) ;; (edebug-trace "indirection: %s" edebug-form-spec) (setq spec indirect)) spec)) +(define-obsolete-function-alias 'get-edebug-spec #'edebug-get-spec "28.1") + +(defun edebug--get-elem-spec (elem) + "Return the specs of the Edebug element ELEM, if any. +ELEM has to be a symbol." + (or (get elem 'edebug-elem-spec) + ;; For backward compatibility, we also allow the use of + ;; a form's name as a shorthand to refer to its spec. + (edebug-get-spec elem))) + ;;;###autoload (defun edebug-basic-spec (spec) "Return t if SPEC uses only extant spec symbols. @@ -445,66 +453,27 @@ the option `edebug-all-forms'." ;; We should somehow arrange to be able to do this ;; without actually replacing the eval-defun command. -(defun edebug-eval-defun (edebug-it) - "Evaluate the top-level form containing point, or after point. - -If the current defun is actually a call to `defvar', then reset the -variable using its initial value expression even if the variable -already has some other value. (Normally `defvar' does not change the -variable's value if it already has a value.) Treat `defcustom' -similarly. Reinitialize the face according to `defface' specification. - -With a prefix argument, instrument the code for Edebug. - -Setting option `edebug-all-defs' to a non-nil value reverses the meaning +(defun edebug--eval-defun (orig-fun edebug-it) + "Setting option `edebug-all-defs' to a non-nil value reverses the meaning of the prefix argument. Code is then instrumented when this function is invoked without a prefix argument. If acting on a `defun' for FUNCTION, and the function was instrumented, `Edebug: FUNCTION' is printed in the minibuffer. If not instrumented, -just FUNCTION is printed. +just FUNCTION is printed." + ;; Re-install our advice, in case `debug' re-bound `load-read-function' to + ;; its default value. + (add-function :around load-read-function #'edebug--read) + (let* ((edebug-all-forms (not (eq (not edebug-it) (not edebug-all-defs)))) + (edebug-all-defs edebug-all-forms)) + (funcall orig-fun nil))) -If not acting on a `defun', the result of evaluation is displayed in -the minibuffer." +(defun edebug-eval-defun (edebug-it) + (declare (obsolete "use eval-defun or edebug--eval-defun instead" "28.1")) (interactive "P") - (let* ((edebugging (not (eq (not edebug-it) (not edebug-all-defs)))) - (edebug-result) - (form - (let ((edebug-all-forms edebugging) - (edebug-all-defs (eq edebug-all-defs (not edebug-it)))) - (edebug-read-top-level-form)))) - ;; This should be consistent with `eval-defun-1', but not the - ;; same, since that gets a macroexpanded form. - (cond ((and (eq (car form) 'defvar) - (cdr-safe (cdr-safe form))) - ;; Force variable to be bound. - (makunbound (nth 1 form))) - ((and (eq (car form) 'defcustom) - (default-boundp (nth 1 form))) - ;; Force variable to be bound. - ;; FIXME: Shouldn't this use the :setter or :initializer? - (set-default (nth 1 form) (eval (nth 2 form) lexical-binding))) - ((eq (car form) 'defface) - ;; Reset the face. - (setq face-new-frame-defaults - (assq-delete-all (nth 1 form) face-new-frame-defaults)) - (put (nth 1 form) 'face-defface-spec nil) - (put (nth 1 form) 'face-documentation (nth 3 form)) - ;; See comments in `eval-defun-1' for purpose of code below - (setq form (prog1 `(prog1 ,form - (put ',(nth 1 form) 'saved-face - ',(get (nth 1 form) 'saved-face)) - (put ',(nth 1 form) 'customized-face - ,(nth 2 form))) - (put (nth 1 form) 'saved-face nil))))) - (setq edebug-result (eval (eval-sexp-add-defvars form) lexical-binding)) - (if (not edebugging) - (prog1 - (prin1 edebug-result) - (let ((str (eval-expression-print-format edebug-result))) - (if str (princ str)))) - edebug-result))) - + (if (advice-member-p #'edebug--eval-defun 'eval-defun) + (eval-defun edebug-it) + (edebug--eval-defun #'eval-defun edebug-it))) ;;;###autoload (defalias 'edebug-defun 'edebug-eval-top-level-form) @@ -576,12 +545,12 @@ already is one.)" (defun edebug-install-read-eval-functions () (interactive) (add-function :around load-read-function #'edebug--read) - (advice-add 'eval-defun :override #'edebug-eval-defun)) + (advice-add 'eval-defun :around #'edebug--eval-defun)) (defun edebug-uninstall-read-eval-functions () (interactive) (remove-function load-read-function #'edebug--read) - (advice-remove 'eval-defun #'edebug-eval-defun)) + (advice-remove 'eval-defun #'edebug--eval-defun)) ;;; Edebug internal data @@ -961,6 +930,18 @@ circular objects. Let `read' read everything else." ;;; Cursors for traversal of list and vector elements with offsets. +;; Edebug's instrumentation is based on parsing the sexps, which come with +;; auxiliary position information. Instead of keeping the position +;; information together with the sexps, it is kept in a "parallel +;; tree" of offsets. +;; +;; An "edebug cursor" is a pair of a *list of sexps* (called the +;; "expressions") together with a matching list of offsets. +;; When we're parsing the content of a list, the +;; `edebug-cursor-expressions' is simply the list but when parsing +;; a vector, the `edebug-cursor-expressions' is a list formed of the +;; elements of the vector. + (defvar edebug-dotted-spec nil "Set to t when matching after the dot in a dotted spec list.") @@ -1015,8 +996,8 @@ circular objects. Let `read' read everything else." ;; The following test should always fail. (if (edebug-empty-cursor cursor) (edebug-no-match cursor "Not enough arguments.")) - (setcar cursor (cdr (car cursor))) - (setcdr cursor (cdr (cdr cursor))) + (cl-callf cdr (car cursor)) + (cl-callf cdr (cdr cursor)) cursor) @@ -1067,8 +1048,6 @@ circular objects. Let `read' read everything else." ;; This data is shared by all embedded definitions. (defvar edebug-top-window-data) -(defvar edebug-&optional) -(defvar edebug-&rest) (defvar edebug-gate nil) ;; whether no-match forces an error. (defvar edebug-def-name nil) ; name of definition, used by interactive-form @@ -1119,8 +1098,6 @@ purpose by adding an entry to this alist, and setting edebug-top-window-data edebug-def-name;; make sure it is locally nil ;; I don't like these here!! - edebug-&optional - edebug-&rest edebug-gate edebug-best-error edebug-error-point @@ -1153,7 +1130,7 @@ purpose by adding an entry to this alist, and setting (eq 'symbol (progn (forward-char 1) (edebug-next-token-class)))) ;; Find out if this is a defining form from first symbol (setq def-kind (read (current-buffer)) - spec (and (symbolp def-kind) (get-edebug-spec def-kind)) + spec (and (symbolp def-kind) (edebug-get-spec def-kind)) defining-form-p (and (listp spec) (eq '&define (car spec))) ;; This is incorrect in general!! But OK most of the time. @@ -1164,6 +1141,9 @@ purpose by adding an entry to this alist, and setting ;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms) (let ((result (cond + ;; IIUC, `&define' is treated specially here so as to avoid + ;; entering Edebug during the actual function's definition: + ;; we only want to enter Edebug later when the thing is called. (defining-form-p (if (or edebug-all-defs edebug-all-forms) ;; If it is a defining form and we are edebugging defs, @@ -1211,26 +1191,12 @@ purpose by adding an entry to this alist, and setting (funcall edebug-after-instrumentation-function result)))) (defvar edebug-def-args) ; args of defining form. -(defvar edebug-def-interactive) ; is it an emacs interactive function? (defvar edebug-inside-func) ;; whether code is inside function context. ;; Currently def-form sets this to nil; def-body sets it to t. -(defvar edebug--cl-macrolet-defs) ;; Fully defined below. - -(defun edebug-interactive-p-name () - ;; Return a unique symbol for the variable used to store the - ;; status of interactive-p for this function. - (intern (format "edebug-%s-interactive-p" edebug-def-name))) - - -(defun edebug-wrap-def-body (forms) - "Wrap the FORMS of a definition body." - (if edebug-def-interactive - `(let ((,(edebug-interactive-p-name) - (called-interactively-p 'interactive))) - ,(edebug-make-enter-wrapper forms)) - (edebug-make-enter-wrapper forms))) +(defvar edebug-lexical-macro-ctx nil + "Alist mapping lexically scoped macro names to their debug spec.") (defun edebug-make-enter-wrapper (forms) ;; Generate the enter wrapper for some forms of a definition. @@ -1380,7 +1346,6 @@ contains a circular object." (edebug-old-def-name (edebug--form-data-name form-data-entry)) edebug-def-name edebug-def-args - edebug-def-interactive edebug-inside-func;; whether wrapped code executes inside a function. ) @@ -1500,9 +1465,12 @@ contains a circular object." ((consp form) ;; The first offset for a list form is for the list form itself. (if (eq 'quote (car form)) + ;; This makes sure we don't instrument 'foo + ;; which would cause the debugger to single-step + ;; the trivial evaluation of a constant. form (let* ((head (car form)) - (spec (and (symbolp head) (get-edebug-spec head))) + (spec (and (symbolp head) (edebug-get-spec head))) (new-cursor (edebug-new-cursor form offset))) ;; Find out if this is a defining form from first symbol. ;; An indirect spec would not work here, yet. @@ -1542,13 +1510,10 @@ contains a circular object." (defsubst edebug-list-form-args (head cursor) ;; Process the arguments of a list form given that head of form is a symbol. ;; Helper for edebug-list-form - (let ((spec (get-edebug-spec head))) + (let* ((lex-spec (assq head edebug-lexical-macro-ctx)) + (spec (if lex-spec (cdr lex-spec) + (edebug-get-spec head)))) (cond - ;; Treat cl-macrolet bindings like macros with no spec. - ((member head edebug--cl-macrolet-defs) - (if edebug-eval-macro-args - (edebug-forms cursor) - (edebug-sexps cursor))) (spec (cond ((consp spec) @@ -1562,7 +1527,7 @@ contains a circular object." ; but leave it in for compatibility. )) ;; No edebug-form-spec provided. - ((macrop head) + ((or lex-spec (macrop head)) (if edebug-eval-macro-args (edebug-forms cursor) (edebug-sexps cursor))) @@ -1575,10 +1540,7 @@ contains a circular object." ;; The after offset will be left in the cursor after processing the form. (let ((head (edebug-top-element-required cursor "Expected elements")) ;; Prevent backtracking whenever instrumenting. - (edebug-gate t) - ;; A list form is never optional because it matches anything. - (edebug-&optional nil) - (edebug-&rest nil)) + (edebug-gate t)) ;; Skip the first offset. (edebug-set-cursor cursor (edebug-cursor-expressions cursor) (cdr (edebug-cursor-offsets cursor))) @@ -1586,11 +1548,6 @@ contains a circular object." ((symbolp head) (cond ((null head) nil) ; () is valid. - ((eq head 'interactive-p) - ;; Special case: replace (interactive-p) with variable - (setq edebug-def-interactive 'check-it) - (edebug-move-cursor cursor) - (edebug-interactive-p-name)) (t (cons head (edebug-list-form-args head (edebug-move-cursor cursor)))))) @@ -1628,7 +1585,7 @@ contains a circular object." (setq edebug-error-point (or edebug-error-point (edebug-before-offset cursor)) edebug-best-error (or edebug-best-error args)) - (if (and edebug-gate (not edebug-&optional)) + (if edebug-gate (progn (if edebug-error-point (goto-char edebug-error-point)) @@ -1639,13 +1596,11 @@ contains a circular object." (defun edebug-match (cursor specs) ;; Top level spec matching function. ;; Used also at each lower level of specs. - (let (edebug-&optional - edebug-&rest - edebug-best-error + (let (edebug-best-error edebug-error-point (edebug-gate edebug-gate) ;; locally bound to limit effect ) - (edebug-match-specs cursor specs 'edebug-match-specs))) + (edebug-match-specs cursor specs #'edebug-match-specs))) (defun edebug-match-one-spec (cursor spec) @@ -1687,10 +1642,10 @@ contains a circular object." (first-char (and (symbolp spec) (aref (symbol-name spec) 0))) (match (cond ((eq ?& first-char);; "&" symbols take all following specs. - (funcall (get-edebug-spec spec) cursor (cdr specs))) + (edebug--match-&-spec-op spec cursor (cdr specs))) ((eq ?: first-char);; ":" symbols take one following spec. (setq rest (cdr (cdr specs))) - (funcall (get-edebug-spec spec) cursor (car (cdr specs)))) + (edebug--handle-:-spec-op spec cursor (car (cdr specs)))) (t;; Any other normal spec. (setq rest (cdr specs)) (edebug-match-one-spec cursor spec))))) @@ -1721,40 +1676,23 @@ contains a circular object." ;; user may want to define macros or functions with the same names. ;; We could use an internal obarray for these primitive specs. -(dolist (pair '((&optional . edebug-match-&optional) - (&rest . edebug-match-&rest) - (&or . edebug-match-&or) - (form . edebug-match-form) +(dolist (pair '((form . edebug-match-form) (sexp . edebug-match-sexp) (body . edebug-match-body) - (&define . edebug-match-&define) - (name . edebug-match-name) - (:name . edebug-match-colon-name) - (:unique . edebug-match-:unique) (arg . edebug-match-arg) (def-body . edebug-match-def-body) (def-form . edebug-match-def-form) ;; Less frequently used: ;; (function . edebug-match-function) - (lambda-expr . edebug-match-lambda-expr) - (cl-generic-method-qualifier - . edebug-match-cl-generic-method-qualifier) - (cl-generic-method-args . edebug-match-cl-generic-method-args) - (cl-macrolet-expr . edebug-match-cl-macrolet-expr) - (cl-macrolet-name . edebug-match-cl-macrolet-name) - (cl-macrolet-body . edebug-match-cl-macrolet-body) - (¬ . edebug-match-¬) - (&key . edebug-match-&key) - (&error . edebug-match-&error) (place . edebug-match-place) (gate . edebug-match-gate) ;; (nil . edebug-match-nil) not this one - special case it. )) - (put (car pair) 'edebug-form-spec (cdr pair))) + (put (car pair) 'edebug-elem-spec (cdr pair))) (defun edebug-match-symbol (cursor symbol) ;; Match a symbol spec. - (let* ((spec (get-edebug-spec symbol))) + (let* ((spec (edebug--get-elem-spec symbol))) (cond (spec (if (consp spec) @@ -1793,13 +1731,12 @@ contains a circular object." (defsubst edebug-match-body (cursor) (edebug-forms cursor)) -(defun edebug-match-&optional (cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql '&optional)) cursor specs) ;; Keep matching until one spec fails. - (edebug-&optional-wrapper cursor specs 'edebug-&optional-wrapper)) + (edebug-&optional-wrapper cursor specs #'edebug-&optional-wrapper)) (defun edebug-&optional-wrapper (cursor specs remainder-handler) (let (result - (edebug-&optional specs) (edebug-gate nil) (this-form (edebug-cursor-expressions cursor)) (this-offset (edebug-cursor-offsets cursor))) @@ -1814,20 +1751,24 @@ contains a circular object." nil))) -(defun edebug-&rest-wrapper (cursor specs remainder-handler) - (if (null specs) (setq specs edebug-&rest)) - ;; Reuse the &optional handler with this as the remainder handler. - (edebug-&optional-wrapper cursor specs remainder-handler)) +(cl-defgeneric edebug--match-&-spec-op (op cursor specs) + "Handle &foo spec operators. +&foo spec operators operate on all the subsequent SPECS.") -(defun edebug-match-&rest (cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql '&rest)) cursor specs) ;; Repeatedly use specs until failure. - (let ((edebug-&rest specs) ;; remember these - edebug-best-error + (let (edebug-best-error edebug-error-point) - (edebug-&rest-wrapper cursor specs 'edebug-&rest-wrapper))) + ;; Reuse the &optional handler with this as the remainder handler. + (edebug-&optional-wrapper + cursor specs + (lambda (c s rh) + ;; `s' is the remaining spec to match. + ;; When it's nil, start over matching `specs'. + (edebug-&optional-wrapper c (or s specs) rh))))) -(defun edebug-match-&or (cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql '&or)) cursor specs) ;; Keep matching until one spec succeeds, and return its results. ;; If none match, fail. ;; This needs to be optimized since most specs spend time here. @@ -1851,24 +1792,49 @@ contains a circular object." (apply #'edebug-no-match cursor "Expected one of" original-specs)) )) - -(defun edebug-match-¬ (cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql '&interpose)) cursor specs) + "Compute the specs for `&interpose SPEC FUN ARGS...'. +Extracts the head of the data by matching it against SPEC, +and then matches the rest by calling (FUN HEAD PF ARGS...) +where PF is the parsing function which FUN can call exactly once, +passing it the specs that it needs to match. +Note that HEAD will always be a list, since specs are defined to match +a sequence of elements." + (pcase-let* + ((`(,spec ,fun . ,args) specs) + (exps (edebug-cursor-expressions cursor)) + (instrumented-head (edebug-match-one-spec cursor spec)) + (consumed (- (length exps) + (length (edebug-cursor-expressions cursor)))) + (head (seq-subseq exps 0 consumed))) + (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps))) + (apply fun `(,head + ,(lambda (newspecs) + ;; FIXME: What'd be the difference if we used + ;; `edebug-match-sublist', which is what + ;; `edebug-list-form-args' uses for the similar purpose + ;; when matching "normal" forms? + (append instrumented-head (edebug-match cursor newspecs))) + ,@args)))) + +(cl-defmethod edebug--match-&-spec-op ((_ (eql '¬)) cursor specs) ;; If any specs match, then fail (if (null (catch 'no-match (let ((edebug-gate nil)) (save-excursion - (edebug-match-&or cursor specs))) + (edebug--match-&-spec-op '&or cursor specs))) nil)) ;; This means something matched, so it is a no match. (edebug-no-match cursor "Unexpected")) ;; This means nothing matched, so it is OK. nil) ;; So, return nothing -(defun edebug-match-&key (cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql '&key)) cursor specs) ;; Following specs must look like (<name> <spec>) ... ;; where <name> is the name of a keyword, and spec is its spec. ;; This really doesn't save much over the expanded form and takes time. - (edebug-match-&rest + (edebug--match-&-spec-op + '&rest cursor (cons '&or (mapcar (lambda (pair) @@ -1876,7 +1842,7 @@ contains a circular object." (car (cdr pair)))) specs)))) -(defun edebug-match-&error (cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql '&error)) cursor specs) ;; Signal an error, using the following string in the spec as argument. (let ((error-string (car specs)) (edebug-error-point (edebug-before-offset cursor))) @@ -1945,19 +1911,15 @@ contains a circular object." (defun edebug-match-sublist (cursor specs) ;; Match a sublist of specs. - (let (edebug-&optional - ;;edebug-best-error - ;;edebug-error-point - ) - (prog1 - ;; match with edebug-match-specs so edebug-best-error is not bound. - (edebug-match-specs cursor specs 'edebug-match-specs) - (if (not (edebug-empty-cursor cursor)) - (if edebug-best-error - (apply #'edebug-no-match cursor edebug-best-error) - ;; A failed &rest or &optional spec may leave some args. - (edebug-no-match cursor "Failed matching" specs) - ))))) + (prog1 + ;; match with edebug-match-specs so edebug-best-error is not bound. + (edebug-match-specs cursor specs 'edebug-match-specs) + (if (not (edebug-empty-cursor cursor)) + (if edebug-best-error + (apply #'edebug-no-match cursor edebug-best-error) + ;; A failed &rest or &optional spec may leave some args. + (edebug-no-match cursor "Failed matching" specs) + )))) (defun edebug-match-string (cursor spec) @@ -1980,61 +1942,83 @@ contains a circular object." (defun edebug-match-function (_cursor) (error "Use function-form instead of function in edebug spec")) -(defun edebug-match-&define (cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql '&define)) cursor specs) ;; Match a defining form. ;; Normally, &define is interpreted specially other places. ;; This should only be called inside of a spec list to match the remainder ;; of the current list. e.g. ("lambda" &define args def-body) - (edebug-make-form-wrapper - cursor - (edebug-before-offset cursor) - ;; Find the last offset in the list. - (let ((offsets (edebug-cursor-offsets cursor))) - (while (consp offsets) (setq offsets (cdr offsets))) - offsets) - specs)) - -(defun edebug-match-lambda-expr (cursor) - ;; The expression must be a function. - ;; This will match any list form that begins with a symbol - ;; that has an edebug-form-spec beginning with &define. In - ;; practice, only lambda expressions should be used. - ;; I could add a &lambda specification to avoid confusion. - (let* ((sexp (edebug-top-element-required - cursor "Expected lambda expression")) - (offset (edebug-top-offset cursor)) - (head (and (consp sexp) (car sexp))) - (spec (and (symbolp head) (get-edebug-spec head))) - (edebug-inside-func nil)) - ;; Find out if this is a defining form from first symbol. - (if (and (consp spec) (eq '&define (car spec))) - (prog1 - (list - (edebug-defining-form - (edebug-new-cursor sexp offset) - (car offset);; before the sexp - (edebug-after-offset cursor) - (cons (symbol-name head) (cdr spec)))) - (edebug-move-cursor cursor)) - (edebug-no-match cursor "Expected lambda expression") - ))) - - -(defun edebug-match-name (cursor) - ;; Set the edebug-def-name bound in edebug-defining-form. - (let ((name (edebug-top-element-required cursor "Expected name"))) - ;; Maybe strings and numbers could be used. - (if (not (symbolp name)) - (edebug-no-match cursor "Symbol expected for name of definition")) - (setq edebug-def-name - (if edebug-def-name - ;; Construct a new name by appending to previous name. - (intern (format "%s@%s" edebug-def-name name)) - name)) - (edebug-move-cursor cursor) - (list name))) - -(defun edebug-match-colon-name (_cursor spec) + (prog1 (edebug-make-form-wrapper + cursor + (edebug-before-offset cursor) + ;; Find the last offset in the list. + (let ((offsets (edebug-cursor-offsets cursor))) + (while (consp offsets) (setq offsets (cdr offsets))) + offsets) + specs) + ;; Stop backtracking here (Bug#41988). + (setq edebug-gate t))) + +(cl-defmethod edebug--match-&-spec-op ((_ (eql '&name)) cursor specs) + "Compute the name for `&name SPEC FUN` spec operator. + +The full syntax of that operator is: + &name [PRESTRING] SPEC [POSTSTRING] FUN ARGS... + +Extracts the head of the data by matching it against SPEC, +and then get the new name to use by calling + (FUN ARGS... OLDNAME [PRESTRING] HEAD [POSTSTRING]) +FUN should return either a string or a symbol. +FUN can be missing in which case it defaults to concatenating +the new name to the end of the old with an \"@\" char between the two. +PRESTRING and POSTSTRING are optional strings that get prepended +or appended to the actual name." + (pcase-let* + ((`(,spec ,fun . ,args) specs) + (prestrings (when (stringp spec) + (prog1 (list spec) (setq spec fun fun (pop args))))) + (poststrings (when (stringp fun) + (prog1 (list fun) (setq fun (pop args))))) + (exps (edebug-cursor-expressions cursor)) + (instrumented (edebug-match-one-spec cursor spec)) + (consumed (- (length exps) + (length (edebug-cursor-expressions cursor)))) + (newname (apply (or fun #'edebug--concat-name) + `(,@args ,edebug-def-name + ,@prestrings + ,@(seq-subseq exps 0 consumed) + ,@poststrings)))) + (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps))) + (setq edebug-def-name (if (stringp newname) (intern newname) newname)) + instrumented)) + +(defun edebug--concat-name (oldname &rest newnames) + (let ((newname (if (null (cdr newnames)) + (car newnames) + ;; Put spaces between each name, but not for the + ;; leading and trailing strings, if any. + (let (beg mid end) + (dolist (name newnames) + (if (stringp name) + (push name (if mid end beg)) + (when end (setq mid (nconc end mid) end nil)) + (push name mid))) + (apply #'concat `(,@(nreverse beg) + ,(mapconcat (lambda (x) (format "%s" x)) + (nreverse mid) " ") + ,@(nreverse end))))))) + (if (null oldname) + (if (or (stringp newname) (symbolp newname)) + newname + (format "%s" newname)) + (format "%s@%s" edebug-def-name newname)))) + +(def-edebug-elem-spec 'name '(&name symbolp)) + +(cl-defgeneric edebug--handle-:-spec-op (op cursor spec) + "Handle :foo spec operators. +:foo spec operators operate on just the one subsequent SPEC element.") + +(cl-defmethod edebug--handle-:-spec-op ((_ (eql :name)) _cursor spec) ;; Set the edebug-def-name to the spec. (setq edebug-def-name (if edebug-def-name @@ -2043,7 +2027,7 @@ contains a circular object." spec)) nil) -(defun edebug-match-:unique (_cursor spec) +(cl-defmethod edebug--handle-:-spec-op ((_ (eql :unique)) _cursor spec) "Match a `:unique PREFIX' specifier. SPEC is the symbol name prefix for `gensym'." (let ((suffix (gensym spec))) @@ -2054,63 +2038,6 @@ SPEC is the symbol name prefix for `gensym'." suffix))) nil) -(defun edebug-match-cl-generic-method-qualifier (cursor) - "Match a QUALIFIER for `cl-defmethod' at CURSOR." - (let ((args (edebug-top-element-required cursor "Expected qualifier"))) - ;; Like in CLOS spec, we support any non-list values. - (unless (atom args) (edebug-no-match cursor "Atom expected")) - ;; Append the arguments to `edebug-def-name' (Bug#42671). - (setq edebug-def-name (intern (format "%s %s" edebug-def-name args))) - (edebug-move-cursor cursor) - (list args))) - -(defun edebug-match-cl-generic-method-args (cursor) - (let ((args (edebug-top-element-required cursor "Expected arguments"))) - (if (not (consp args)) - (edebug-no-match cursor "List expected")) - ;; Append the arguments to edebug-def-name. - (setq edebug-def-name - (intern (format "%s %s" edebug-def-name args))) - (edebug-move-cursor cursor) - (list args))) - -(defvar edebug--cl-macrolet-defs nil - "List of symbols found within the bindings of enclosing `cl-macrolet' forms.") -(defvar edebug--current-cl-macrolet-defs nil - "List of symbols found within the bindings of the current `cl-macrolet' form.") - -(defun edebug-match-cl-macrolet-expr (cursor) - "Match a `cl-macrolet' form at CURSOR." - (let (edebug--current-cl-macrolet-defs) - (edebug-match cursor - '((&rest (&define cl-macrolet-name cl-macro-list - cl-declarations-or-string - def-body)) - cl-declarations cl-macrolet-body)))) - -(defun edebug-match-cl-macrolet-name (cursor) - "Match the name in a `cl-macrolet' binding at CURSOR. -Collect the names in `edebug--cl-macrolet-defs' where they -will be checked by `edebug-list-form-args' and treated as -macros without a spec." - (let ((name (edebug-top-element-required cursor "Expected name"))) - (when (not (symbolp name)) - (edebug-no-match cursor "Bad name:" name)) - ;; Change edebug-def-name to avoid conflicts with - ;; names at global scope. - (setq edebug-def-name (gensym "edebug-anon")) - (edebug-move-cursor cursor) - (push name edebug--current-cl-macrolet-defs) - (list name))) - -(defun edebug-match-cl-macrolet-body (cursor) - "Match the body of a `cl-macrolet' expression at CURSOR. -Put the definitions collected in `edebug--current-cl-macrolet-defs' -into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." - (let ((edebug--cl-macrolet-defs (nconc edebug--current-cl-macrolet-defs - edebug--cl-macrolet-defs))) - (edebug-match-body cursor))) - (defun edebug-match-arg (cursor) ;; set the def-args bound in edebug-defining-form (let ((edebug-arg (edebug-top-element-required cursor "Expected arg"))) @@ -2139,151 +2066,135 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." ;; This happens to handle bug#20281, tho maybe a better fix would be to ;; improve the `defun' spec. (when forms - (list (edebug-wrap-def-body forms))))) + (list (edebug-make-enter-wrapper forms))))) ;;;; Edebug Form Specs ;;; ========================================================== -;;;;* Spec for def-edebug-spec -;;; Out of date. - -(defun edebug-spec-p (object) - "Return non-nil if OBJECT is a symbol with an edebug-form-spec property." - (and (symbolp object) - (get object 'edebug-form-spec))) - -(def-edebug-spec def-edebug-spec - ;; Top level is different from lower levels. - (&define :name edebug-spec name - &or "nil" edebug-spec-p "t" "0" (&rest edebug-spec))) - -(def-edebug-spec edebug-spec-list - ;; A list must have something in it, or it is nil, a symbolp - ((edebug-spec . [&or nil edebug-spec]))) - -(def-edebug-spec edebug-spec - (&or - edebug-spec-list - (vector &rest edebug-spec) ; matches a vector - ("vector" &rest edebug-spec) ; matches a vector spec - ("quote" symbolp) - stringp - [edebug-lambda-list-keywordp &rest edebug-spec] - [keywordp gate edebug-spec] - edebug-spec-p ;; Including all the special ones e.g. form. - symbolp;; a predicate - )) - - ;;;* Emacs special forms and some functions. -;; quote expects only one argument, although it allows any number. -(def-edebug-spec quote sexp) +(pcase-dolist + (`(,name ,spec) + + '((quote (sexp)) ;quote expects only one arg, tho it allows any number. + + ;; The standard defining forms. + (defvar (symbolp &optional form stringp)) + (defconst defvar) + + ;; Contrary to macros, special forms default to assuming that all args + ;; are normal forms, so we don't need to do anything about those + ;; special forms: + ;;(save-current-buffer t) + ;;(save-excursion t) + ;;... + ;;(progn t) + + ;; `defun' and `defmacro' are not special forms (any more), but it's + ;; more convenient to define their Edebug spec here. + (defun ( &define name lambda-list lambda-doc + [&optional ("declare" def-declarations)] + [&optional ("interactive" &optional [&or stringp def-form] + &rest symbolp)] + def-body)) + + (defmacro ( &define name lambda-list lambda-doc + [&optional ("declare" def-declarations)] + def-body)) + + ;; function expects a symbol or a lambda or macro expression + ;; A macro is allowed by Emacs. + (function (&or symbolp lambda-expr)) + + ;; FIXME? The manual uses this form (maybe that's just + ;; for illustration purposes?): + ;; (let ((&rest &or symbolp (gate symbolp &optional form)) body)) + (let ((&rest &or (symbolp &optional form) symbolp) body)) + (let* let) + + (setq (&rest symbolp form)) + (cond (&rest (&rest form))) + + (condition-case ( symbolp form + &rest ([&or symbolp (&rest symbolp)] body))) + + (\` (backquote-form)) + + ;; Assume immediate quote in unquotes mean backquote at next + ;; higher level. + (\, (&or ("quote" edebug-\`) def-form)) + (\,@ (&define ;; so (,@ form) is never wrapped. + &or ("quote" edebug-\`) def-form)) + )) + (put name 'edebug-form-spec spec)) + +(defun edebug--match-declare-arg (head pf) + (funcall pf (get (car head) 'edebug-declaration-spec))) -;; The standard defining forms. -(def-edebug-spec defconst defvar) -(def-edebug-spec defvar (symbolp &optional form stringp)) +(def-edebug-elem-spec 'def-declarations + '(&rest &or (&interpose symbolp edebug--match-declare-arg) sexp)) -(def-edebug-spec defun - (&define name lambda-list lambda-doc - [&optional ("declare" &rest sexp)] - [&optional ("interactive" interactive)] - def-body)) -(def-edebug-spec defmacro - ;; FIXME: Improve `declare' so we can Edebug gv-expander and - ;; gv-setter declarations. - (&define name lambda-list lambda-doc - [&optional ("declare" &rest sexp)] def-body)) +(def-edebug-elem-spec 'lambda-list + '(([&rest arg] + [&optional ["&optional" arg &rest arg]] + &optional ["&rest" arg] + ))) -(def-edebug-spec arglist lambda-list) ;; deprecated - use lambda-list. +(def-edebug-elem-spec 'lambda-expr + '(("lambda" &define lambda-list lambda-doc + [&optional ("interactive" interactive)] + def-body))) -(def-edebug-spec lambda-list - (([&rest arg] - [&optional ["&optional" arg &rest arg]] - &optional ["&rest" arg] - ))) +(def-edebug-elem-spec 'arglist '(lambda-list)) ;; deprecated - use lambda-list. -(def-edebug-spec lambda-doc - (&optional [&or stringp - (&define ":documentation" def-form)])) +(def-edebug-elem-spec 'lambda-doc + '(&optional [&or stringp + (&define ":documentation" def-form)])) -(def-edebug-spec interactive - (&optional &or stringp def-form)) +(def-edebug-elem-spec 'interactive '(&optional [&or stringp def-form] + &rest symbolp)) ;; A function-form is for an argument that may be a function or a form. ;; This specially recognizes anonymous functions quoted with quote. -(def-edebug-spec function-form +(def-edebug-elem-spec 'function-form ;Deprecated, use `form'! ;; form at the end could also handle "function", ;; but recognize it specially to avoid wrapping function forms. - (&or ([&or "quote" "function"] &or symbolp lambda-expr) form)) - -;; function expects a symbol or a lambda or macro expression -;; A macro is allowed by Emacs. -(def-edebug-spec function (&or symbolp lambda-expr)) - -;; A macro expression is a lambda expression with "macro" prepended. -(def-edebug-spec macro (&define "lambda" lambda-list def-body)) - -;; (def-edebug-spec anonymous-form ((&or ["lambda" lambda] ["macro" macro]))) - -;; Standard functions that take function-forms arguments. - -;; FIXME? The manual uses this form (maybe that's just for illustration?): -;; (def-edebug-spec let -;; ((&rest &or symbolp (gate symbolp &optional form)) -;; body)) -(def-edebug-spec let - ((&rest &or (symbolp &optional form) symbolp) - body)) - -(def-edebug-spec let* let) - -(def-edebug-spec setq (&rest symbolp form)) - -(def-edebug-spec cond (&rest (&rest form))) - -(def-edebug-spec condition-case - (symbolp - form - &rest ([&or symbolp (&rest symbolp)] body))) - - -(def-edebug-spec \` (backquote-form)) + '(&or ([&or "quote" "function"] &or symbolp lambda-expr) form)) ;; Supports quotes inside backquotes, ;; but only at the top level inside unquotes. -(def-edebug-spec backquote-form - (&or - ;; Disallow instrumentation of , and ,@ inside a nested backquote, since - ;; these are likely to be forms generated by a macro being debugged. - ("`" nested-backquote-form) - ([&or "," ",@"] &or ("quote" backquote-form) form) - ;; The simple version: - ;; (backquote-form &rest backquote-form) - ;; doesn't handle (a . ,b). The straightforward fix: - ;; (backquote-form . [&or nil backquote-form]) - ;; uses up too much stack space. - ;; Note that `(foo . ,@bar) is not valid, so we don't need to handle it. - (backquote-form [&rest [¬ ","] backquote-form] - . [&or nil backquote-form]) - ;; If you use dotted forms in backquotes, replace the previous line - ;; with the following. This takes quite a bit more stack space, however. - ;; (backquote-form . [&or nil backquote-form]) - (vector &rest backquote-form) - sexp)) - -(def-edebug-spec nested-backquote-form - (&or - ("`" &error "Triply nested backquotes (without commas \"between\" them) \ +(def-edebug-elem-spec 'backquote-form + '(&or + ;; Disallow instrumentation of , and ,@ inside a nested backquote, since + ;; these are likely to be forms generated by a macro being debugged. + ("`" nested-backquote-form) + ([&or "," ",@"] &or ("quote" backquote-form) form) + ;; The simple version: + ;; (backquote-form &rest backquote-form) + ;; doesn't handle (a . ,b). The straightforward fix: + ;; (backquote-form . [&or nil backquote-form]) + ;; uses up too much stack space. + ;; Note that `(foo . ,@bar) is not valid, so we don't need to handle it. + (backquote-form [&rest [¬ ","] backquote-form] + . [&or nil backquote-form]) + ;; If you use dotted forms in backquotes, replace the previous line + ;; with the following. This takes quite a bit more stack space, however. + ;; (backquote-form . [&or nil backquote-form]) + (vector &rest backquote-form) + sexp)) + +(def-edebug-elem-spec 'nested-backquote-form + '(&or + ("`" &error "Triply nested backquotes (without commas \"between\" them) \ are too difficult to instrument") - ;; Allow instrumentation of any , or ,@ contained within the (\, ...) or - ;; (\,@ ...) matched on the next line. - ([&or "," ",@"] backquote-form) - (nested-backquote-form [&rest [¬ "," ",@"] nested-backquote-form] - . [&or nil nested-backquote-form]) - (vector &rest nested-backquote-form) - sexp)) + ;; Allow instrumentation of any , or ,@ contained within the (\, ...) or + ;; (\,@ ...) matched on the next line. + ([&or "," ",@"] backquote-form) + (nested-backquote-form [&rest [¬ "," ",@"] nested-backquote-form] + . [&or nil nested-backquote-form]) + (vector &rest nested-backquote-form) + sexp)) ;; Special version of backquote that instruments backquoted forms ;; destined to be evaluated, usually as the result of a @@ -2298,20 +2209,9 @@ are too difficult to instrument") ;; ,@ might have some problems. -(defalias 'edebug-\` '\`) ;; same macro as regular backquote. -(def-edebug-spec edebug-\` (def-form)) - -;; Assume immediate quote in unquotes mean backquote at next higher level. -(def-edebug-spec \, (&or ("quote" edebug-\`) def-form)) -(def-edebug-spec \,@ (&define ;; so (,@ form) is never wrapped. - &or ("quote" edebug-\`) def-form)) - -;; New byte compiler. - -(def-edebug-spec save-selected-window t) -(def-edebug-spec save-current-buffer t) - -;; Anything else? +(defmacro edebug-\` (exp) + (declare (debug (def-form))) + (list '\` exp)) ;;; The debugger itself @@ -2485,11 +2385,10 @@ STATUS should be a list returned by `edebug-var-status'." (edebug-print-trace-after (format "%s result: %s" function edebug-result))))) -(def-edebug-spec edebug-tracing (form body)) - (defmacro edebug-tracing (msg &rest body) "Print MSG in *edebug-trace* before and after evaluating BODY. The result of BODY is also printed." + (declare (debug (form body))) `(let ((edebug-stack-depth (1+ edebug-stack-depth)) edebug-result) (edebug-print-trace-before ,msg) @@ -2921,7 +2820,6 @@ See `edebug-behavior-alist' for implementations.") (defvar edebug-outside-match-data) ; match data outside of edebug (defvar edebug-backtrace-buffer) ; each recursive edit gets its own (defvar edebug-inside-windows) -(defvar edebug-interactive-p) (defvar edebug-mode-map) ; will be defined fully later. @@ -2937,7 +2835,6 @@ See `edebug-behavior-alist' for implementations.") ;;(edebug-number-of-recursions (1+ edebug-number-of-recursions)) (edebug-recursion-depth (recursion-depth)) edebug-entered ; bind locally to nil - (edebug-interactive-p nil) ; again non-interactive edebug-backtrace-buffer ; each recursive edit gets its own ;; The window configuration may be saved and restored ;; during a recursive-edit @@ -3601,7 +3498,10 @@ canceled the first time the function is entered." ;; Could store this in the edebug data instead. (put function 'edebug-on-entry (if flag 'temp t))) -(defalias 'edebug-cancel-edebug-on-entry #'cancel-edebug-on-entry) +(define-obsolete-function-alias 'edebug-cancel-edebug-on-entry + #'edebug-cancel-on-entry "28.1") +(define-obsolete-function-alias 'cancel-edebug-on-entry + #'edebug-cancel-on-entry "28.1") (defun edebug--edebug-on-entry-functions () (let ((functions nil)) @@ -3613,9 +3513,9 @@ canceled the first time the function is entered." obarray) functions)) -(defun cancel-edebug-on-entry (function) +(defun edebug-cancel-on-entry (function) "Cause Edebug to not stop when FUNCTION is called. -The removes the effect of `edebug-on-entry'. If FUNCTION is is +The removes the effect of `edebug-on-entry'. If FUNCTION is nil, remove `edebug-on-entry' on all functions." (interactive (list (let ((name (completing-read @@ -3801,9 +3701,10 @@ Print result in minibuffer." (interactive (list (read--expression "Eval: "))) (princ (edebug-outside-excursion - (setq values (cons (edebug-eval expr) values)) - (concat (edebug-safe-prin1-to-string (car values)) - (eval-expression-print-format (car values)))))) + (let ((result (edebug-eval expr))) + (values--store-value result) + (concat (edebug-safe-prin1-to-string result) + (eval-expression-print-format result)))))) (defun edebug-eval-last-sexp (&optional no-truncate) "Evaluate sexp before point in the outside environment. @@ -3936,10 +3837,14 @@ be installed in `emacs-lisp-mode-map'.") ;; Autoloading these global bindings doesn't make sense because ;; they cannot be used anyway unless Edebug is already loaded and active. -(defvar global-edebug-prefix "\^XX" +(define-obsolete-variable-alias 'global-edebug-prefix + 'edebug-global-prefix "28.1") +(defvar edebug-global-prefix "\^XX" "Prefix key for global edebug commands, available from any buffer.") -(defvar global-edebug-map +(define-obsolete-variable-alias 'global-edebug-map + 'edebug-global-map "28.1") +(defvar edebug-global-map (let ((map (make-sparse-keymap))) (define-key map " " 'edebug-step-mode) @@ -3972,9 +3877,9 @@ be installed in `emacs-lisp-mode-map'.") map) "Global map of edebug commands, available from any buffer.") -(when global-edebug-prefix - (global-unset-key global-edebug-prefix) - (global-set-key global-edebug-prefix global-edebug-map)) +(when edebug-global-prefix + (global-unset-key edebug-global-prefix) + (global-set-key edebug-global-prefix edebug-global-map)) (defun edebug-help () @@ -4216,12 +4121,12 @@ This should be a list of `edebug---frame' objects.") "Stack frames of the current Edebug Backtrace buffer with instrumentation. This should be a list of `edebug---frame' objects.") -;; Data structure for backtrace frames with information -;; from Edebug instrumentation found in the backtrace. (cl-defstruct (edebug--frame (:constructor edebug--make-frame) (:include backtrace-frame)) + "Data structure for backtrace frames with information +from Edebug instrumentation found in the backtrace." def-name before-index after-index) (defun edebug-pop-to-backtrace () @@ -4236,7 +4141,8 @@ This should be a list of `edebug---frame' objects.") (pop-to-buffer edebug-backtrace-buffer) (unless (derived-mode-p 'backtrace-mode) (backtrace-mode) - (add-hook 'backtrace-goto-source-functions #'edebug--backtrace-goto-source)) + (add-hook 'backtrace-goto-source-functions + #'edebug--backtrace-goto-source nil t)) (setq edebug-instrumented-backtrace-frames (backtrace-get-frames 'edebug-debugger :constructor #'edebug--make-frame) @@ -4470,10 +4376,6 @@ It is removed when you hit any char." (set variable (not (symbol-value variable))) (message "%s: %s" variable (symbol-value variable))) -;; We have to require easymenu (even for Emacs 18) just so -;; the easy-menu-define macro call is compiled correctly. -(require 'easymenu) - (defconst edebug-mode-menus '("Edebug" ["Stop" edebug-stop t] @@ -4578,13 +4480,18 @@ With prefix argument, make it a temporary breakpoint." (add-hook 'called-interactively-p-functions #'edebug--called-interactively-skip) (defun edebug--called-interactively-skip (i frame1 frame2) - (when (and (eq (car-safe (nth 1 frame1)) 'lambda) - (eq (nth 1 (nth 1 frame1)) '()) - (eq (nth 1 frame2) 'edebug-enter)) + (when (and (memq (car-safe (nth 1 frame1)) '(lambda closure)) + ;; Lambda value with no arguments. + (null (nth (if (eq (car-safe (nth 1 frame1)) 'lambda) 1 2) + (nth 1 frame1))) + (memq (nth 1 frame2) '(edebug-enter edebug-default-enter))) ;; `edebug-enter' calls itself on its first invocation. - (if (eq (nth 1 (backtrace-frame i 'called-interactively-p)) - 'edebug-enter) - 2 1))) + (let ((s 1)) + (while (memq (nth 1 (backtrace-frame i 'called-interactively-p)) + '(edebug-enter edebug-default-enter)) + (cl-incf s) + (cl-incf i)) + s))) ;; Finally, hook edebug into the rest of Emacs. ;; There are probably some other things that could go here. diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index ec1077d447e..ec7c899bddc 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -1,7 +1,6 @@ ;;; eieio-base.el --- Base classes for EIEIO. -*- lexical-binding:t -*- -;;; Copyright (C) 2000-2002, 2004-2005, 2007-2021 Free Software -;;; Foundation, Inc. +;; Copyright (C) 2000-2021 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Keywords: OO, lisp @@ -157,7 +156,7 @@ only one object ever exists." ;; NOTE TO SELF: In next version, make `slot-boundp' support classes ;; with class allocated slots or default values. (let ((old (oref-default class singleton))) - (if (eq old eieio-unbound) + (if (eq old eieio--unbound) (oset-default class singleton (cl-call-next-method)) old))) diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index db97d4ca4e8..6d84839c341 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -105,7 +105,7 @@ Summary: (declare (doc-string 3) (obsolete cl-defmethod "25.1") (debug (&define ; this means we are defining something - [&or name ("setf" name :name setf)] + [&name sexp] ;Allow (setf ...) additionally to symbols. ;; ^^ This is the methods symbol [ &optional symbolp ] ; this is key :before etc cl-generic-method-args ; arguments diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index a8361c0d4b4..b11ed3333f0 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -71,11 +71,10 @@ Currently under control of this var: - Define <class>-child-p and <class>-list-p predicates. - Allow object names in constructors.") -(defconst eieio-unbound - (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound)) - eieio-unbound - (make-symbol "unbound")) +(define-obsolete-variable-alias 'eieio-unbound 'eieio--unbound "28.1") +(defvar eieio--unbound (make-symbol "eieio--unbound") "Uninterned symbol representing an unbound slot in an object.") +(defvar eieio--unbound-form (macroexp-quote eieio--unbound)) ;; This is a bootstrap for eieio-default-superclass so it has a value ;; while it is being built itself. @@ -169,7 +168,7 @@ Return nil if that option doesn't exist." (and (recordp obj) (eieio--class-p (eieio--object-class obj)))) -(define-obsolete-function-alias 'object-p 'eieio-object-p "25.1") +(define-obsolete-function-alias 'object-p #'eieio-object-p "25.1") (defun class-abstract-p (class) "Return non-nil if CLASS is abstract. @@ -242,9 +241,9 @@ use \\='%s or turn off `eieio-backward-compatibility' instead" cname) (cl-deftype list-of (elem-type) `(and list - (satisfies (lambda (list) - (cl-every (lambda (elem) (cl-typep elem ',elem-type)) - list))))) + (satisfies ,(lambda (list) + (cl-every (lambda (elem) (cl-typep elem elem-type)) + list))))) (defun eieio-make-class-predicate (class) @@ -264,6 +263,7 @@ use \\='%s or turn off `eieio-backward-compatibility' instead" cname) (object-of-class-p obj class)))) (defvar eieio--known-slot-names nil) +(defvar eieio--known-class-slot-names nil) (defun eieio-defclass-internal (cname superclasses slots options) "Define CNAME as a new subclass of SUPERCLASSES. @@ -347,19 +347,20 @@ See `defclass' for more information." (when eieio-backward-compatibility (let ((csym (intern (concat (symbol-name cname) "-list-p")))) (defalias csym - `(lambda (obj) - ,(format - "Test OBJ to see if it a list of objects which are a child of type %s" - cname) - (when (listp obj) - (let ((ans t)) ;; nil is valid - ;; Loop over all the elements of the input list, test - ;; each to make sure it is a child of the desired object class. - (while (and obj ans) - (setq ans (and (eieio-object-p (car obj)) - (object-of-class-p (car obj) ,cname))) - (setq obj (cdr obj))) - ans)))) + (lambda (obj) + (:documentation + (format + "Test OBJ to see if it a list of objects which are a child of type %s" + cname)) + (when (listp obj) + (let ((ans t)) ;; nil is valid + ;; Loop over all the elements of the input list, test + ;; each to make sure it is a child of the desired object class. + (while (and obj ans) + (setq ans (and (eieio-object-p (car obj)) + (object-of-class-p (car obj) 'cname))) + (setq obj (cdr obj))) + ans)))) (make-obsolete csym (format "use (cl-typep ... \\='(list-of %s)) instead" cname) @@ -380,7 +381,7 @@ See `defclass' for more information." (pcase-dolist (`(,name . ,slot) slots) (let* ((init (or (plist-get slot :initform) (if (member :initform slot) nil - eieio-unbound))) + eieio--unbound-form))) (initarg (plist-get slot :initarg)) (docstr (plist-get slot :documentation)) (prot (plist-get slot :protection)) @@ -394,6 +395,14 @@ See `defclass' for more information." (skip-nil (eieio--class-option-assoc options :allow-nil-initform)) ) + (unless (or (macroexp-const-p init) + (eieio--eval-default-p init)) + ;; FIXME: We duplicate this test here and in `defclass' because + ;; if we move this part to `defclass' we may break some existing + ;; code (because the `fboundp' test in `eieio--eval-default-p' + ;; returns a different result at compile time). + (setq init (macroexp-quote init))) + ;; Clean up the meaning of protection. (setq prot (pcase prot @@ -456,8 +465,9 @@ See `defclass' for more information." (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 (aref v i) (eval + (cl--slot-descriptor-initform (aref slots i)) + t))) (setf (eieio--class-class-allocation-values newc) v)) ;; Attach slot symbols into a hash table, and store the index of @@ -512,7 +522,7 @@ See `defclass' for more information." cname )) -(defsubst eieio-eval-default-p (val) +(defun eieio--eval-default-p (val) "Whether the default value VAL should be evaluated for use." (and (consp val) (symbolp (car val)) (fboundp (car val)))) @@ -521,10 +531,10 @@ See `defclass' for more information." 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? + (if (not (or (not (macroexp-const-p value)) eieio-skip-typecheck (and skipnil (null value)) - (eieio--perform-slot-validation spec value))) + (eieio--perform-slot-validation spec (eval value t)))) (signal 'invalid-slot-type (list (cl--slot-descriptor-name slot) spec value))))) (defun eieio--slot-override (old new skipnil) @@ -545,7 +555,7 @@ If SKIPNIL is non-nil, then if default value is nil return t instead." type tp a)) (setf (cl--slot-descriptor-type new) tp)) ;; If we have a repeat, only update the initarg... - (unless (eq d eieio-unbound) + (unless (eq d eieio--unbound-form) (eieio--perform-slot-validation-for-default new skipnil) (setf (cl--slot-descriptor-initform old) d)) @@ -603,6 +613,8 @@ if default value is nil." (cold (car (cl-member a (eieio--class-class-slots newc) :key #'cl--slot-descriptor-name)))) (cl-pushnew a eieio--known-slot-names) + (when (eq alloc :class) + (cl-pushnew a eieio--known-class-slot-names)) (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 @@ -678,7 +690,7 @@ the new child class." (defun eieio--perform-slot-validation (spec value) "Return non-nil if SPEC does not match VALUE." (or (eq spec t) ; t always passes - (eq value eieio-unbound) ; unbound always passes + (eq value eieio--unbound) ; unbound always passes (cl-typep value spec))) (defun eieio--validate-slot-value (class slot-idx value slot) @@ -714,7 +726,7 @@ an error." 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)) + (if (and (eq value eieio--unbound) (not eieio-skip-typecheck)) (slot-unbound instance (eieio--object-class instance) slotname fn) value)) @@ -729,8 +741,9 @@ Argument FN is the function calling this verifier." (pcase slot ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) - (macroexp--warn-and-return - (format-message "Unknown slot `%S'" name) exp 'compile-only)) + (macroexp-warn-and-return + (format-message "Unknown slot `%S'" name) + exp nil 'compile-only)) (_ exp)))) (gv-setter eieio-oset)) (cl-check-type slot symbol) @@ -754,15 +767,30 @@ Argument FN is the function calling this verifier." (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) -(defun eieio-oref-default (obj slot) +(defun eieio-oref-default (class slot) "Do the work for the macro `oref-default' with similar parameters. -Fills in OBJ's SLOT with its default value." - (declare (gv-setter eieio-oset-default)) - (cl-check-type obj (or eieio-object class)) +Fills in CLASS's SLOT with its default value." + (declare (gv-setter eieio-oset-default) + (compiler-macro + (lambda (exp) + (ignore class) + (pcase slot + ((and (or `',name (and name (pred keywordp))) + (guard (not (memq name eieio--known-slot-names)))) + (macroexp-warn-and-return + (format-message "Unknown slot `%S'" name) + exp nil 'compile-only)) + ((and (or `',name (and name (pred keywordp))) + (guard (not (memq name eieio--known-class-slot-names)))) + (macroexp-warn-and-return + (format-message "Slot `%S' is not class-allocated" name) + exp nil 'compile-only)) + (_ exp))))) + (cl-check-type class (or eieio-object class)) (cl-check-type slot symbol) - (let* ((cl (cond ((symbolp obj) (cl--find-class obj)) - ((eieio-object-p obj) (eieio--object-class obj)) - (t obj))) + (let* ((cl (cond ((symbolp class) (cl--find-class class)) + ((eieio-object-p class) (eieio--object-class class)) + (t class))) (c (eieio--slot-name-index cl slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. @@ -772,27 +800,13 @@ Fills in OBJ's SLOT with its default value." ;; Oref that slot. (aref (eieio--class-class-allocation-values cl) c) - (slot-missing obj slot 'oref-default)) + (slot-missing class slot 'oref-default)) (eieio-barf-if-slot-unbound (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-name cl) 'oref-default)))) - -(defun eieio-default-eval-maybe (val) - "Check VAL, and return what `oref-default' would provide." - ;; FIXME: What the hell is this supposed to do? Shouldn't it evaluate - ;; variables as well? Why not just always call `eval'? - (cond - ;; Is it a function call? If so, evaluate it. - ((eieio-eval-default-p val) - (eval val)) - ;;;; check for quoted things, and unquote them - ;;((and (consp val) (eq (car val) 'quote)) - ;; (car (cdr val))) - ;; return it verbatim - (t val))) + (eval val t)) + class (eieio--class-name cl) 'oref-default)))) (defun eieio-oset (obj slot value) "Do the work for the macro `oset'. @@ -819,6 +833,21 @@ Fills in OBJ's SLOT with VALUE." (defun eieio-oset-default (class slot value) "Do the work for the macro `oset-default'. Fills in the default value in CLASS' in SLOT with VALUE." + (declare (compiler-macro + (lambda (exp) + (ignore class value) + (pcase slot + ((and (or `',name (and name (pred keywordp))) + (guard (not (memq name eieio--known-slot-names)))) + (macroexp-warn-and-return + (format-message "Unknown slot `%S'" name) + exp nil 'compile-only)) + ((and (or `',name (and name (pred keywordp))) + (guard (not (memq name eieio--known-class-slot-names)))) + (macroexp-warn-and-return + (format-message "Slot `%S' is not class-allocated" name) + exp nil 'compile-only)) + (_ exp))))) (setq class (eieio--class-object class)) (cl-check-type class eieio--class) (cl-check-type slot symbol) @@ -835,22 +864,18 @@ Fills in the default value in CLASS' in SLOT with VALUE." (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. + ;; it'd be nice to get rid 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")) (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) + (macroexp-quote value)) ;; Take the value, and put it into our cache object. (eieio-oset (eieio--class-default-object-cache class) slot value) @@ -1029,7 +1054,7 @@ method invocation orders of the involved classes." (eieio--class-precedence-c3 class)))))) (define-obsolete-function-alias - 'class-precedence-list 'eieio--class-precedence-list "24.4") + 'class-precedence-list #'eieio--class-precedence-list "24.4") ;;; Here are some special types of errors @@ -1092,8 +1117,20 @@ These match if the argument is the name of a subclass of CLASS." (defmacro eieio-declare-slots (&rest slots) "Declare that SLOTS are known eieio object slot names." - `(eval-when-compile - (setq eieio--known-slot-names (append ',slots eieio--known-slot-names)))) + (let ((slotnames (mapcar (lambda (s) (if (consp s) (car s) s)) slots)) + (classslots (delq nil + (mapcar (lambda (s) + (when (and (consp s) + (eq :class (plist-get (cdr s) + :allocation))) + (car s))) + slots)))) + `(eval-when-compile + ,@(when classslots + (mapcar (lambda (s) `(add-to-list 'eieio--known-class-slot-names ',s)) + classslots)) + ,@(mapcar (lambda (s) `(add-to-list 'eieio--known-slot-names ',s)) + slotnames)))) (provide 'eieio-core) diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index 184b99fdac6..d7d078b2d94 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -1,4 +1,4 @@ -;;; eieio-custom.el -- eieio object customization -*- lexical-binding:t -*- +;;; eieio-custom.el --- eieio object customization -*- lexical-binding:t -*- ;; Copyright (C) 1999-2001, 2005, 2007-2021 Free Software Foundation, ;; Inc. @@ -46,7 +46,7 @@ :documentation "A string for testing custom. This is the next line of documentation.") (listostuff :initarg :listostuff - :initform ("1" "2" "3") + :initform '("1" "2" "3") :type list :custom (repeat (string :tag "Stuff")) :label "List of Strings" diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index e65f424cbab..9c842f46829 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -1,4 +1,4 @@ -;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) -*- lexical-binding: t; -*- +;;; eieio-opt.el --- eieio optional functions (debug, printing, speedbar) -*- lexical-binding: t; -*- ;; Copyright (C) 1996, 1998-2003, 2005, 2008-2021 Free Software ;; Foundation, Inc. @@ -323,7 +323,7 @@ current expansion depth." (defun eieio-sb-expand (text class indent) "For button TEXT, expand CLASS at the current location. Argument INDENT is the depth of indentation." - (cond ((string-match "\\+" text) ;we have to expand this file + (cond ((string-search "+" text) ;we have to expand this file (speedbar-change-expand-button-char ?-) (speedbar-with-writable (save-excursion @@ -332,7 +332,7 @@ Argument INDENT is the depth of indentation." (while subclasses (eieio-class-button (car subclasses) (1+ indent)) (setq subclasses (cdr subclasses))))))) - ((string-match "-" text) ;we have to contract this node + ((string-search "-" text) ;we have to contract this node (speedbar-change-expand-button-char ?+) (speedbar-delete-subblock indent)) (t (error "Ooops... not sure what to do"))) diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index 8bf77e20dfa..86b22cad73b 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el @@ -1,4 +1,4 @@ -;;; eieio-speedbar.el -- Classes for managing speedbar displays. -*- lexical-binding:t -*- +;;; eieio-speedbar.el --- Classes for managing speedbar displays. -*- lexical-binding:t -*- ;; Copyright (C) 1999-2002, 2005, 2007-2021 Free Software Foundation, ;; Inc. @@ -248,7 +248,7 @@ and take the appropriate action." Possible values are those symbols supported by the `exp-button-type' argument to `speedbar-make-tag-line'." :allocation :class) - (buttonface :initform speedbar-tag-face + (buttonface :initform 'speedbar-tag-face :type (or symbol face) :documentation "The face used on the textual part of the button for this class. @@ -265,15 +265,15 @@ Add one of the child classes to this class to the parent list of a class." :abstract t) (defclass eieio-speedbar-directory-button (eieio-speedbar) - ((buttontype :initform angle) - (buttonface :initform speedbar-directory-face)) + ((buttontype :initform 'angle) + (buttonface :initform 'speedbar-directory-face)) "Class providing support for objects which behave like a directory." :method-invocation-order :depth-first :abstract t) (defclass eieio-speedbar-file-button (eieio-speedbar) - ((buttontype :initform bracket) - (buttonface :initform speedbar-file-face)) + ((buttontype :initform 'bracket) + (buttonface :initform 'speedbar-file-face)) "Class providing support for objects which behave like a file." :method-invocation-order :depth-first :abstract t) @@ -344,14 +344,14 @@ The object is at indentation level INDENT." (defun eieio-speedbar-object-expand (text token indent) "Expand object represented by TEXT. TOKEN is the object. INDENT is the current indentation level." - (cond ((string-match "\\+" text) ;we have to expand this file + (cond ((string-search "+" text) ;we have to expand this file (speedbar-change-expand-button-char ?-) (oset token expanded t) (speedbar-with-writable (save-excursion (end-of-line) (forward-char 1) (eieio-speedbar-expand token (1+ indent))))) - ((string-match "-" text) ;we have to contract this node + ((string-search "-" text) ;we have to contract this node (speedbar-change-expand-button-char ?+) (oset token expanded nil) (speedbar-delete-subblock indent)) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index a095ad0f6db..c16d8e110ec 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -53,6 +53,7 @@ (message eieio-version)) (require 'eieio-core) +(eval-when-compile (require 'subr-x)) ;;; Defining a new class @@ -131,6 +132,7 @@ and reference them using the function `class-option'." (let ((testsym1 (intern (concat (symbol-name name) "-p"))) (testsym2 (intern (format "%s--eieio-childp" name))) + (warnings '()) (accessors ())) ;; Collect the accessors we need to define. @@ -145,6 +147,8 @@ and reference them using the function `class-option'." ;; Update eieio--known-slot-names already in case we compile code which ;; uses this before the class is loaded. (cl-pushnew sname eieio--known-slot-names) + (when (eq alloc :class) + (cl-pushnew sname eieio--known-class-slot-names)) (if eieio-error-unsupported-class-tags (let ((tmp soptions)) @@ -176,8 +180,22 @@ and reference them using the function `class-option'." (signal 'invalid-slot-type (list :label label))) ;; Is there an initarg, but allocation of class? - (if (and initarg (eq alloc :class)) - (message "Class allocated slots do not need :initarg")) + (when (and initarg (eq alloc :class)) + (push (format "Meaningless :initarg for class allocated slot '%S'" + sname) + warnings)) + + (let ((init (plist-get soptions :initform))) + (unless (or (macroexp-const-p init) + (eieio--eval-default-p init)) + ;; FIXME: Historically, EIEIO used a heuristic to try and guess + ;; whether the initform is a form to be evaluated or just + ;; a constant. We use `eieio--eval-default-p' to see what the + ;; heuristic says and if it disagrees with normal evaluation + ;; then tweak the initform to make it fit and emit + ;; a warning accordingly. + (push (format "Ambiguous initform needs quoting: %S" init) + warnings))) ;; Anyone can have an accessor function. This creates a function ;; of the specified name, and also performs a `defsetf' if applicable @@ -223,6 +241,9 @@ This method is obsolete." )) `(progn + ,@(mapcar (lambda (w) + (macroexp-warn-and-return w `(progn ',w) nil 'compile-only)) + warnings) ;; This test must be created right away so we can have self- ;; referencing classes. ei, a class whose slot can contain only ;; pointers to itself. @@ -233,7 +254,7 @@ This method is obsolete." ,@(when eieio-backward-compatibility (let ((f (intern (format "%s-child-p" name)))) - `((defalias ',f ',testsym2) + `((defalias ',f #',testsym2) (make-obsolete ',f ,(format "use (cl-typep ... \\='%s) instead" name) "25.1")))) @@ -269,7 +290,7 @@ This method is obsolete." (lambda (whole) (if (not (stringp (car slots))) whole - (macroexp--warn-and-return + (macroexp-warn-and-return (format "Obsolete name arg %S to constructor %S" (car slots) (car whole)) ;; Keep the name arg, for backward compatibility, @@ -282,23 +303,19 @@ This method is obsolete." ;;; Get/Set slots in an object. ;; (defmacro oref (obj slot) - "Retrieve the value stored in OBJ in the slot named by SLOT. -Slot is the name of the slot when created by `defclass' or the label -created by the :initarg tag." + "Retrieve the value stored in OBJ in the slot named by SLOT." (declare (debug (form symbolp))) `(eieio-oref ,obj (quote ,slot))) -(defalias 'slot-value 'eieio-oref) -(defalias 'set-slot-value 'eieio-oset) +(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. -The default value is the value installed in a class with the :initform -tag. SLOT can be the slot name, or the tag specified by the :initarg -tag in the `defclass' call." +(defmacro oref-default (class slot) + "Get the value of class allocated slot SLOT. +CLASS can also be an object, in which case we use the object's class." (declare (debug (form symbolp))) - `(eieio-oref-default ,obj (quote ,slot))) + `(eieio-oref-default ,class (quote ,slot))) ;;; Handy CLOS macros ;; @@ -418,7 +435,7 @@ If EXTRA, include that in the string returned to represent the symbol." (cl-check-type obj eieio-object) (eieio-class-name (eieio--object-class obj))) (define-obsolete-function-alias - 'object-class-name 'eieio-object-class-name "24.4") + 'object-class-name #'eieio-object-class-name "24.4") (defun eieio-class-parents (class) ;; FIXME: What does "(overload of variable)" mean here? @@ -446,7 +463,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function." (defmacro eieio-class-parent (class) "Return first parent class to CLASS. (overload of variable)." `(car (eieio-class-parents ,class))) -(define-obsolete-function-alias 'class-parent 'eieio-class-parent "24.4") +(define-obsolete-function-alias 'class-parent #'eieio-class-parent "24.4") (defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS." @@ -461,7 +478,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function." ;; class will be checked one layer down (child-of-class-p (eieio--object-class obj) class)) ;; Backwards compatibility -(defalias 'obj-of-class-p 'object-of-class-p) +(defalias 'obj-of-class-p #'object-of-class-p) (defun child-of-class-p (child class) "Return non-nil if CHILD class is a subclass of CLASS." @@ -538,11 +555,11 @@ OBJECT can be an instance or a class." ((eieio-object-p object) (eieio-oref object slot)) ((symbolp object) (eieio-oref-default object slot)) (t (signal 'wrong-type-argument (list 'eieio-object-p object)))) - eieio-unbound)))) + eieio--unbound)))) (defun slot-makeunbound (object slot) "In OBJECT, make SLOT unbound." - (eieio-oset object slot eieio-unbound)) + (eieio-oset object slot eieio--unbound)) (defun slot-exists-p (object-or-class slot) "Return non-nil if OBJECT-OR-CLASS has SLOT." @@ -665,7 +682,7 @@ This class is not stored in the `parent' slot of a class vector." (setq eieio-default-superclass (cl--find-class 'eieio-default-superclass)) (define-obsolete-function-alias 'standard-class - 'eieio-default-superclass "26.1") + #'eieio-default-superclass "26.1") (cl-defgeneric make-instance (class &rest initargs) "Make a new instance of CLASS based on INITARGS. @@ -725,35 +742,37 @@ Called from the constructor routine." "Construct the new object THIS based on SLOTS.") (cl-defmethod initialize-instance ((this eieio-default-superclass) - &optional slots) - "Construct the new object THIS based on SLOTS. -SLOTS is a tagged list where odd numbered elements are tags, and + &optional args) + "Construct the new object THIS based on ARGS. +ARGS is a property list where odd numbered elements are tags, and even numbered elements are the values to store in the tagged slot. If you overload the `initialize-instance', there you will need to call `shared-initialize' yourself, or you can call `call-next-method' to have this constructor called automatically. If these steps are 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. +dynamically set from ARGS." (let* ((this-class (eieio--object-class this)) + (initargs args) (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: - ;; > CL evaluates it if it can, and otherwise, leaves it as - ;; > 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. + ;; For each slot, see if we need to evaluate its initform. (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)) + (slot-name (eieio-slot-descriptor-name slot)) + (initform (cl--slot-descriptor-initform slot))) + (unless (or (when-let ((initarg + (car (rassq slot-name + (eieio--class-initarg-tuples + this-class))))) + (plist-get initargs initarg)) + ;; Those slots whose initform is constant already have + ;; the right value set in the default-object. + (macroexp-const-p initform)) + ;; FIXME: Use `aset' instead of `eieio-oset', relying on that + ;; vector returned by `eieio--class-slots' + ;; should be congruent with the object itself. + (eieio-oset this slot-name (eval initform t)))))) + ;; Shared initialize will parse our args for us. + (shared-initialize this args)) (cl-defgeneric slot-missing (object slot-name _operation &optional _new-value) "Method invoked when an attempt to access a slot in OBJECT fails. @@ -972,13 +991,13 @@ this object." This may create or delete slots, but does not affect the return value of `eq'." (error "EIEIO: `change-class' is unimplemented")) -(define-obsolete-function-alias 'change-class 'eieio-change-class "26.1") +(define-obsolete-function-alias 'change-class #'eieio-change-class "26.1") ;; Hook ourselves into help system for describing classes and methods. ;; FIXME: This is not actually needed any more since we can click on the ;; hyperlink from the constructor's docstring to see the type definition. -(add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) +(add-hook 'help-fns-describe-function-functions #'eieio-help-constructor) (provide 'eieio) -;;; eieio ends here +;;; eieio.el ends here diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 90e075b1102..cec89cf3bc5 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -63,7 +63,7 @@ If this variable is set to 0, no idle time is required." :type 'number) (defcustom eldoc-print-after-edit nil - "If non-nil eldoc info is only shown when editing. + "If non-nil, eldoc info is only shown when editing. Changing the value requires toggling `eldoc-mode'." :type 'boolean) @@ -100,7 +100,7 @@ If the value is a positive number, it is used to calculate a number of logical lines of documentation that ElDoc is allowed to put in the echo area. If a positive integer, the number is used directly, while a float specifies the number of lines as a -proporting of the echo area frame's height. +proportion of the echo area frame's height. If value is the symbol `truncate-sym-name-if-fit' t, the part of the doc string that represents a symbol's name may be truncated @@ -248,7 +248,8 @@ expression point is on." :lighter eldoc-minor-mode-string #'elisp-eldoc-var-docstring nil t) (add-hook 'eldoc-documentation-functions #'elisp-eldoc-funcall nil t) - (setq eldoc-documentation-strategy 'eldoc-documentation-default))) + (setq-local eldoc-documentation-strategy + 'eldoc-documentation-default))) (eldoc-mode +1)) ;;;###autoload @@ -390,12 +391,12 @@ name, inside its arg list, or on any object with some associated information. Each hook function is called with at least one argument CALLBACK, -a function, and decides whether to display a doc short string +a function, and decides whether to display a short doc string about the context around point. - If that decision can be taken quickly, the hook function may - call CALLBACK immediately following the protocol described - below. Alternatively it may ignore CALLBACK entirely and + call CALLBACK immediately, following the protocol described + below. Alternatively, it may ignore CALLBACK entirely and return either the doc string, or nil if there's no doc appropriate for the context. @@ -537,7 +538,7 @@ documentation to potentially appear in the echo are is truncated." (and truncatedp (eq eldoc-echo-area-prefer-doc-buffer 'maybe))) - (get-buffer-window eldoc--doc-buffer))) + (get-buffer-window eldoc--doc-buffer 'visible))) (defun eldoc-display-in-echo-area (docs _interactive) "Display DOCS in echo area. @@ -687,11 +688,11 @@ following values are allowed: - `eldoc-documentation-compose': calls all functions in the special hook and displays all of the resulting doc strings together. Wait for all strings to be ready, and preserve their - relative as specified by the order of functions in the hook; + relative order as specified by the order of functions in the hook; - `eldoc-documentation-compose-eagerly': calls all functions in - the special hook and display as many of the resulting doc - strings as possible, as soon as possibl. Preserving the + the special hook and displays as many of the resulting doc + strings as possible, as soon as possible. Preserves the relative order of doc strings; - `eldoc-documentation-enthusiast': calls all functions in the @@ -792,7 +793,7 @@ function passes responsibility to the functions in Other third-party values of `eldoc-documentation-strategy' should not use `eldoc--make-callback'. They must find some alternate way to produce callbacks to feed to -`eldoc-documentation-function' and should endeavour to display +`eldoc-documentation-functions' and should endeavour to display the docstrings eventually produced, using `eldoc-display-functions'." (let* (;; How many callbacks have been created by the strategy diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index cc2927caf40..c2b026dc822 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -1,7 +1,6 @@ ;;; elp.el --- Emacs Lisp Profiler -*- lexical-binding: t -*- -;; Copyright (C) 1994-1995, 1997-1998, 2001-2021 Free Software -;; Foundation, Inc. +;; Copyright (C) 1994-2021 Free Software Foundation, Inc. ;; Author: Barry A. Warsaw ;; Maintainer: emacs-devel@gnu.org @@ -30,8 +29,8 @@ ;; hacks those functions so that profiling information is recorded ;; whenever they are called. To print out the current results, use ;; M-x elp-results. If you want output to go to standard-output -;; instead of a separate buffer, setq elp-use-standard-output to -;; non-nil. With elp-reset-after-results set to non-nil, profiling +;; instead of a separate buffer, set `elp-use-standard-output' to +;; non-nil. With `elp-reset-after-results' set to non-nil, profiling ;; information will be reset whenever the results are displayed. You ;; can also reset all profiling info at any time with M-x ;; elp-reset-all. @@ -40,12 +39,12 @@ ;; the package follows the GNU coding standard of a common textual ;; prefix. Use M-x elp-instrument-package for this. ;; -;; If you want to sort the results, set elp-sort-by-function to some +;; If you want to sort the results, set `elp-sort-by-function' to some ;; predicate function. The three most obvious choices are predefined: -;; elp-sort-by-call-count, elp-sort-by-average-time, and -;; elp-sort-by-total-time. Also, you can prune from the output, all +;; `elp-sort-by-call-count', `elp-sort-by-average-time', and +;; `elp-sort-by-total-time'. Also, you can prune from the output, all ;; functions that have been called fewer than a given number of times -;; by setting elp-report-limit. +;; by setting `elp-report-limit'. ;; ;; Elp can instrument byte-compiled functions just as easily as ;; interpreted functions, but it cannot instrument macros. However, @@ -95,11 +94,11 @@ ;; Note that there are plenty of factors that could make the times ;; reported unreliable, including the accuracy and granularity of your -;; system clock, and the overhead spent in lisp calculating and +;; system clock, and the overhead spent in Lisp calculating and ;; recording the intervals. I figure the latter is pretty constant, ;; so while the times may not be entirely accurate, I think they'll ;; give you a good feel for the relative amount of work spent in the -;; various lisp routines you are profiling. Note further that times +;; various Lisp routines you are profiling. Note further that times ;; are calculated using wall-clock time, so other system load will ;; affect accuracy too. @@ -404,15 +403,15 @@ original definition, use \\[elp-restore-function] or \\[elp-restore-all]." (defvar elp-et-len nil) (defun elp-sort-by-call-count (vec1 vec2) - ;; sort by highest call count. See `sort'. + "Predicate to sort by highest call count. See `sort'." (>= (aref vec1 0) (aref vec2 0))) (defun elp-sort-by-total-time (vec1 vec2) - ;; sort by highest total time spent in function. See `sort'. + "Predicate to sort by highest total time spent in function. See `sort'." (>= (aref vec1 1) (aref vec2 1))) (defun elp-sort-by-average-time (vec1 vec2) - ;; sort by highest average time spent in function. See `sort'. + "Predicate to sort by highest average time spent in function. See `sort'." (>= (aref vec1 2) (aref vec2 2))) (defsubst elp-pack-number (number width) @@ -470,13 +469,13 @@ original definition, use \\[elp-restore-function] or \\[elp-restore-all]." "Keymap used on the function name column." ) (defun elp-results-jump-to-definition (&optional event) - "Jump to the definition of the function under the point." + "Jump to the definition of the function at point." (interactive (list last-nonmenu-event)) (if event (posn-set-point (event-end event))) (find-function (get-text-property (point) 'elp-symname))) (defun elp-output-insert-symname (symname) - ;; Insert SYMNAME with text properties. + "Insert SYMNAME with text properties." (insert (propertize symname 'elp-symname (intern symname) 'keymap elp-results-symname-map @@ -484,6 +483,10 @@ original definition, use \\[elp-restore-function] or \\[elp-restore-all]." 'face 'link 'help-echo "mouse-2 or RET jumps to definition"))) +(define-derived-mode elp-results-mode special-mode "ELP" + "Mode for ELP results." + :interactive nil) + ;;;###autoload (defun elp-results () "Display current profiling results. @@ -491,11 +494,12 @@ If `elp-reset-after-results' is non-nil, then current profiling information for all instrumented functions is reset after results are displayed." (interactive) - (let ((curbuf (current-buffer)) - (resultsbuf (if elp-recycle-buffers-p - (get-buffer-create elp-results-buffer) - (generate-new-buffer elp-results-buffer)))) - (set-buffer resultsbuf) + (pop-to-buffer + (if elp-recycle-buffers-p + (get-buffer-create elp-results-buffer) + (generate-new-buffer elp-results-buffer))) + (elp-results-mode) + (let ((inhibit-read-only t)) (erase-buffer) ;; get the length of the longest function name being profiled (let* ((longest 0) @@ -566,9 +570,6 @@ displayed." (if elp-sort-by-function (setq resvec (sort resvec elp-sort-by-function))) (mapc 'elp-output-result resvec)) - ;; now pop up results buffer - (set-buffer curbuf) - (pop-to-buffer resultsbuf) ;; copy results to standard-output? (if (or elp-use-standard-output noninteractive) (princ (buffer-substring (point-min) (point-max))) @@ -583,11 +584,10 @@ displayed." ;; continue standard unloading nil) -(cl-defmethod loadhist-unload-element :before :extra "elp" ((x (head defun))) +(cl-defmethod loadhist-unload-element :extra "elp" :before ((x (head defun))) "Un-instrument before unloading a function." (elp-restore-function (cdr x))) - (provide 'elp) ;;; elp.el ends here diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index d058d3dda0b..59ec4d24849 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -98,19 +98,10 @@ To be used in ERT tests. If BODY finishes successfully, the test buffer is killed; if there is an error, the test buffer is kept around on error for further inspection. Its name is derived from the name of the test and the result of NAME-FORM." - (declare (debug ((":name" form) body)) + (declare (debug ((":name" form) def-body)) (indent 1)) `(ert--call-with-test-buffer ,name-form (lambda () ,@body))) -;; We use these `put' forms in addition to the (declare (indent)) in -;; the defmacro form since the `declare' alone does not lead to -;; correct indentation before the .el/.elc file is loaded. -;; Autoloading these `put' forms solves this. -;;;###autoload -(progn - ;; TODO(ohler): Figure out what these mean and make sure they are correct. - (put 'ert-with-test-buffer 'lisp-indent-function 1)) - ;;;###autoload (defun ert-kill-all-test-buffers () "Kill all test buffers that are still live." @@ -376,8 +367,7 @@ different resource directory naming scheme, set the variable name will be trimmed using `string-trim' with arguments `ert-resource-directory-trim-left-regexp' and `ert-resource-directory-trim-right-regexp'." - `(let* ((testfile ,(or (bound-and-true-p byte-compile-current-file) - (and load-in-progress load-file-name) + `(let* ((testfile ,(or (macroexp-file-name) buffer-file-name)) (default-directory (file-name-directory testfile))) (file-truename diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index fdbf95319ff..92acfe7246f 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -60,7 +60,6 @@ (require 'cl-lib) (require 'debug) (require 'backtrace) -(require 'easymenu) (require 'ewoc) (require 'find-func) (require 'pp) @@ -81,15 +80,13 @@ Use nil for no limit (caution: backtrace lines can be very long)." :background "green1") (((class color) (background dark)) :background "green3")) - "Face used for expected results in the ERT results buffer." - :group 'ert) + "Face used for expected results in the ERT results buffer.") (defface ert-test-result-unexpected '((((class color) (background light)) :background "red1") (((class color) (background dark)) :background "red3")) - "Face used for unexpected results in the ERT results buffer." - :group 'ert) + "Face used for unexpected results in the ERT results buffer.") ;;; Copies/reimplementations of cl functions. @@ -196,8 +193,8 @@ it has to be wrapped in `(eval (quote ...))'. \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ [:tags \\='(TAG...)] BODY...)" - (declare (debug (&define :name test - name sexp [&optional stringp] + (declare (debug (&define [&name "test@" symbolp] + sexp [&optional stringp] [&rest keywordp sexp] def-body)) (doc-string 3) (indent 2)) @@ -224,16 +221,6 @@ it has to be wrapped in `(eval (quote ...))'. :body (lambda () ,@body))) ',name)))) -;; We use these `put' forms in addition to the (declare (indent)) in -;; the defmacro form since the `declare' alone does not lead to -;; correct indentation before the .el/.elc file is loaded. -;; Autoloading these `put' forms solves this. -;;;###autoload -(progn - ;; TODO(ohler): Figure out what these mean and make sure they are correct. - (put 'ert-deftest 'lisp-indent-function 2) - (put 'ert-info 'lisp-indent-function 1)) - (defvar ert--find-test-regexp (concat "^\\s-*(ert-deftest" find-function-space-re @@ -274,7 +261,7 @@ DATA is displayed to the user and should state the reason for skipping." It should only be stopped when ran from inside ert--run-test-internal." (when (and (not (symbolp debugger)) ; only run on anonymous debugger (memq error-symbol '(ert-test-failed ert-test-skipped))) - (funcall debugger 'error (list error-symbol data)))) + (funcall debugger 'error (cons error-symbol data)))) (defun ert--special-operator-p (thing) "Return non-nil if THING is a symbol naming a special operator." @@ -290,14 +277,7 @@ It should only be stopped when ran from inside ert--run-test-internal." (let ((form ;; catch macroexpansion errors (condition-case err - (macroexpand-all form - (append (bound-and-true-p - byte-compile-macro-environment) - (cond - ((boundp 'macroexpand-all-environment) - macroexpand-all-environment) - ((boundp 'cl-macro-environment) - cl-macro-environment)))) + (macroexpand-all form macroexpand-all-environment) (error `(signal ',(car err) ',(cdr err)))))) (cond ((or (atom form) (ert--special-operator-p (car form))) @@ -333,12 +313,13 @@ It should only be stopped when ran from inside ert--run-test-internal." (list :form `(,,fn ,@,args)) (unless (eql ,value ',default-value) (list :value ,value)) - (let ((-explainer- - (and (symbolp ',fn-name) - (get ',fn-name 'ert-explainer)))) - (when -explainer- - (list :explanation - (apply -explainer- ,args))))) + (unless (eql ,value ',default-value) + (let ((-explainer- + (and (symbolp ',fn-name) + (get ',fn-name 'ert-explainer)))) + (when -explainer- + (list :explanation + (apply -explainer- ,args)))))) value) ,value)))))))) @@ -1299,11 +1280,28 @@ EXPECTEDP specifies whether the result was expected." (ert-test-quit '("quit" "QUIT"))))) (elt s (if expectedp 0 1)))) +(defun ert-reason-for-test-result (result) + "Return the reason given for RESULT, as a string. + +The reason is the argument given when invoking `ert-fail' or `ert-skip'. +It is output using `prin1' prefixed by two spaces. + +If no reason was given, or for a successful RESULT, return the +empty string." + (let ((reason + (and + (ert-test-result-with-condition-p result) + (cadr (ert-test-result-with-condition-condition result)))) + (print-escape-newlines t) + (print-level 6) + (print-length 10)) + (if reason (format " %S" reason) ""))) + (defun ert--pp-with-indentation-and-newline (object) "Pretty-print OBJECT, indenting it to the current column of point. Ensures a final newline is inserted." (let ((begin (point)) - (pp-escape-newlines nil) + (pp-escape-newlines t) (print-escape-control-characters t)) (pp object (current-buffer)) (unless (bolp) (insert "\n")) @@ -1389,18 +1387,24 @@ Returns the stats object." (cl-loop for test across (ert--stats-tests stats) for result = (ert-test-most-recent-result test) do (when (not (ert-test-result-expected-p test result)) - (message "%9s %S" + (message "%9s %S%s" (ert-string-for-test-result result nil) - (ert-test-name test)))) + (ert-test-name test) + (if (getenv "EMACS_TEST_VERBOSE") + (ert-reason-for-test-result result) + "")))) (message "%s" "")) (unless (zerop skipped) (message "%s skipped results:" skipped) (cl-loop for test across (ert--stats-tests stats) for result = (ert-test-most-recent-result test) do (when (ert-test-result-type-p result :skipped) - (message "%9s %S" + (message "%9s %S%s" (ert-string-for-test-result result nil) - (ert-test-name test)))) + (ert-test-name test) + (if (getenv "EMACS_TEST_VERBOSE") + (ert-reason-for-test-result result) + "")))) (message "%s" ""))))) (test-started ) @@ -1548,7 +1552,7 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (when badtests (message "%d files did not finish:" (length badtests)) (mapc (lambda (l) (message " %s" l)) badtests) - (if (getenv "EMACS_HYDRA_CI") + (if (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) (with-temp-buffer (dolist (f badtests) (erase-buffer) @@ -1563,9 +1567,9 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (message "------------------") (setq tests (sort tests (lambda (x y) (> (car x) (car y))))) (when (< high (length tests)) (setcdr (nthcdr (1- high) tests) nil)) - (message "%s" (mapconcat 'cdr tests "\n"))) - ;; More details on hydra, where the logs are harder to get to. - (when (and (getenv "EMACS_HYDRA_CI") + (message "%s" (mapconcat #'cdr tests "\n"))) + ;; More details on hydra and emba, where the logs are harder to get to. + (when (and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) (not (zerop (+ nunexpected nskipped)))) (message "\nDETAILS") (message "-------") @@ -1653,7 +1657,7 @@ default (if any)." (defun ert-find-test-other-window (test-name) "Find, in another window, the definition of TEST-NAME." - (interactive (list (ert-read-test-name-at-point "Find test definition: "))) + (interactive (list (ert-read-test-name-at-point "Find test definition"))) (find-function-do-it test-name 'ert--test 'switch-to-buffer-other-window)) (defun ert-delete-test (test-name) @@ -2090,7 +2094,7 @@ and how to display message." (ert-run-tests selector listener t))) ;;;###autoload -(defalias 'ert 'ert-run-tests-interactively) +(defalias 'ert #'ert-run-tests-interactively) ;;; Simple view mode for auxiliary information like stack traces or @@ -2103,6 +2107,7 @@ and how to display message." (define-derived-mode ert-results-mode special-mode "ERT-Results" "Major mode for viewing results of ERT test runs." + :interactive nil (setq-local revert-buffer-function (lambda (&rest _) (ert-results-rerun-all-tests)))) @@ -2198,7 +2203,7 @@ To be used in the ERT results buffer." "Move point to the next test. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next "No tests below")) @@ -2206,7 +2211,7 @@ To be used in the ERT results buffer." "Move point to the previous test. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev "No tests above")) @@ -2239,7 +2244,7 @@ user-error is signaled with the message ERROR-MESSAGE." "Find the definition of the test at point in another window. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (let ((name (ert-test-at-point))) (unless name (user-error "No test at point")) @@ -2273,7 +2278,7 @@ To be used in the ERT results buffer." ;; the summary apparently needs to be easily accessible from the ;; error log, and perhaps it would be better to have it in a ;; separate buffer to keep it visible. - (interactive) + (interactive nil ert-results-mode) (let ((ewoc ert--results-ewoc) (progress-bar-begin ert--results-progress-bar-button-begin)) (cond ((ert--results-test-node-or-null-at-point) @@ -2390,7 +2395,7 @@ definition." "Re-run all tests, using the same selector. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (cl-assert (eql major-mode 'ert-results-mode)) (let ((selector (ert--stats-selector ert--results-stats))) (ert-run-tests-interactively selector (buffer-name)))) @@ -2399,7 +2404,7 @@ To be used in the ERT results buffer." "Re-run the test at point. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (cl-destructuring-bind (test redefinition-state) (ert--results-test-at-point-allow-redefinition) (when (null test) @@ -2434,7 +2439,7 @@ To be used in the ERT results buffer." "Re-run the test at point with `ert-debug-on-error' bound to t. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (let ((ert-debug-on-error t)) (ert-results-rerun-test-at-point))) @@ -2442,7 +2447,7 @@ To be used in the ERT results buffer." "Display the backtrace for the test at point. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (let* ((test (ert--results-test-at-point-no-redefinition t)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) @@ -2469,7 +2474,7 @@ To be used in the ERT results buffer." "Display the part of the *Messages* buffer generated during the test at point. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (let* ((test (ert--results-test-at-point-no-redefinition t)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) @@ -2490,7 +2495,7 @@ To be used in the ERT results buffer." "Display the list of `should' forms executed during the test at point. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (let* ((test (ert--results-test-at-point-no-redefinition t)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) @@ -2526,7 +2531,7 @@ To be used in the ERT results buffer." "Toggle how much of the condition to print for the test at point. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (let* ((ewoc ert--results-ewoc) (node (ert--results-test-node-at-point)) (entry (ewoc-data node))) @@ -2538,7 +2543,7 @@ To be used in the ERT results buffer." "Display test timings for the last run. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (let* ((stats ert--results-stats) (buffer (get-buffer-create "*ERT timings*")) (data (cl-loop for test across (ert--stats-tests stats) @@ -2617,7 +2622,7 @@ To be used in the ERT results buffer." "Display the documentation of the test at point. To be used in the ERT results buffer." - (interactive) + (interactive nil ert-results-mode) (ert-describe-test (ert--results-test-at-point-no-redefinition t))) diff --git a/lisp/emacs-lisp/faceup.el b/lisp/emacs-lisp/faceup.el index 6c3931f9829..162c39634ed 100644 --- a/lisp/emacs-lisp/faceup.el +++ b/lisp/emacs-lisp/faceup.el @@ -1170,11 +1170,6 @@ Intended to be called when a file is loaded." ;; File is being evaluated using, for example, `eval-buffer'. default-directory))) - -;; ---------------------------------------------------------------------- -;; The end -;; - (provide 'faceup) ;;; faceup.el ends here diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index c399a682f70..7bc3e6b25ff 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -123,10 +123,18 @@ should insert the feature name." :group 'xref :version "25.1") +(defun find-function--defface (symbol) + (catch 'found + (while (re-search-forward (format find-face-regexp symbol) nil t) + (unless (ppss-comment-or-string-start + (save-excursion (syntax-ppss (match-beginning 0)))) + ;; We're not in a comment or a string. + (throw 'found t))))) + (defvar find-function-regexp-alist '((nil . find-function-regexp) (defvar . find-variable-regexp) - (defface . find-face-regexp) + (defface . find-function--defface) (feature . find-feature-regexp) (defalias . find-alias-regexp)) "Alist mapping definition types into regexp variables. @@ -178,13 +186,18 @@ See the functions `find-function' and `find-variable'." (setq name rel)))) (unless (equal name library) name))) +(defvar comp-eln-to-el-h) + (defun find-library-name (library) "Return the absolute file name of the Emacs Lisp source of LIBRARY. LIBRARY should be a string (the name of the library)." ;; If the library is byte-compiled, try to find a source library by ;; the same name. - (when (string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) + (cond + ((string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) (setq library (replace-match "" t t library))) + ((string-match "\\.eln\\'" library) + (setq library (gethash (file-name-nondirectory library) comp-eln-to-el-h)))) (or (locate-file library (or find-function-source-path load-path) @@ -203,7 +216,7 @@ LIBRARY should be a string (the name of the library)." (or find-function-source-path load-path) load-file-rep-suffixes))))) (find-library--from-load-history library) - (error "Can't find library %s" library))) + (signal 'file-error (list "Can't find library" library)))) (defun find-library--from-load-history (library) ;; In `load-history', the file may be ".elc", ".el", ".el.gz", and @@ -491,7 +504,7 @@ message about the whole chain of aliases." (cons function (cond ((autoloadp def) (nth 1 def)) - ((subrp def) + ((subr-primitive-p def) (if lisp-only (error "%s is a built-in function" function)) (help-C-file-name def 'subr)) diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index 4256bd59584..0e86b923c4a 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -31,6 +31,7 @@ (with-suppressed-warnings ((lexical pi)) (defconst pi float-pi "Obsolete since Emacs-23.3. Use `float-pi' instead.")) +(make-obsolete-variable 'pi 'float-pi "23.3") (internal-make-var-non-special 'pi) (defconst float-e (exp 1) "The value of e (2.7182818...).") diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index e45260c32ac..4ae20ba4205 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -1,6 +1,6 @@ ;;; generator.el --- generators -*- lexical-binding: t -*- -;;; Copyright (C) 2015-2021 Free Software Foundation, Inc. +;; Copyright (C) 2015-2021 Free Software Foundation, Inc. ;; Author: Daniel Colascione <dancol@dancol.org> ;; Keywords: extensions, elisp diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 29f8230e6b8..d6272a52469 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -135,7 +135,7 @@ The returned value will then be an Elisp expression that first evaluates all the parts of PLACE that can be evaluated and then runs E. \(fn (GETTER SETTER) PLACE &rest BODY)" - (declare (indent 2) (debug (sexp form body))) + (declare (indent 2) (debug (sexp form def-body))) `(gv-get ,place (lambda ,vars ,@body))) ;; Different ways to declare a generalized variable. @@ -187,6 +187,13 @@ arguments as NAME. DO is a function as defined in `gv-get'." (push (list 'gv-setter #'gv--setter-defun-declaration) defun-declarations-alist)) +;;;###autoload +(let ((spec (get 'compiler-macro 'edebug-declaration-spec))) + ;; It so happens that it's the same spec for gv-* as for compiler-macros. + ;; '(&or symbolp ("lambda" &define lambda-list lambda-doc def-body)) + (put 'gv-expander 'edebug-declaration-spec spec) + (put 'gv-setter 'edebug-declaration-spec spec)) + ;; (defmacro gv-define-expand (name expander) ;; "Use EXPANDER to handle NAME as a generalized var. ;; NAME is a symbol: the name of a function, macro, or special form. @@ -224,7 +231,8 @@ The first arg in ARGLIST (the one that receives VAL) receives an expression which can do arbitrary things, whereas the other arguments are all guaranteed to be pure and copyable. Example use: (gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))" - (declare (indent 2) (debug (&define name :name gv-setter sexp def-body))) + (declare (indent 2) + (debug (&define [&name symbolp "@gv-setter"] sexp def-body))) `(gv-define-expander ,name (lambda (do &rest args) (declare-function @@ -307,7 +315,7 @@ The return value is the last VAL in the list. ;; Autoload this `put' since a user might use C-u C-M-x on an expression ;; containing a non-trivial `push' even before gv.el was loaded. ;;;###autoload -(put 'gv-place 'edebug-form-spec 'edebug-match-form) +(def-edebug-elem-spec 'gv-place '(form)) ;; CL did the equivalent of: ;;(gv-define-macroexpand edebug-after (lambda (before index place) place)) @@ -316,8 +324,7 @@ The return value is the last VAL in the list. (gv-letplace (getter setter) place (funcall do `(edebug-after ,before ,index ,getter) (lambda (store) - `(progn (edebug-after ,before ,index ,getter) - ,(funcall setter store))))))) + `(edebug-after ,before ,index ,(funcall setter store))))))) ;;; The common generalized variables. @@ -585,7 +592,7 @@ binding mode." ;; dynamic binding mode as well. (eq (car-safe code) 'cons)) code - (macroexp--warn-and-return + (macroexp-warn-and-return "Use of gv-ref probably requires lexical-binding" code)))) @@ -607,5 +614,105 @@ REF must have been previously obtained with `gv-ref'." ;; (,(nth 1 vars) (v) (funcall ',setter v))) ;; ,@body))) +;;; Generalized variables. + +;; Some Emacs-related place types. +(gv-define-simple-setter buffer-file-name set-visited-file-name t) +(gv-define-setter buffer-modified-p (flag &optional buf) + (macroexp-let2 nil buffer `(or ,buf (current-buffer)) + `(with-current-buffer ,buffer + (set-buffer-modified-p ,flag)))) +(gv-define-simple-setter buffer-name rename-buffer t) +(gv-define-setter buffer-string (store) + `(insert (prog1 ,store (erase-buffer)))) +(gv-define-simple-setter buffer-substring cl--set-buffer-substring) +(gv-define-simple-setter current-buffer set-buffer) +(gv-define-simple-setter current-column move-to-column t) +(gv-define-simple-setter current-global-map use-global-map t) +(gv-define-setter current-input-mode (store) + `(progn (apply #'set-input-mode ,store) ,store)) +(gv-define-simple-setter current-local-map use-local-map t) +(gv-define-simple-setter current-window-configuration + set-window-configuration t) +(gv-define-simple-setter default-file-modes set-default-file-modes t) +(gv-define-simple-setter documentation-property put) +(gv-define-setter face-background (x f &optional s) + `(set-face-background ,f ,x ,s)) +(gv-define-setter face-background-pixmap (x f &optional s) + `(set-face-background-pixmap ,f ,x ,s)) +(gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s)) +(gv-define-setter face-foreground (x f &optional s) + `(set-face-foreground ,f ,x ,s)) +(gv-define-setter face-underline-p (x f &optional s) + `(set-face-underline ,f ,x ,s)) +(gv-define-simple-setter file-modes set-file-modes t) +(gv-define-setter frame-height (x &optional frame) + `(set-frame-height (or ,frame (selected-frame)) ,x)) +(gv-define-simple-setter frame-parameters modify-frame-parameters t) +(gv-define-simple-setter frame-visible-p cl--set-frame-visible-p) +(gv-define-setter frame-width (x &optional frame) + `(set-frame-width (or ,frame (selected-frame)) ,x)) +(gv-define-simple-setter getenv setenv t) +(gv-define-simple-setter get-register set-register) +(gv-define-simple-setter global-key-binding global-set-key) +(gv-define-simple-setter local-key-binding local-set-key) +(gv-define-simple-setter mark set-mark t) +(gv-define-simple-setter mark-marker set-mark t) +(gv-define-simple-setter marker-position set-marker t) +(gv-define-setter mouse-position (store scr) + `(set-mouse-position ,scr (car ,store) (cadr ,store) + (cddr ,store))) +(gv-define-simple-setter point goto-char) +(gv-define-simple-setter point-marker goto-char t) +(gv-define-setter point-max (store) + `(progn (narrow-to-region (point-min) ,store) ,store)) +(gv-define-setter point-min (store) + `(progn (narrow-to-region ,store (point-max)) ,store)) +(gv-define-setter read-mouse-position (store scr) + `(set-mouse-position ,scr (car ,store) (cdr ,store))) +(gv-define-simple-setter screen-height set-screen-height t) +(gv-define-simple-setter screen-width set-screen-width t) +(gv-define-simple-setter selected-window select-window) +(gv-define-simple-setter selected-screen select-screen) +(gv-define-simple-setter selected-frame select-frame) +(gv-define-simple-setter standard-case-table set-standard-case-table) +(gv-define-simple-setter syntax-table set-syntax-table) +(gv-define-simple-setter visited-file-modtime set-visited-file-modtime t) +(gv-define-setter window-height (store) + `(progn (enlarge-window (- ,store (window-height))) ,store)) +(gv-define-setter window-width (store) + `(progn (enlarge-window (- ,store (window-width)) t) ,store)) +(gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t) + +;; More complex setf-methods. + +;; This is a hack that allows (setf (eq a 7) B) to mean either +;; (setq a 7) or (setq a nil) depending on whether B is nil or not. +;; This is useful when you have control over the PLACE but not over +;; the VALUE, as is the case in define-minor-mode's :variable. +;; It turned out that :variable needed more flexibility anyway, so +;; this doesn't seem too useful now. +(gv-define-expander eq + (lambda (do place val) + (gv-letplace (getter setter) place + (macroexp-let2 nil val val + (funcall do `(eq ,getter ,val) + (lambda (v) + `(cond + (,v ,(funcall setter val)) + ((eq ,getter ,val) ,(funcall setter `(not ,val)))))))))) + +(gv-define-expander substring + (lambda (do place from &optional to) + (gv-letplace (getter setter) place + (macroexp-let2* nil ((start from) (end to)) + (funcall do `(substring ,getter ,start ,end) + (lambda (v) + (macroexp-let2 nil v v + `(progn + ,(funcall setter `(cl--set-substring + ,getter ,start ,end ,v)) + ,v)))))))) + (provide 'gv) ;;; gv.el ends here diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el index d6106fe35d0..36d71a8c04d 100644 --- a/lisp/emacs-lisp/inline.el +++ b/lisp/emacs-lisp/inline.el @@ -262,7 +262,7 @@ See Info node `(elisp)Defining Functions' for more details." '(throw 'inline--just-use ;; FIXME: This would inf-loop by calling us right back when ;; macroexpand-all recurses to expand inline--form. - ;; (macroexp--warn-and-return (format ,@args) + ;; (macroexp-warn-and-return (format ,@args) ;; inline--form) inline--form)) diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index adb9cb2372c..df14a5cd499 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -109,13 +109,10 @@ ;; * Footer line --- marks end-of-file so it can be distinguished from ;; an expanded formfeed or the results of truncation. -;;; Change Log: - -;; Tue Jul 14 23:44:17 1992 ESR -;; * Created. - ;;; Code: +(require 'mail-parse) + ;;; Variables: (defgroup lisp-mnt nil @@ -362,18 +359,11 @@ Return argument is of the form (\"HOLDER\" \"YEAR1\" ... \"YEARN\")" summary))))) (defun lm-crack-address (x) - "Split up an email address X into full name and real email address. -The value is a cons of the form (FULLNAME . ADDRESS)." - (cond ((string-match "\\(.+\\) [(<]\\(\\S-+@\\S-+\\)[>)]" x) - (cons (match-string 1 x) - (match-string 2 x))) - ((string-match "\\(\\S-+@\\S-+\\) [(<]\\(.*\\)[>)]" x) - (cons (match-string 2 x) - (match-string 1 x))) - ((string-match "\\S-+@\\S-+" x) - (cons nil x)) - (t - (cons x nil)))) + "Split up email address(es) X into full name and real email address. +The value is a list of elements of the form (FULLNAME . ADDRESS)." + (mapcar (lambda (elem) + (cons (cdr elem) (car elem))) + (mail-header-parse-addresses-lax x))) (defun lm-authors (&optional file) "Return the author list of file FILE, or current buffer if FILE is nil. @@ -381,16 +371,24 @@ Each element of the list is a cons; the car is the full name, the cdr is an email address." (lm-with-file file (let ((authorlist (lm-header-multiline "author"))) - (mapcar #'lm-crack-address authorlist)))) + (mapcan #'lm-crack-address authorlist)))) + +(defun lm-maintainers (&optional file) + "Return the maintainer list of file FILE, or current buffer if FILE is nil. +If the maintainers are unspecified, then return the authors. +Each element of the list is a cons; the car is the full name, +the cdr is an email address." + (lm-with-file file + (mapcan #'lm-crack-address + (or (lm-header-multiline "maintainer") + (lm-header-multiline "author"))))) (defun lm-maintainer (&optional file) "Return the maintainer of file FILE, or current buffer if FILE is nil. +If the maintainer is unspecified, then return the author. The return value has the form (NAME . ADDRESS)." - (lm-with-file file - (let ((maint (lm-header "maintainer"))) - (if maint - (lm-crack-address maint) - (car (lm-authors)))))) + (declare (obsolete lm-maintainers "28.1")) + (car (lm-maintainers file))) (defun lm-creation-date (&optional file) "Return the created date given in file FILE, or current buffer if FILE is nil." @@ -455,7 +453,7 @@ each line." "Return list of keywords given in file FILE." (let ((keywords (lm-keywords file))) (if keywords - (if (string-match-p "," keywords) + (if (string-search "," keywords) (split-string keywords ",[ \t\n]*" t "[ ]+") (split-string keywords "[ \t\n]+" t "[ ]+"))))) @@ -495,7 +493,7 @@ absent, return nil." (concat "^;;;[[:blank:]]*\\(" lm-commentary-header "\\):[[:blank:]\n]*") - "^;;[[:blank:]]*" ; double semicolon prefix + "^;;[[:blank:]]?" ; double semicolon prefix "[[:blank:]\n]*\\'") ; trailing new-lines "" (buffer-substring-no-properties start (lm-commentary-end)))))))) @@ -550,7 +548,7 @@ copyright notice is allowed." "Can't find package name") ((not (lm-authors)) "`Author:' tag missing") - ((not (lm-maintainer)) + ((not (lm-maintainers)) "`Maintainer:' tag missing") ((not (lm-summary)) "Can't find the one-line summary description") @@ -618,7 +616,7 @@ Prompts for bug subject TOPIC. Leaves you in a mail buffer." (interactive "sBug Subject: ") (require 'emacsbug) (let ((package (lm-get-package-name)) - (addr (lm-maintainer)) + (addr (car (lm-maintainers))) (version (lm-version))) (compose-mail (if addr (concat (car addr) " <" (cdr addr) ">") diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index f5ce107185a..51fb88502ab 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -62,9 +62,6 @@ (modify-syntax-entry ?\t " " table) (modify-syntax-entry ?\f " " table) (modify-syntax-entry ?\n "> " table) - ;; This is probably obsolete since nowadays such features use overlays. - ;; ;; Give CR the same syntax as newline, for selective-display. - ;; (modify-syntax-entry ?\^m "> " table) (modify-syntax-entry ?\; "< " table) (modify-syntax-entry ?` "' " table) (modify-syntax-entry ?' "' " table) @@ -530,7 +527,7 @@ This will generate compile-time constants from BINDINGS." ;; This is too general -- rms. ;; A user complained that he has functions whose names start with `do' ;; and that they get the wrong color. - ;; That user has violated the http://www.cliki.net/Naming+conventions: + ;; That user has violated the https://www.cliki.net/Naming+conventions: ;; CL (but not EL!) `with-' (context) and `do-' (iteration) (,(concat "(\\(\\(do-\\|with-\\)" lisp-mode-symbol-regexp "\\)") (1 font-lock-keyword-face)) @@ -685,10 +682,16 @@ font-lock keywords will not be case sensitive." (defun lisp-outline-level () "Lisp mode `outline-level' function." + ;; Expects outline-regexp is ";;;\\(;* [^ \t\n]\\|###autoload\\)\\|(" + ;; and point is at the beginning of a matching line. (let ((len (- (match-end 0) (match-beginning 0)))) - (if (looking-at "(\\|;;;###autoload") - 1000 - len))) + (cond ((looking-at "(\\|;;;###autoload") + 1000) + ((looking-at ";;\\(;+\\) ") + (- (match-end 1) (match-beginning 1))) + ;; Above should match everything but just in case. + (t + len)))) (defun lisp-current-defun-name () "Return the name of the defun at point, or nil." @@ -743,27 +746,26 @@ font-lock keywords will not be case sensitive." ;;; Generic Lisp mode. (defvar lisp-mode-map - (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap "Lisp"))) + (let ((map (make-sparse-keymap))) (set-keymap-parent map lisp-mode-shared-map) (define-key map "\e\C-x" 'lisp-eval-defun) (define-key map "\C-c\C-z" 'run-lisp) - (bindings--define-key map [menu-bar lisp] (cons "Lisp" menu-map)) - (bindings--define-key menu-map [run-lisp] - '(menu-item "Run inferior Lisp" run-lisp - :help "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'")) - (bindings--define-key menu-map [ev-def] - '(menu-item "Eval defun" lisp-eval-defun - :help "Send the current defun to the Lisp process made by M-x run-lisp")) - (bindings--define-key menu-map [ind-sexp] - '(menu-item "Indent sexp" indent-sexp - :help "Indent each line of the list starting just after point")) map) "Keymap for ordinary Lisp mode. All commands in `lisp-mode-shared-map' are inherited by this map.") +(easy-menu-define lisp-mode-menu lisp-mode-map + "Menu for ordinary Lisp mode." + '("Lisp" + ["Indent sexp" indent-sexp + :help "Indent each line of the list starting just after point"] + ["Eval defun" lisp-eval-defun + :help "Send the current defun to the Lisp process made by M-x run-lisp"] + ["Run inferior Lisp" run-lisp + :help "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'"])) + (define-derived-mode lisp-mode lisp-data-mode "Lisp" - "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp. + "Major mode for editing programs in Common Lisp and other similar Lisps. Commands: Delete converts tabs to spaces as it moves back. Blank lines separate paragraphs. Semicolons start comments. @@ -1375,7 +1377,8 @@ and initial semicolons." fill-column))) (save-restriction (save-excursion - (let ((ppss (syntax-ppss))) + (let ((ppss (syntax-ppss)) + (start (point))) ;; If we're in a string, then narrow (roughly) to that ;; string before filling. This avoids filling Lisp ;; statements that follow the string. @@ -1390,6 +1393,8 @@ and initial semicolons." t)) (narrow-to-region (ppss-comment-or-string-start ppss) (point)))) + ;; Move back to where we were. + (goto-char start) (fill-paragraph justify))))) ;; Never return nil. t)) diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 46ca94869c7..2495277ba23 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -503,7 +503,7 @@ If ARG is positive, that's the end of the buffer. Otherwise, that's the beginning of the buffer." (if (> arg 0) (point-max) (point-min))) -(defun end-of-defun (&optional arg) +(defun end-of-defun (&optional arg interactive) "Move forward to next end of defun. With argument, do it that many times. Negative argument -N means move back to Nth preceding end of defun. @@ -513,129 +513,145 @@ matches the open-parenthesis that starts a defun; see function `beginning-of-defun'. If variable `end-of-defun-function' is non-nil, its value -is called as a function to find the defun's end." - (interactive "^p") - (or (not (eq this-command 'end-of-defun)) - (eq last-command 'end-of-defun) - (and transient-mark-mode mark-active) - (push-mark)) - (if (or (null arg) (= arg 0)) (setq arg 1)) - (let ((pos (point)) - (beg (progn (end-of-line 1) (beginning-of-defun-raw 1) (point))) - (skip (lambda () - ;; When comparing point against pos, we want to consider that if - ;; point was right after the end of the function, it's still - ;; considered as "in that function". - ;; E.g. `eval-defun' from right after the last close-paren. - (unless (bolp) - (skip-chars-forward " \t") - (if (looking-at "\\s<\\|\n") - (forward-line 1)))))) - (funcall end-of-defun-function) - (when (<= arg 1) - (funcall skip)) - (cond - ((> arg 0) - ;; Moving forward. - (if (> (point) pos) - ;; We already moved forward by one because we started from - ;; within a function. - (setq arg (1- arg)) - ;; We started from after the end of the previous function. - (goto-char pos)) - (unless (zerop arg) - (beginning-of-defun-raw (- arg)) - (funcall end-of-defun-function))) - ((< arg 0) - ;; Moving backward. - (if (< (point) pos) - ;; We already moved backward because we started from between - ;; two functions. - (setq arg (1+ arg)) - ;; We started from inside a function. - (goto-char beg)) - (unless (zerop arg) +is called as a function to find the defun's end. + +If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." + (interactive "^p\nd") + (if interactive + (condition-case e + (end-of-defun arg nil) + (scan-error (user-error (cadr e)))) + (or (not (eq this-command 'end-of-defun)) + (eq last-command 'end-of-defun) + (and transient-mark-mode mark-active) + (push-mark)) + (if (or (null arg) (= arg 0)) (setq arg 1)) + (let ((pos (point)) + (beg (progn (end-of-line 1) (beginning-of-defun-raw 1) (point))) + (skip (lambda () + ;; When comparing point against pos, we want to consider that + ;; if point was right after the end of the function, it's + ;; still considered as "in that function". + ;; E.g. `eval-defun' from right after the last close-paren. + (unless (bolp) + (skip-chars-forward " \t") + (if (looking-at "\\s<\\|\n") + (forward-line 1)))))) + (funcall end-of-defun-function) + (when (<= arg 1) + (funcall skip)) + (cond + ((> arg 0) + ;; Moving forward. + (if (> (point) pos) + ;; We already moved forward by one because we started from + ;; within a function. + (setq arg (1- arg)) + ;; We started from after the end of the previous function. + (goto-char pos)) + (unless (zerop arg) + (beginning-of-defun-raw (- arg)) + (funcall end-of-defun-function))) + ((< arg 0) + ;; Moving backward. + (if (< (point) pos) + ;; We already moved backward because we started from between + ;; two functions. + (setq arg (1+ arg)) + ;; We started from inside a function. + (goto-char beg)) + (unless (zerop arg) + (beginning-of-defun-raw (- arg)) + (setq beg (point)) + (funcall end-of-defun-function)))) + (funcall skip) + (while (and (< arg 0) (>= (point) pos)) + ;; We intended to move backward, but this ended up not doing so: + ;; Try harder! + (goto-char beg) (beginning-of-defun-raw (- arg)) - (setq beg (point)) - (funcall end-of-defun-function)))) - (funcall skip) - (while (and (< arg 0) (>= (point) pos)) - ;; We intended to move backward, but this ended up not doing so: - ;; Try harder! - (goto-char beg) - (beginning-of-defun-raw (- arg)) - (if (>= (point) beg) - (setq arg 0) - (setq beg (point)) - (funcall end-of-defun-function) - (funcall skip))))) - -(defun mark-defun (&optional arg) + (if (>= (point) beg) + (setq arg 0) + (setq beg (point)) + (funcall end-of-defun-function) + (funcall skip)))))) + +(defun mark-defun (&optional arg interactive) "Put mark at end of this defun, point at beginning. The defun marked is the one that contains point or follows point. With positive ARG, mark this and that many next defuns; with negative ARG, change the direction of marking. If the mark is active, it marks the next or previous defun(s) after -the one(s) already marked." - (interactive "p") - (setq arg (or arg 1)) - ;; There is no `mark-defun-back' function - see - ;; https://lists.gnu.org/r/bug-gnu-emacs/2016-11/msg00079.html - ;; for explanation - (when (eq last-command 'mark-defun-back) - (setq arg (- arg))) - (when (< arg 0) - (setq this-command 'mark-defun-back)) - (cond ((use-region-p) - (if (>= arg 0) - (set-mark - (save-excursion - (goto-char (mark)) - ;; change the dotimes below to (end-of-defun arg) once bug #24427 is fixed - (dotimes (_ignore arg) - (end-of-defun)) - (point))) - (beginning-of-defun-comments (- arg)))) - (t - (let ((opoint (point)) - beg end) - (push-mark opoint) - ;; Try first in this order for the sake of languages with nested - ;; functions where several can end at the same place as with the - ;; offside rule, e.g. Python. - (beginning-of-defun-comments) - (setq beg (point)) - (end-of-defun) - (setq end (point)) - (when (or (and (<= (point) opoint) - (> arg 0)) - (= beg (point-min))) ; we were before the first defun! - ;; beginning-of-defun moved back one defun so we got the wrong - ;; one. If ARG < 0, however, we actually want to go back. - (goto-char opoint) - (end-of-defun) - (setq end (point)) - (beginning-of-defun-comments) - (setq beg (point))) - (goto-char beg) - (cond ((> arg 0) - ;; change the dotimes below to (end-of-defun arg) once bug #24427 is fixed +the one(s) already marked. + +If INTERACTIVE is non-nil, as it is interactively, +report errors as appropriate for this kind of usage." + (interactive "p\nd") + (if interactive + (condition-case e + (mark-defun arg nil) + (scan-error (user-error (cadr e)))) + (setq arg (or arg 1)) + ;; There is no `mark-defun-back' function - see + ;; https://lists.gnu.org/r/bug-gnu-emacs/2016-11/msg00079.html + ;; for explanation + (when (eq last-command 'mark-defun-back) + (setq arg (- arg))) + (when (< arg 0) + (setq this-command 'mark-defun-back)) + (cond ((use-region-p) + (if (>= arg 0) + (set-mark + (save-excursion + (goto-char (mark)) + ;; change the dotimes below to (end-of-defun arg) + ;; once bug #24427 is fixed (dotimes (_ignore arg) (end-of-defun)) - (setq end (point)) - (push-mark end nil t) - (goto-char beg)) - (t - (goto-char beg) - (unless (= arg -1) ; beginning-of-defun behaves - ; strange with zero arg - see - ; https://lists.gnu.org/r/bug-gnu-emacs/2017-02/msg00196.html - (beginning-of-defun (1- (- arg)))) - (push-mark end nil t)))))) - (skip-chars-backward "[:space:]\n") - (unless (bobp) - (forward-line 1))) + (point))) + (beginning-of-defun-comments (- arg)))) + (t + (let ((opoint (point)) + beg end) + (push-mark opoint) + ;; Try first in this order for the sake of languages with nested + ;; functions where several can end at the same place as with the + ;; offside rule, e.g. Python. + (beginning-of-defun-comments) + (setq beg (point)) + (end-of-defun) + (setq end (point)) + (when (or (and (<= (point) opoint) + (> arg 0)) + (= beg (point-min))) ; we were before the first defun! + ;; beginning-of-defun moved back one defun so we got the wrong + ;; one. If ARG < 0, however, we actually want to go back. + (goto-char opoint) + (end-of-defun) + (setq end (point)) + (beginning-of-defun-comments) + (setq beg (point))) + (goto-char beg) + (cond ((> arg 0) + ;; change the dotimes below to (end-of-defun arg) + ;; once bug #24427 is fixed + (dotimes (_ignore arg) + (end-of-defun)) + (setq end (point)) + (push-mark end nil t) + (goto-char beg)) + (t + (goto-char beg) + (unless (= arg -1) + ;; beginning-of-defun behaves strange with zero arg - see + ;; lists.gnu.org/r/bug-gnu-emacs/2017-02/msg00196.html + (beginning-of-defun (1- (- arg)))) + (push-mark end nil t)))))) + (skip-chars-backward "[:space:]\n") + (unless (bobp) + (forward-line 1)))) (defvar narrow-to-defun-include-comments nil "If non-nil, `narrow-to-defun' will also show comments preceding the defun.") diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index e842222b7c3..61c1ea490f0 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -112,7 +112,7 @@ and also to avoid outputting the warning during normal execution." (funcall (eval (cadr form))) (byte-compile-constant nil))) -(defun macroexp--compiling-p () +(defun macroexp-compiling-p () "Return non-nil if we're macroexpanding for the compiler." ;; FIXME: ¡¡Major Ugly Hack!! To determine whether the output of this ;; macro-expansion will be processed by the byte-compiler, we check @@ -120,30 +120,55 @@ and also to avoid outputting the warning during normal execution." (member '(declare-function . byte-compile-macroexpand-declare-function) macroexpand-all-environment)) +(defun macroexp-file-name () + "Return the name of the file from which the code comes. +Returns nil when we do not know. +A non-nil result is expected to be reliable when called from a macro in order +to find the file in which the macro's call was found, and it should be +reliable as well when used at the top-level of a file. +Other uses risk returning non-nil value that point to the wrong file." + ;; `eval-buffer' binds `current-load-list' but not `load-file-name', + ;; so prefer using it over using `load-file-name'. + (let ((file (car (last current-load-list)))) + (or (if (stringp file) file) + (bound-and-true-p byte-compile-current-file)))) + (defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) -(defun macroexp--warn-and-return (msg form &optional compile-only) - (let ((when-compiled (lambda () (byte-compile-warn "%s" msg)))) - (cond - ((null msg) form) - ((macroexp--compiling-p) - (if (and (consp form) (gethash form macroexp--warned)) - ;; Already wrapped this exp with a warning: avoid inf-looping - ;; where we keep adding the same warning onto `form' because - ;; macroexpand-all gets right back to macroexpanding `form'. - form - (puthash form form macroexp--warned) - `(progn - (macroexp--funcall-if-compiled ',when-compiled) - ,form))) - (t - (unless compile-only - (message "%sWarning: %s" - (if (stringp load-file-name) - (concat (file-relative-name load-file-name) ": ") - "") - msg)) - form)))) +(defun macroexp--warn-wrap (msg form category) + (let ((when-compiled (lambda () + (when (byte-compile-warning-enabled-p category) + (byte-compile-warn "%s" msg))))) + `(progn + (macroexp--funcall-if-compiled ',when-compiled) + ,form))) + +(define-obsolete-function-alias 'macroexp--warn-and-return + #'macroexp-warn-and-return "28.1") +(defun macroexp-warn-and-return (msg form &optional category compile-only) + "Return code equivalent to FORM labeled with warning MSG. +CATEGORY is the category of the warning, like the categories that +can appear in `byte-compile-warnings'. +COMPILE-ONLY non-nil means no warning should be emitted if the code +is executed without being compiled first." + (cond + ((null msg) form) + ((macroexp-compiling-p) + (if (and (consp form) (gethash form macroexp--warned)) + ;; Already wrapped this exp with a warning: avoid inf-looping + ;; where we keep adding the same warning onto `form' because + ;; macroexpand-all gets right back to macroexpanding `form'. + form + (puthash form form macroexp--warned) + (macroexp--warn-wrap msg form category))) + (t + (unless compile-only + (message "%sWarning: %s" + (if (stringp load-file-name) + (concat (file-relative-name load-file-name) ": ") + "") + msg)) + form))) (defun macroexp--obsolete-warning (fun obsolescence-data type) (let ((instead (car obsolescence-data)) @@ -187,19 +212,80 @@ and also to avoid outputting the warning during normal execution." (if (and (not (eq form new-form)) ;It was a macro call. (car-safe form) (symbolp (car form)) - (get (car form) 'byte-obsolete-info) - (or (not (fboundp 'byte-compile-warning-enabled-p)) - (byte-compile-warning-enabled-p 'obsolete (car form)))) + (get (car form) 'byte-obsolete-info)) (let* ((fun (car form)) (obsolete (get fun 'byte-obsolete-info))) - (macroexp--warn-and-return + (macroexp-warn-and-return (macroexp--obsolete-warning fun obsolete (if (symbolp (symbol-function fun)) "alias" "macro")) - new-form)) + new-form 'obsolete)) new-form))) +(defun macroexp--unfold-lambda (form &optional name) + ;; In lexical-binding mode, let and functions don't bind vars in the same way + ;; (let obey special-variable-p, but functions don't). But luckily, this + ;; 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)) + (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)) + (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 + (macroexp-warn-and-return + (format (if (eq values 'too-few) + "attempt to open-code `%s' with too few arguments" + "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))) + + (if bindings + `(let ,(nreverse bindings) . ,body) + (macroexp-progn body))))) + (defun macroexp--expand-all (form) "Expand all macros in FORM. This is an internal version of `macroexpand-all'. @@ -213,10 +299,12 @@ Assumes the caller has bound `macroexpand-all-environment'." macroexpand-all-environment) ;; Normal form; get its expansion, and then expand arguments. (setq form (macroexp-macroexpand form macroexpand-all-environment)) + ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when + ;; I tried it, it broke the bootstrap :-( (pcase form (`(cond . ,clauses) (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) - (`(condition-case . ,(or `(,err ,body . ,handlers) dontcare)) + (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) (macroexp--cons 'condition-case (macroexp--cons err @@ -233,51 +321,35 @@ Assumes the caller has bound `macroexpand-all-environment'." (cdr form)) form)) (`(,(or 'function 'quote) . ,_) form) - (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) dontcare)) - (macroexp--cons fun - (macroexp--cons (macroexp--all-clauses bindings 1) - (macroexp--all-forms body) - (cdr form)) - form)) + (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) + pcase--dontcare)) + (macroexp--cons + fun + (macroexp--cons + (macroexp--all-clauses bindings 1) + (if (null body) + (macroexp-unprogn + (macroexp-warn-and-return + (format "Empty %s body" fun) + nil nil 'compile-only)) + (macroexp--all-forms body)) + (cdr form)) + form)) (`(,(and fun `(lambda . ,_)) . ,args) ;; Embedded lambda in function position. ;; If the byte-optimizer is loaded, try to unfold this, ;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the optimizer ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the ;; creation of a closure, thus resulting in much better code. - (let ((newform (if (not (fboundp 'byte-compile-unfold-lambda)) - 'macroexp--not-unfolded - ;; Don't unfold if byte-opt is not yet loaded. - (byte-compile-unfold-lambda form)))) - (if (or (eq newform 'macroexp--not-unfolded) - (eq newform form)) + (let ((newform (macroexp--unfold-lambda form))) + (if (eq newform form) ;; Unfolding failed for some reason, avoid infinite recursion. (macroexp--cons (macroexp--all-forms fun 2) (macroexp--all-forms args) form) (macroexp--expand-all newform)))) - ;; The following few cases are for normal function calls that - ;; are known to funcall one of their arguments. The byte - ;; compiler has traditionally handled these functions specially - ;; by treating a lambda expression quoted by `quote' as if it - ;; were quoted by `function'. We make the same transformation - ;; here, so that any code that cares about the difference will - ;; see the same transformation. - ;; First arg is a function: - (`(,(and fun (or 'funcall 'apply 'mapcar 'mapatoms 'mapconcat 'mapc)) - ',(and f `(lambda . ,_)) . ,args) - (macroexp--warn-and-return - (format "%s quoted with ' rather than with #'" - (list 'lambda (nth 1 f) '...)) - (macroexp--expand-all `(,fun #',f . ,args)))) - ;; Second arg is a function: - (`(,(and fun (or 'sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args) - (macroexp--warn-and-return - (format "%s quoted with ' rather than with #'" - (list 'lambda (nth 1 f) '...)) - (macroexp--expand-all `(,fun ,arg1 #',f . ,args)))) - (`(funcall ,exp . ,args) + (`(funcall . ,(or `(,exp . ,args) pcase--dontcare)) (let ((eexp (macroexp--expand-all exp)) (eargs (macroexp--all-forms args))) ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' @@ -286,10 +358,22 @@ Assumes the caller has bound `macroexpand-all-environment'." (`#',f (macroexp--expand-all `(,f . ,eargs))) (_ `(funcall ,eexp . ,eargs))))) (`(,func . ,_) - ;; Macro expand compiler macros. This cannot be delayed to - ;; byte-optimize-form because the output of the compiler-macro can - ;; use macros. - (let ((handler (function-get func 'compiler-macro))) + (let ((handler (function-get func 'compiler-macro)) + (funargs (function-get func 'funarg-positions))) + ;; Check functions quoted with ' rather than with #' + (dolist (funarg funargs) + (let ((arg (nth funarg form))) + (when (and (eq 'quote (car-safe arg)) + (eq 'lambda (car-safe (cadr arg)))) + (setcar (nthcdr funarg form) + (macroexp-warn-and-return + (format "%S quoted with ' rather than with #'" + (let ((f (cadr arg))) + (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) + arg))))) + ;; Macro expand compiler macros. This cannot be delayed to + ;; byte-optimize-form because the output of the compiler-macro can + ;; use macros. (if (null handler) ;; No compiler macro. We just expand each argument (for ;; setq/setq-default this works alright because the variable names @@ -315,6 +399,19 @@ Assumes the caller has bound `macroexpand-all-environment'." (_ form)))) +;; Record which arguments expect functions, so we can warn when those +;; are accidentally quoted with ' rather than with #' +(dolist (f '( funcall apply mapcar mapatoms mapconcat mapc cl-mapcar maphash + map-char-table map-keymap map-keymap-internal)) + (put f 'funarg-positions '(1))) +(dolist (f '( add-hook remove-hook advice-remove advice--remove-function + defalias fset global-set-key run-after-idle-timeout + set-process-filter set-process-sentinel sort)) + (put f 'funarg-positions '(2))) +(dolist (f '( advice-add define-key + run-at-time run-with-idle-timer run-with-timer )) + (put f 'funarg-positions '(3))) + ;;;###autoload (defun macroexpand-all (form &optional environment) "Return result of expanding macros at all levels in FORM. @@ -513,20 +610,35 @@ test of free variables in the following ways: - For the same reason it may cause the result to fail to include bindings which will be used if SEXP is not yet fully macro-expanded and the use of the binding will only be revealed by macro expansion." - (let ((res '())) - (while (and (consp sexp) bindings) - (dolist (binding (macroexp--fgrep bindings (pop sexp))) - (push binding res) - (setq bindings (remove binding bindings)))) - (if (or (vectorp sexp) (byte-code-function-p sexp)) - ;; With backquote, code can appear within vectors as well. - ;; This wouldn't be needed if we `macroexpand-all' before - ;; calling macroexp--fgrep, OTOH. - (macroexp--fgrep bindings (mapcar #'identity sexp)) - (let ((tmp (assq sexp bindings))) - (if tmp - (cons tmp res) - res))))) + (let ((res '()) + ;; Cyclic code should not happen, but code can contain cyclic data :-( + (seen (make-hash-table :test #'eq)) + (sexpss (list (list sexp)))) + ;; Use a nested while loop to reduce the amount of heap allocations for + ;; pushes to `sexpss' and the `gethash' overhead. + (while (and sexpss bindings) + (let ((sexps (pop sexpss))) + (unless (gethash sexps seen) + (puthash sexps t seen) ;; Using `setf' here causes bootstrap problems. + (if (vectorp sexps) (setq sexps (mapcar #'identity sexps))) + (let ((tortoise sexps) (skip t)) + (while sexps + (let ((sexp (if (consp sexps) (pop sexps) + (prog1 sexps (setq sexps nil))))) + (if skip + (setq skip nil) + (setq tortoise (cdr tortoise)) + (if (eq tortoise sexps) + (setq sexps nil) ;; Found a cycle: we're done! + (setq skip t))) + (cond + ((or (consp sexp) (vectorp sexp)) (push sexp sexpss)) + (t + (let ((tmp (assq sexp bindings))) + (when tmp + (push tmp res) + (setq bindings (remove tmp bindings)))))))))))) + res)) ;;; Load-time macro-expansion. diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index 14112a1c147..0522b31f577 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -38,46 +38,62 @@ (defun map-y-or-n-p (prompter actor list &optional help action-alist no-cursor-in-echo-area) - "Ask a series of boolean questions. -Takes args PROMPTER ACTOR LIST, and optional args HELP and ACTION-ALIST. + "Ask a boolean question per PROMPTER for each object in LIST, then call ACTOR. LIST is a list of objects, or a function of no arguments to return the next -object or nil. - -If PROMPTER is a string, the prompt is \(format PROMPTER OBJECT). If not -a string, PROMPTER is a function of one arg (an object from LIST), which -returns a string to be used as the prompt for that object. If the return -value is not a string, it may be nil to ignore the object or non-nil to act -on the object without asking the user. - -ACTOR is a function of one arg (an object from LIST), -which gets called with each object that the user answers `yes' for. - -If HELP is given, it is a list (OBJECT OBJECTS ACTION), -where OBJECT is a string giving the singular noun for an elt of LIST; -OBJECTS is the plural noun for elts of LIST, and ACTION is a transitive -verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\"). - -At the prompts, the user may enter y, Y, or SPC to act on that object; -n, N, or DEL to skip that object; ! to act on all following objects; -ESC or q to exit (skip all following objects); . (period) to act on the -current object and then exit; or \\[help-command] to get help. - -If ACTION-ALIST is given, it is an alist (KEY FUNCTION HELP) of extra keys -that will be accepted. KEY is a character; FUNCTION is a function of one -arg (an object from LIST); HELP is a string. When the user hits KEY, -FUNCTION is called. If it returns non-nil, the object is considered -\"acted upon\", and the next object from LIST is processed. If it returns -nil, the prompt is repeated for the same object. - -Final optional argument NO-CURSOR-IN-ECHO-AREA non-nil says not to set -`cursor-in-echo-area' while prompting. +object; when it returns nil, the list of objects is considered exhausted. + +If PROMPTER is a string, it should be a format string to be used to format +the question as \(format PROMPTER OBJECT). +If PROMPTER is not a string, it should be a function of one argument, an +object from LIST, which returns a string to be used as the question for +that object. If the function's return value is not a string, it may be +nil to ignore the object, or non-nil to act on the object with ACTOR +without asking the user. + +ACTOR is a function of one argument, an object from LIST, +which gets called with each object for which the user answers `yes' +to the question presented by PROMPTER. + +The user's answers to the questions may be one of the following: + + - y, Y, or SPC to act on that object; + - n, N, or DEL to skip that object; + - ! to act on all following objects; + - ESC or q to exit (skip all following objects); + - . (period) to act on the current object and then exit; or + - \\[help-command] to get help. + +HELP provides information for displaying help when the user +types \\[help-command]. If HELP is given, it should be a list of +the form (OBJECT OBJECTS ACTION), where OBJECT is a string giving +the singular noun describing an element of LIST; OBJECTS is the +plural noun describing several elements of LIST, and ACTION is a +transitive verb describing action by ACTOR on one or more elements +of LIST. If HELP is omitted or nil, it defaults +to \(\"object\" \"objects\" \"act on\"). + +If ACTION-ALIST is given, it is an alist specifying additional keys +that will be accepted as an answer to the questions. Each element +of the alist has the form (KEY FUNCTION HELP), where KEY is a character; +FUNCTION is a function of one argument (an object from LIST); and HELP +is a string. When the user presses KEY, FUNCTION is called; if it +returns non-nil, the object is considered to have been \"acted upon\", +and `map-y-or-n-p' proceeeds to the next object from LIST. If +FUNCTION returns nil, the prompt is re-issued for the same object: this +comes in handy if FUNCTION produces some display that will allow the +user to make an intelligent decision whether the object in question +should be acted upon. If the user types \\[help-command], the string +given by HELP is used to describe the effect of KEY. + +Optional argument NO-CURSOR-IN-ECHO-AREA, if non-nil, means not to set +`cursor-in-echo-area' while prompting with the questions. This function uses `query-replace-map' to define the standard responses, -but not all of the responses which `query-replace' understands -are meaningful here. +but only some of the responses which `query-replace' understands +are meaningful here, as described above. -Returns the number of actions taken." +The function's value is the number of actions taken." (let* ((actions 0) (msg (current-message)) user-keys mouse-event map prompt char elt def @@ -265,7 +281,8 @@ C-g to quit (cancel the whole command); "If non-nil, `read-answer' accepts single-character answers. If t, accept short (single key-press) answers to the question. If nil, require long answers. If `auto', accept short answers if -the function cell of `yes-or-no-p' is set to `y-or-n-p'." +`use-short-answers' is non-nil, or the function cell of `yes-or-no-p' +is set to `y-or-n-p'." :type '(choice (const :tag "Accept short answers" t) (const :tag "Require long answer" nil) (const :tag "Guess preference" auto)) @@ -304,7 +321,8 @@ Return a long answer even in case of accepting short ones. When `use-dialog-box' is t, pop up a dialog window to get user input." (let* ((short (if (eq read-answer-short 'auto) - (eq (symbol-function 'yes-or-no-p) 'y-or-n-p) + (or use-short-answers + (eq (symbol-function 'yes-or-no-p) 'y-or-n-p)) read-answer-short)) (answers-with-help (if (assoc "help" answers) diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 46a1bd21a3d..988a62a4e34 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -3,12 +3,10 @@ ;; Copyright (C) 2015-2021 Free Software Foundation, Inc. ;; Author: Nicolas Petton <nicolas@petton.fr> -;; Keywords: convenience, map, hash-table, alist, array -;; Version: 2.1 -;; Package-Requires: ((emacs "25")) -;; Package: map - ;; Maintainer: emacs-devel@gnu.org +;; Keywords: extensions, lisp +;; Version: 3.1 +;; Package-Requires: ((emacs "26")) ;; This file is part of GNU Emacs. @@ -27,8 +25,9 @@ ;;; Commentary: -;; map.el provides map-manipulation functions that work on alists, -;; hash-table and arrays. All functions are prefixed with "map-". +;; map.el provides generic map-manipulation functions that work on +;; alists, plists, hash-tables, and arrays. All functions are +;; prefixed with "map-". ;; ;; Functions taking a predicate or iterating over a map using a ;; function take the function as their first argument. All other @@ -54,7 +53,7 @@ ARGS is a list of elements to be matched in the map. Each element of ARGS can be of the form (KEY PAT), in which case KEY is evaluated and searched for in the map. The match fails if for any KEY found in the map, the corresponding PAT doesn't match the value -associated to the KEY. +associated with the KEY. Each element can also be a SYMBOL, which is an abbreviation of a (KEY PAT) tuple of the form (\\='SYMBOL SYMBOL). When SYMBOL @@ -75,7 +74,7 @@ bound to the looked up value in MAP. KEYS can also be a list of (KEY VARNAME) pairs, in which case KEY is an unquoted form. -MAP can be a list, hash-table or array." +MAP can be an alist, plist, hash-table, or array." (declare (indent 2) (debug ((&rest &or symbolp ([form symbolp])) form body))) `(pcase-let ((,(map--make-pcase-patterns keys) ,map)) @@ -101,7 +100,7 @@ Returns the result of evaluating the form associated with MAP-VAR's type." (define-error 'map-not-inplace "Cannot modify map in-place") (defsubst map--plist-p (list) - (and (consp list) (not (listp (car list))))) + (and (consp list) (atom (car list)))) (cl-defgeneric map-elt (map key &optional default testfn) "Lookup KEY in MAP and return its associated value. @@ -109,7 +108,8 @@ If KEY is not found, return DEFAULT which defaults to nil. TESTFN is deprecated. Its default depends on the MAP argument. -In the base definition, MAP can be an alist, hash-table, or array." +In the base definition, MAP can be an alist, plist, hash-table, +or array." (declare (gv-expander (lambda (do) @@ -124,29 +124,30 @@ In the base definition, MAP can be an alist, hash-table, or array." (with-no-warnings (map-put! ,mgetter ,key ,v ,testfn)) (map-not-inplace ,(funcall msetter - `(map-insert ,mgetter ,key ,v)))))))))) + `(map-insert ,mgetter ,key ,v)) + ;; Always return the value. + ,v)))))))) ;; `testfn' is deprecated. (advertised-calling-convention (map key &optional default) "27.1")) + ;; Can't use `cl-defmethod' with `advertised-calling-convention'. (map--dispatch map :list (if (map--plist-p map) - (let ((res (plist-get map key))) - (if (and default (null res) (not (plist-member map key))) - default - res)) + (let ((res (plist-member map key))) + (if res (cadr res) default)) (alist-get key map default nil testfn)) :hash-table (gethash key map default) - :array (if (and (>= key 0) (< key (seq-length map))) - (seq-elt map key) + :array (if (map-contains-key map key) + (aref map key) default))) (defmacro map-put (map key value &optional testfn) "Associate KEY with VALUE in MAP and return VALUE. If KEY is already present in MAP, replace the associated value with VALUE. -When MAP is a list, test equality with TESTFN if non-nil, +When MAP is an alist, test equality with TESTFN if non-nil, otherwise use `eql'. -MAP can be a list, hash-table or array." +MAP can be an alist, plist, hash-table, or array." (declare (obsolete "use map-put! or (setf (map-elt ...) ...) instead" "27.1")) `(setf (map-elt ,map ,key nil ,testfn) ,value)) @@ -168,23 +169,30 @@ MAP can be a list, hash-table or array." (cl-defgeneric map-delete (map key) "Delete KEY in-place from MAP and return MAP. -No error is signaled if KEY is not a key of MAP. -If MAP is an array, store nil at the index KEY." - (map--dispatch map - ;; FIXME: Signal map-not-inplace i.s.o returning a different list? - :list (if (map--plist-p map) - (setq map (map--plist-delete map key)) - (setf (alist-get key map nil t) nil)) - :hash-table (remhash key map) - :array (and (>= key 0) - (<= key (seq-length map)) - (aset map key nil))) +Keys not present in MAP are ignored.") + +(cl-defmethod map-delete ((map list) key) + ;; FIXME: Signal map-not-inplace i.s.o returning a different list? + (if (map--plist-p map) + (map--plist-delete map key) + (setf (alist-get key map nil t) nil) + map)) + +(cl-defmethod map-delete ((map hash-table) key) + (remhash key map) + map) + +(cl-defmethod map-delete ((map array) key) + "Store nil at index KEY." + (when (map-contains-key map key) + (aset map key nil)) map) (defun map-nested-elt (map keys &optional default) "Traverse MAP using KEYS and return the looked up value or DEFAULT if nil. -Map can be a nested map composed of alists, hash-tables and arrays." +MAP can be a nested map composed of alists, plists, hash-tables, +and arrays." (or (seq-reduce (lambda (acc key) (when (mapp acc) (map-elt acc key))) @@ -202,30 +210,49 @@ The default implementation delegates to `map-apply'." The default implementation delegates to `map-apply'." (map-apply (lambda (_ value) value) map)) +(cl-defmethod map-values ((map array)) + "Convert MAP into a list." + (append map ())) + (cl-defgeneric map-pairs (map) - "Return the elements of MAP as key/value association lists. + "Return the key/value pairs in MAP as an alist. The default implementation delegates to `map-apply'." (map-apply #'cons map)) (cl-defgeneric map-length (map) ;; FIXME: Should we rename this to `map-size'? - "Return the number of elements in the map. -The default implementation counts `map-keys'." - (cond - ((hash-table-p map) (hash-table-count map)) - ((listp map) - ;; FIXME: What about repeated/shadowed keys? - (if (map--plist-p map) (/ (length map) 2) (length map))) - ((arrayp map) (length map)) - (t (length (map-keys map))))) + "Return the number of key/value pairs in MAP. +Note that this does not always reflect the number of unique keys. +The default implementation delegates to `map-do'." + (let ((size 0)) + (map-do (lambda (_k _v) (setq size (1+ size))) map) + size)) + +(cl-defmethod map-length ((map hash-table)) + (hash-table-count map)) + +(cl-defmethod map-length ((map list)) + (if (map--plist-p map) + (/ (length map) 2) + (length map))) + +(cl-defmethod map-length ((map array)) + (length map)) (cl-defgeneric map-copy (map) - "Return a copy of MAP." - ;; FIXME: Clarify how deep is the copy! - (map--dispatch map - :list (seq-copy map) ;FIXME: Probably not deep enough for alists! - :hash-table (copy-hash-table map) - :array (seq-copy map))) + "Return a copy of MAP.") + +(cl-defmethod map-copy ((map list)) + "Use `copy-alist' on alists and `copy-sequence' on plists." + (if (map--plist-p map) + (copy-sequence map) + (copy-alist map))) + +(cl-defmethod map-copy ((map hash-table)) + (copy-hash-table map)) + +(cl-defmethod map-copy ((map array)) + (copy-sequence map)) (cl-defgeneric map-apply (function map) "Apply FUNCTION to each element of MAP and return the result as a list. @@ -243,26 +270,28 @@ FUNCTION is called with two arguments, the key and the value.") (cl-defmethod map-do (function (map hash-table)) (maphash function map)) (cl-defgeneric map-keys-apply (function map) - "Return the result of applying FUNCTION to each key of MAP. + "Return the result of applying FUNCTION to each key in MAP. The default implementation delegates to `map-apply'." (map-apply (lambda (key _) (funcall function key)) map)) (cl-defgeneric map-values-apply (function map) - "Return the result of applying FUNCTION to each value of MAP. + "Return the result of applying FUNCTION to each value in MAP. The default implementation delegates to `map-apply'." (map-apply (lambda (_ val) (funcall function val)) map)) +(cl-defmethod map-values-apply (function (map array)) + (mapcar function map)) + (cl-defgeneric map-filter (pred map) "Return an alist of key/val pairs for which (PRED key val) is non-nil in MAP. The default implementation delegates to `map-apply'." (delq nil (map-apply (lambda (key val) - (if (funcall pred key val) - (cons key val) - nil)) + (and (funcall pred key val) + (cons key val))) map))) (cl-defgeneric map-remove (pred map) @@ -272,7 +301,7 @@ The default implementation delegates to `map-filter'." map)) (cl-defgeneric mapp (map) - "Return non-nil if MAP is a map (alist, hash-table, array, ...)." + "Return non-nil if MAP is a map (alist/plist, hash-table, array, ...)." (or (listp map) (hash-table-p map) (arrayp map))) @@ -292,130 +321,161 @@ The default implementation delegates to `map-length'." ;; test function! "Return non-nil if and only if MAP contains KEY. TESTFN is deprecated. Its default depends on MAP. -The default implementation delegates to `map-do'." +The default implementation delegates to `map-some'." (unless testfn (setq testfn #'equal)) - (catch 'map--catch - (map-do (lambda (k _v) - (if (funcall testfn key k) (throw 'map--catch t))) - map) - nil)) + (map-some (lambda (k _v) (funcall testfn key k)) map)) (cl-defmethod map-contains-key ((map list) key &optional testfn) - (let ((v '(nil))) - (not (eq v (alist-get key map v nil (or testfn #'equal)))))) + "Return non-nil if MAP contains KEY. +If MAP is an alist, TESTFN defaults to `equal'. +If MAP is a plist, `plist-member' is used instead." + (if (map--plist-p map) + (plist-member map key) + (let ((v '(nil))) + (not (eq v (alist-get key map v nil (or testfn #'equal))))))) (cl-defmethod map-contains-key ((map array) key &optional _testfn) - (and (integerp key) - (>= key 0) - (< key (length map)))) + "Return non-nil if KEY is an index of MAP, ignoring TESTFN." + (and (natnump key) (< key (length map)))) (cl-defmethod map-contains-key ((map hash-table) key &optional _testfn) + "Return non-nil if MAP contains KEY, ignoring TESTFN." (let ((v '(nil))) (not (eq v (gethash key map v))))) (cl-defgeneric map-some (pred map) "Return the first non-nil (PRED key val) in MAP. -The default implementation delegates to `map-apply'." +Return nil if no such element is found. +The default implementation delegates to `map-do'." ;; FIXME: Not sure if there's much benefit to defining it as defgeneric, ;; since as defined, I can't think of a map-type where we could provide an ;; algorithmically more efficient algorithm than the default. (catch 'map--break - (map-apply (lambda (key value) - (let ((result (funcall pred key value))) - (when result - (throw 'map--break result)))) - map) + (map-do (lambda (key value) + (let ((result (funcall pred key value))) + (when result + (throw 'map--break result)))) + map) nil)) (cl-defgeneric map-every-p (pred map) "Return non-nil if (PRED key val) is non-nil for all elements of MAP. -The default implementation delegates to `map-apply'." +The default implementation delegates to `map-do'." ;; FIXME: Not sure if there's much benefit to defining it as defgeneric, ;; since as defined, I can't think of a map-type where we could provide an ;; algorithmically more efficient algorithm than the default. (catch 'map--break - (map-apply (lambda (key value) + (map-do (lambda (key value) (or (funcall pred key value) (throw 'map--break nil))) map) t)) +(defun map--merge (merge type &rest maps) + "Merge into a map of TYPE all the key/value pairs in MAPS. +MERGE is a function that takes the target MAP, a KEY, and a +VALUE, merges KEY and VALUE into MAP, and returns the result. +MAP may be of a type other than TYPE." + ;; Use a hash table internally if `type' is a list. This avoids + ;; both quadratic lookup behavior and the type ambiguity of nil. + (let* ((tolist (memq type '(list alist plist))) + (result (map-into (pop maps) + ;; Use same testfn as `map-elt' gv setter. + (cond ((eq type 'plist) '(hash-table :test eq)) + (tolist '(hash-table :test equal)) + (type))))) + (dolist (map maps) + (map-do (lambda (key value) + (setq result (funcall merge result key value))) + map)) + ;; Convert internal representation to desired type. + (if tolist (map-into result type) result))) + (defun map-merge (type &rest maps) - "Merge into a map of type TYPE all the key/value pairs in MAPS. + "Merge into a map of TYPE all the key/value pairs in MAPS. See `map-into' for all supported values of TYPE." - (let ((result (map-into (pop maps) type))) - (while maps - ;; FIXME: When `type' is `list', we get an O(N^2) behavior. - ;; For small tables, this is fine, but for large tables, we - ;; should probably use a hash-table internally which we convert - ;; to an alist in the end. - (map-apply (lambda (key value) - (setf (map-elt result key) value)) - (pop maps))) - result)) + (apply #'map--merge + (lambda (result key value) + (setf (map-elt result key) value) + result) + type maps)) (defun map-merge-with (type function &rest maps) - "Merge into a map of type TYPE all the key/value pairs in MAPS. -When two maps contain the same key (`eql'), call FUNCTION on the two + "Merge into a map of TYPE all the key/value pairs in MAPS. +When two maps contain the same key, call FUNCTION on the two values and use the value returned by it. -MAP can be a list, hash-table or array. +Each of MAPS can be an alist, plist, hash-table, or array. See `map-into' for all supported values of TYPE." - (let ((result (map-into (pop maps) type)) - (not-found (cons nil nil))) - (while maps - (map-apply (lambda (key value) - (cl-callf (lambda (old) - (if (eql old not-found) - value - (funcall function old value))) - (map-elt result key not-found))) - (pop maps))) - result)) + (let ((not-found (list nil))) + (apply #'map--merge + (lambda (result key value) + (cl-callf (lambda (old) + (if (eql old not-found) + value + (funcall function old value))) + (map-elt result key not-found)) + result) + type maps))) (cl-defgeneric map-into (map type) - "Convert the map MAP into a map of type TYPE.") + "Convert MAP into a map of TYPE.") + ;; FIXME: I wish there was a way to avoid this η-redex! -(cl-defmethod map-into (map (_type (eql list))) (map-pairs map)) -(cl-defmethod map-into (map (_type (eql alist))) (map-pairs map)) -(cl-defmethod map-into (map (_type (eql plist))) - (let ((plist '())) - (map-do (lambda (k v) (setq plist `(,k ,v ,@plist))) map) - plist)) +(cl-defmethod map-into (map (_type (eql 'list))) + "Convert MAP into an alist." + (map-pairs map)) + +(cl-defmethod map-into (map (_type (eql 'alist))) + "Convert MAP into an alist." + (map-pairs map)) + +(cl-defmethod map-into (map (_type (eql 'plist))) + "Convert MAP into a plist." + (let (plist) + (map-do (lambda (k v) (setq plist `(,v ,k ,@plist))) map) + (nreverse plist))) (cl-defgeneric map-put! (map key value &optional testfn) "Associate KEY with VALUE in MAP. If KEY is already present in MAP, replace the associated value with VALUE. This operates by modifying MAP in place. -If it cannot do that, it signals the `map-not-inplace' error. -If you want to insert an element without modifying MAP, use `map-insert'." +If it cannot do that, it signals a `map-not-inplace' error. +To insert an element without modifying MAP, use `map-insert'." ;; `testfn' only exists for backward compatibility with `map-put'! (declare (advertised-calling-convention (map key value) "27.1")) - (map--dispatch map - :list - (if (map--plist-p map) - (plist-put map key value) - (let ((oldmap map)) - (setf (alist-get key map key nil (or testfn #'equal)) value) - (unless (eq oldmap map) - (signal 'map-not-inplace (list oldmap))))) - :hash-table (puthash key value map) - ;; FIXME: If `key' is too large, should we signal `map-not-inplace' - ;; and let `map-insert' grow the array? - :array (aset map key value))) - -(define-error 'map-inplace "Can only modify map in place") + ;; Can't use `cl-defmethod' with `advertised-calling-convention'. + (map--dispatch + map + :list + (progn + (if (map--plist-p map) + (plist-put map key value) + (let ((oldmap map)) + (setf (alist-get key map key nil (or testfn #'equal)) value) + (unless (eq oldmap map) + (signal 'map-not-inplace (list oldmap))))) + ;; Always return the value. + value) + :hash-table (puthash key value map) + ;; FIXME: If `key' is too large, should we signal `map-not-inplace' + ;; and let `map-insert' grow the array? + :array (aset map key value))) (cl-defgeneric map-insert (map key value) "Return a new map like MAP except that it associates KEY with VALUE. This does not modify MAP. -If you want to insert an element in place, use `map-put!'." - (if (listp map) - (if (map--plist-p map) - `(,key ,value ,@map) - (cons (cons key value) map)) - ;; FIXME: Should we signal an error or use copy+put! ? - (signal 'map-inplace (list map)))) +If you want to insert an element in place, use `map-put!'. +The default implementation defaults to `map-copy' and `map-put!'." + (let ((copy (map-copy map))) + (map-put! copy key value) + copy)) + +(cl-defmethod map-insert ((map list) key value) + "Cons KEY and VALUE to the front of MAP." + (if (map--plist-p map) + (cons key (cons value map)) + (cons (cons key value) map))) ;; There shouldn't be old source code referring to `map--put', yet we do ;; need to keep it for backward compatibility with .elc files where the @@ -425,11 +485,9 @@ If you want to insert an element in place, use `map-put!'." (cl-defmethod map-apply (function (map list)) (if (map--plist-p map) (cl-call-next-method) - (seq-map (lambda (pair) - (funcall function - (car pair) - (cdr pair))) - map))) + (mapcar (lambda (pair) + (funcall function (car pair) (cdr pair))) + map))) (cl-defmethod map-apply (function (map hash-table)) (let (result) @@ -439,46 +497,40 @@ If you want to insert an element in place, use `map-put!'." (nreverse result))) (cl-defmethod map-apply (function (map array)) - (let ((index 0)) - (seq-map (lambda (elt) - (prog1 - (funcall function index elt) - (setq index (1+ index)))) - map))) + (seq-map-indexed (lambda (elt index) + (funcall function index elt)) + map)) (cl-defmethod map-do (function (map list)) - "Private function used to iterate over ALIST using FUNCTION." (if (map--plist-p map) (while map (funcall function (pop map) (pop map))) - (seq-do (lambda (pair) - (funcall function - (car pair) - (cdr pair))) - map))) + (mapc (lambda (pair) + (funcall function (car pair) (cdr pair))) + map) + nil)) -(cl-defmethod map-do (function (array array)) - "Private function used to iterate over ARRAY using FUNCTION." +(cl-defmethod map-do (function (map array)) (seq-do-indexed (lambda (elt index) - (funcall function index elt)) - array)) + (funcall function index elt)) + map)) (defun map--into-hash (map keyword-args) "Convert MAP into a hash-table. KEYWORD-ARGS are forwarded to `make-hash-table'." (let ((ht (apply #'make-hash-table keyword-args))) - (map-apply (lambda (key value) - (setf (gethash key ht) value)) - map) + (map-do (lambda (key value) + (puthash key value ht)) + map) ht)) -(cl-defmethod map-into (map (_type (eql hash-table))) - "Convert MAP into a hash-table." - (map--into-hash map (list :size (map-length map) :test 'equal))) +(cl-defmethod map-into (map (_type (eql 'hash-table))) + "Convert MAP into a hash-table with keys compared with `equal'." + (map--into-hash map (list :size (map-length map) :test #'equal))) (cl-defmethod map-into (map (type (head hash-table))) "Convert MAP into a hash-table. -TYPE is a list where the car is `hash-table' and the cdr are the +TYPE is a list whose car is `hash-table' and cdr a list of keyword-args forwarded to `make-hash-table'. Example: @@ -487,23 +539,23 @@ Example: (defun map--make-pcase-bindings (args) "Return a list of pcase bindings from ARGS to the elements of a map." - (seq-map (lambda (elt) - (cond ((consp elt) - `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt))) - ((keywordp elt) - (let ((var (intern (substring (symbol-name elt) 1)))) - `(app (pcase--flip map-elt ,elt) ,var))) - (t `(app (pcase--flip map-elt ',elt) ,elt)))) - args)) + (mapcar (lambda (elt) + (cond ((consp elt) + `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt))) + ((keywordp elt) + (let ((var (intern (substring (symbol-name elt) 1)))) + `(app (pcase--flip map-elt ,elt) ,var))) + (t `(app (pcase--flip map-elt ',elt) ,elt)))) + args)) (defun map--make-pcase-patterns (args) "Return a list of `(map ...)' pcase patterns built from ARGS." (cons 'map - (seq-map (lambda (elt) - (if (and (consp elt) (eq 'map (car elt))) - (map--make-pcase-patterns elt) - elt)) - args))) + (mapcar (lambda (elt) + (if (eq (car-safe elt) 'map) + (map--make-pcase-patterns elt) + elt)) + args))) (provide 'map) ;;; map.el ends here diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el index 3d6ca957e63..aee2a0079ca 100644 --- a/lisp/emacs-lisp/memory-report.el +++ b/lisp/emacs-lisp/memory-report.el @@ -44,6 +44,8 @@ by counted more than once." (pop-to-buffer "*Memory Report*") (special-mode) (button-mode 1) + (setq-local revert-buffer-function (lambda (_ignore-auto _noconfirm) + (memory-report))) (setq truncate-lines t) (message "Gathering data...") (let ((reports (append (memory-report--garbage-collect) @@ -182,7 +184,7 @@ by counted more than once." (cl-defmethod memory-report--object-size-1 (_ (value symbol)) ;; Don't count global symbols -- makes sizes of lists of symbols too - ;; heavey. + ;; heavy. (if (intern-soft value obarray) 0 (memory-report--size 'symbol))) @@ -214,22 +216,21 @@ by counted more than once." (setf (gethash value counted) t) (when (car value) (cl-incf total (memory-report--object-size counted (car value)))) - (if (cdr value) - (if (consp (cdr value)) - (if (gethash (cdr value) counted) - (setq value nil) - (setq value (cdr value))) - (cl-incf total (memory-report--object-size counted (cdr value))) - (setq value nil)) - (setq value nil))) + (let ((next (cdr value))) + (setq value (when next + (if (consp next) + (unless (gethash next counted) + (cdr value)) + (cl-incf total (memory-report--object-size + counted next)) + nil))))) total)) (cl-defmethod memory-report--object-size-1 (counted (value vector)) (let ((total (+ (memory-report--size 'vector) (* (memory-report--size 'object) (length value))))) (cl-loop for elem across value - do (setf (gethash elem counted) t) - (cl-incf total (memory-report--object-size counted elem))) + do (cl-incf total (memory-report--object-size counted elem))) total)) (cl-defmethod memory-report--object-size-1 (counted (value hash-table)) @@ -237,8 +238,6 @@ by counted more than once." (* (memory-report--size 'object) (hash-table-size value))))) (maphash (lambda (key elem) - (setf (gethash key counted) t) - (setf (gethash elem counted) t) (cl-incf total (memory-report--object-size counted key)) (cl-incf total (memory-report--object-size counted elem))) value) @@ -295,7 +294,7 @@ by counted more than once." (- (position-bytes (point-min))) (gap-size))) (seq-reduce #'+ (mapcar (lambda (elem) - (if (cdr elem) + (if (and (consp elem) (cdr elem)) (memory-report--object-size (make-hash-table :test #'eq) (cdr elem)) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index afdd372d273..4804e859ebe 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -316,8 +316,26 @@ is also interactive. There are 3 cases: `(advice--add-function ,where (gv-ref ,(advice--normalize-place place)) ,function ,props)) +(declare-function comp-subr-trampoline-install "comp") + ;;;###autoload (defun advice--add-function (where ref function props) + (when (and (featurep 'native-compile) + (subr-primitive-p (gv-deref ref))) + (let ((subr-name (intern (subr-name (gv-deref ref))))) + ;; Requiring the native compiler to advice `macroexpand' cause a + ;; circular dependency in eager macro expansion. uniquify is + ;; advising `rename-buffer' while being loaded in loadup.el. + ;; This would require the whole native compiler machinery but we + ;; don't want to include it in the dump. Because these two + ;; functions are already handled in + ;; `native-comp-never-optimize-functions' we hack the problem + ;; this way for now :/ + (unless (memq subr-name '(macroexpand rename-buffer)) + ;; Must require explicitly as during bootstrap we have no + ;; autoloads. + (require 'comp) + (comp-subr-trampoline-install subr-name)))) (let* ((name (cdr (assq 'name props))) (a (advice--member-p (or name function) (if name t) (gv-deref ref)))) (when a @@ -485,7 +503,7 @@ arguments. Note if NAME is nil the advice is anonymous; otherwise it is named `SYMBOL@NAME'. \(fn SYMBOL (WHERE LAMBDA-LIST &optional NAME DEPTH) &rest BODY)" - (declare (indent 2) (doc-string 3) (debug (sexp sexp body))) + (declare (indent 2) (doc-string 3) (debug (sexp sexp def-body))) (or (listp args) (signal 'wrong-type-argument (list 'listp args))) (or (<= 2 (length args) 4) (signal 'wrong-number-of-arguments (list 2 4 (length args)))) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ccd52aa7b33..9ed23862e92 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -73,9 +73,9 @@ ;; M-x list-packages ;; Enters a mode similar to buffer-menu which lets you manage ;; packages. You can choose packages for install (mark with "i", -;; then "x" to execute) or deletion (not implemented yet), and you -;; can see what packages are available. This will automatically -;; fetch the latest list of packages from ELPA. +;; then "x" to execute) or deletion, and you can see what packages +;; are available. This will automatically fetch the latest list of +;; packages from ELPA. ;; ;; M-x package-install-from-buffer ;; Install a package consisting of a single .el file that appears @@ -89,7 +89,7 @@ ;; Install a package from the indicated file. The package can be ;; either a tar file or a .el file. A tar file must contain an ;; appropriately-named "-pkg.el" file; a .el file must be properly -;; formatted as with package-install-from-buffer. +;; formatted as with `package-install-from-buffer'. ;;; Thanks: ;;; (sorted by sort-lines): @@ -225,7 +225,7 @@ security." :type '(alist :key-type (string :tag "Archive name") :value-type (string :tag "URL or directory name")) :risky t - :version "26.1") ; gnutls test + :version "28.1") (defcustom package-menu-hide-low-priority 'archive "If non-nil, hide low priority packages from the packages menu. @@ -397,6 +397,12 @@ a sane initial value." :version "25.1" :type '(repeat symbol)) +(defcustom package-native-compile nil + "Non-nil means to native compile packages on installation." + :type '(boolean) + :risky t + :version "28.1") + (defcustom package-menu-async t "If non-nil, package-menu will use async operations when possible. Currently, only the refreshing of archive contents supports @@ -830,8 +836,6 @@ correspond to previously loaded files (those returned by ;; Don't return nil. t))) -(declare-function find-library-name "find-func" (library)) - (defun package--files-load-history () (delq nil (mapcar (lambda (x) @@ -841,20 +845,22 @@ correspond to previously loaded files (those returned by load-history))) (defun package--list-of-conflicts (dir history) - (delq - nil - (mapcar - (lambda (x) (let* ((file (file-relative-name x dir)) - ;; Previously loaded file, if any. - (previous - (ignore-errors - (file-name-sans-extension - (file-truename (find-library-name file))))) - (pos (when previous (member previous history)))) - ;; Return (RELATIVE-FILENAME . HISTORY-POSITION) - (when pos - (cons (file-name-sans-extension file) (length pos))))) - (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")))) + (require 'find-func) + (declare-function find-library-name "find-func" (library)) + (delq + nil + (mapcar + (lambda (x) (let* ((file (file-relative-name x dir)) + ;; Previously loaded file, if any. + (previous + (ignore-error file-error ;"Can't find library" + (file-name-sans-extension + (file-truename (find-library-name file))))) + (pos (when previous (member previous history)))) + ;; Return (RELATIVE-FILENAME . HISTORY-POSITION) + (when pos + (cons (file-name-sans-extension file) (length pos))))) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")))) (defun package--list-loaded-files (dir) "Recursively list all files in DIR which correspond to loaded features. @@ -986,6 +992,8 @@ untar into a directory named DIR; otherwise, signal an error." ;; E.g. for multi-package installs, we should first install all packages ;; and then compile them. (package--compile new-desc) + (when package-native-compile + (package--native-compile-async new-desc)) ;; After compilation, load again any files loaded by ;; `activate-1', so that we use the byte-compiled definitions. (package--load-files-for-activation new-desc :reload))) @@ -1070,6 +1078,15 @@ This assumes that `pkg-desc' has already been activated with (load-path load-path)) (byte-recompile-directory (package-desc-dir pkg-desc) 0 t))) +(defun package--native-compile-async (pkg-desc) + "Native compile installed package PKG-DESC asynchronously. +This assumes that `pkg-desc' has already been activated with +`package-activate-1'." + (when (and (featurep 'native-compile) + (native-comp-available-p)) + (let ((warning-minimum-level :error)) + (native-compile-async (package-desc-dir pkg-desc) t)))) + ;;;; Inferring package from current buffer (defun package-read-from-string (str) "Read a Lisp expression from STR. @@ -1104,7 +1121,7 @@ is wrapped around any parts requiring it." (declare-function lm-header-multiline "lisp-mnt" (header)) (declare-function lm-homepage "lisp-mnt" (&optional file)) (declare-function lm-keywords-list "lisp-mnt" (&optional file)) -(declare-function lm-maintainer "lisp-mnt" (&optional file)) +(declare-function lm-maintainers "lisp-mnt" (&optional file)) (declare-function lm-authors "lisp-mnt" (&optional file)) (defun package-buffer-info () @@ -1150,7 +1167,10 @@ boundaries." :kind 'single :url homepage :keywords keywords - :maintainer (lm-maintainer) + :maintainer + ;; For backward compatibility, use a single string if there's only + ;; one maintainer (the most common case). + (let ((maints (lm-maintainers))) (if (cdr maints) maints (car maints))) :authors (lm-authors))))) (defun package--read-pkg-desc (kind) @@ -1289,7 +1309,10 @@ is non-nil, don't propagate connection errors (does not apply to errors signaled by ERROR-FORM or by BODY). \(fn URL &key ASYNC FILE ERROR-FORM NOERROR &rest BODY)" - (declare (indent defun) (debug t)) + (declare (indent defun) + ;; FIXME: This should be something like + ;; `form def-body &rest form', but that doesn't work. + (debug (form &rest sexp))) (while (keywordp (car body)) (setq body (cdr (cdr body)))) `(package--with-response-buffer-1 ,url (lambda () ,@body) @@ -1347,11 +1370,9 @@ errors signaled by ERROR-FORM or by BODY). (kill-buffer buffer) (goto-char (point-min)))))) (package--unless-error body - (let ((url (expand-file-name file url))) - (unless (file-name-absolute-p url) - (error "Location %s is not a url nor an absolute file name" - url)) - (insert-file-contents-literally url))))) + (unless (file-name-absolute-p url) + (error "Location %s is not a url nor an absolute file name" url)) + (insert-file-contents-literally (expand-file-name file url))))) (define-error 'bad-signature "Failed to verify signature") @@ -2176,8 +2197,24 @@ Downloads and installs required packages as needed." ((derived-mode-p 'tar-mode) (package-tar-file-info)) (t - (save-excursion - (package-buffer-info))))) + ;; Package headers should be parsed from decoded text + ;; (see Bug#48137) where possible. + (if (and (eq buffer-file-coding-system 'no-conversion) + buffer-file-name) + (let* ((package-buffer (current-buffer)) + (decoding-system + (car (find-operation-coding-system + 'insert-file-contents + (cons buffer-file-name + package-buffer))))) + (with-temp-buffer + (insert-buffer-substring package-buffer) + (decode-coding-region (point-min) (point-max) + decoding-system) + (package-buffer-info))) + + (save-excursion + (package-buffer-info)))))) (name (package-desc-name pkg-desc))) ;; Download and install the dependencies. (let* ((requires (package-desc-reqs pkg-desc)) @@ -2203,14 +2240,18 @@ directory." (setq default-directory file) (dired-mode)) (insert-file-contents-literally file) + (set-visited-file-name file) (when (string-match "\\.tar\\'" file) (tar-mode))) (package-install-from-buffer))) ;;;###autoload -(defun package-install-selected-packages () +(defun package-install-selected-packages (&optional noconfirm) "Ensure packages in `package-selected-packages' are installed. -If some packages are not installed propose to install them." +If some packages are not installed, propose to install them. +If optional argument NOCONFIRM is non-nil, don't ask for +confirmation to install packages." (interactive) + (package--archives-initialize) ;; We don't need to populate `package-selected-packages' before ;; using here, because the outcome is the same either way (nothing ;; gets installed). @@ -2221,10 +2262,11 @@ If some packages are not installed propose to install them." (difference (- (length not-installed) (length available)))) (cond (available - (when (y-or-n-p - (format "Packages to install: %d (%s), proceed? " - (length available) - (mapconcat #'symbol-name available " "))) + (when (or noconfirm + (y-or-n-p + (format "Packages to install: %d (%s), proceed? " + (length available) + (mapconcat #'symbol-name available " ")))) (mapc (lambda (p) (package-install p 'dont-select)) available))) ((> difference 0) (message "Packages that are not available: %d (the rest is already installed), maybe you need to `M-x package-refresh-contents'" @@ -2240,6 +2282,17 @@ If some packages are not installed propose to install them." (equal (cadr (assq (package-desc-name pkg) package-alist)) pkg)) +(declare-function comp-el-to-eln-filename "comp.c") +(defun package--delete-directory (dir) + "Delete DIR recursively. +Clean-up the corresponding .eln files if Emacs is native +compiled." + (when (featurep 'native-compile) + (cl-loop + for file in (directory-files-recursively dir "\\.el\\'") + do (comp-clean-up-stale-eln (comp-el-to-eln-filename file)))) + (delete-directory dir t)) + (defun package-delete (pkg-desc &optional force nosave) "Delete package PKG-DESC. @@ -2292,7 +2345,7 @@ If NOSAVE is non-nil, the package is not removed from (package-desc-name pkg-used-elsewhere-by))) (t (add-hook 'post-command-hook #'package-menu--post-refresh) - (delete-directory dir t) + (package--delete-directory dir) ;; Remove NAME-VERSION.signed and NAME-readme.txt files. ;; ;; NAME-readme.txt files are no longer created, but they @@ -2693,9 +2746,9 @@ PROPERTIES are passed to `insert-text-button', for which this function is a convenience wrapper used by `describe-package-1'." (let ((button-text (if (display-graphic-p) text (concat "[" text "]"))) (button-face (if (display-graphic-p) - '(:box (:line-width 2 :color "dark grey") - :background "light grey" - :foreground "black") + (progn + (require 'cus-edit) ; for the custom-button face + 'custom-button) 'link))) (apply #'insert-text-button button-text 'face button-face 'follow-link t properties))) @@ -2732,6 +2785,7 @@ either a full name or nil, and EMAIL is a valid email address." (define-key map "U" 'package-menu-mark-upgrades) (define-key map "r" 'revert-buffer) (define-key map "~" 'package-menu-mark-obsolete-for-deletion) + (define-key map "w" 'package-browse-url) (define-key map "x" 'package-menu-execute) (define-key map "h" 'package-menu-quick-help) (define-key map "H" #'package-menu-hide-package) @@ -2754,6 +2808,8 @@ either a full name or nil, and EMAIL is a valid email address." "Menu for `package-menu-mode'." '("Package" ["Describe Package" package-menu-describe-package :help "Display information about this package"] + ["Open Package Homepage" package-browse-url + :help "Open the homepage of this package"] ["Help" package-menu-quick-help :help "Show short key binding help for package-menu-mode"] "--" ["Refresh Package List" revert-buffer @@ -2803,6 +2859,7 @@ either a full name or nil, and EMAIL is a valid email address." Letters do not insert themselves; instead, they are commands. \\<package-menu-mode-map> \\{package-menu-mode-map}" + :interactive nil (setq mode-line-process '((package--downloads-in-progress ":Loading") (package-menu--transaction-status package-menu--transaction-status))) @@ -2925,7 +2982,7 @@ Installed obsolete packages are always displayed.") Also hide packages whose name matches a regexp in user option `package-hidden-regexps' (a list). To add regexps to this list, use `package-menu-hide-package'." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (setq package-menu--hide-packages (not package-menu--hide-packages)) @@ -3262,7 +3319,7 @@ To unhide a package, type Type \\[package-menu-toggle-hiding] to toggle package hiding." (declare (interactive-only "change `package-hidden-regexps' instead.")) - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (let* ((name (when (derived-mode-p 'package-menu-mode) (concat "\\`" (regexp-quote (symbol-name (package-desc-name @@ -3286,7 +3343,7 @@ Type \\[package-menu-toggle-hiding] to toggle package hiding." (defun package-menu-describe-package (&optional button) "Describe the current package. If optional arg BUTTON is non-nil, describe its associated package." - (interactive) + (interactive nil package-menu-mode) (let ((pkg-desc (if button (button-get button 'package-desc) (tabulated-list-get-id)))) (if pkg-desc @@ -3296,7 +3353,7 @@ If optional arg BUTTON is non-nil, describe its associated package." ;; fixme numeric argument (defun package-menu-mark-delete (&optional _num) "Mark a package for deletion and move to the next line." - (interactive "p") + (interactive "p" package-menu-mode) (package--ensure-package-menu-mode) (if (member (package-menu-get-status) '("installed" "dependency" "obsolete" "unsigned")) @@ -3305,7 +3362,7 @@ If optional arg BUTTON is non-nil, describe its associated package." (defun package-menu-mark-install (&optional _num) "Mark a package for installation and move to the next line." - (interactive "p") + (interactive "p" package-menu-mode) (package--ensure-package-menu-mode) (if (member (package-menu-get-status) '("available" "avail-obso" "new" "dependency")) (tabulated-list-put-tag "I" t) @@ -3313,20 +3370,20 @@ If optional arg BUTTON is non-nil, describe its associated package." (defun package-menu-mark-unmark (&optional _num) "Clear any marks on a package and move to the next line." - (interactive "p") + (interactive "p" package-menu-mode) (package--ensure-package-menu-mode) (tabulated-list-put-tag " " t)) (defun package-menu-backup-unmark () "Back up one line and clear any marks on that package." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (forward-line -1) (tabulated-list-put-tag " ")) (defun package-menu-mark-obsolete-for-deletion () "Mark all obsolete packages for deletion." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (save-excursion (goto-char (point-min)) @@ -3336,7 +3393,8 @@ If optional arg BUTTON is non-nil, describe its associated package." (forward-line 1))))) (defvar package--quick-help-keys - '(("install," "delete," "unmark," ("execute" . 1)) + '((("mark for installation," . 9) + ("mark for deletion," . 9) "unmark," ("execute marked actions" . 1)) ("next," "previous") ("Hide-package," "(-toggle-hidden") ("g-refresh-contents," "/-filter," "help"))) @@ -3357,7 +3415,7 @@ If optional arg BUTTON is non-nil, describe its associated package." (defun package-menu-quick-help () "Show short key binding help for `package-menu-mode'. The full list of keys can be viewed with \\[describe-mode]." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (message (mapconcat #'package--prettify-quick-help-key package--quick-help-keys "\n"))) @@ -3453,7 +3511,7 @@ call will upgrade the package. If there's an async refresh operation in progress, the flags will be placed as part of `package-menu--post-refresh' instead of immediately." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (if (not package--downloads-in-progress) (package-menu--mark-upgrades-1) @@ -3547,7 +3605,7 @@ packages list, respectively." Packages marked for installation are downloaded and installed; packages marked for deletion are removed. Optional argument NOQUERY non-nil means do not ask the user to confirm." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (let (install-list delete-list cmd pkg-desc) (save-excursion @@ -3792,7 +3850,8 @@ strings. If ARCHIVE is nil or the empty string, show all packages." (interactive (list (completing-read-multiple "Filter by archive (comma separated): " - (mapcar #'car package-archives)))) + (mapcar #'car package-archives))) + package-menu-mode) (package--ensure-package-menu-mode) (let ((re (if (listp archive) (regexp-opt archive) @@ -3813,7 +3872,8 @@ DESCRIPTION. When called interactively, prompt for DESCRIPTION. If DESCRIPTION is nil or the empty string, show all packages." - (interactive (list (read-regexp "Filter by description (regexp)"))) + (interactive (list (read-regexp "Filter by description (regexp)")) + package-menu-mode) (package--ensure-package-menu-mode) (if (or (not description) (string-empty-p description)) (package-menu--generate t t) @@ -3834,10 +3894,11 @@ strings. If KEYWORD is nil or the empty string, show all packages." (interactive (list (completing-read-multiple "Keywords (comma separated): " - (package-all-keywords)))) + (package-all-keywords))) + package-menu-mode) + (package--ensure-package-menu-mode) (when (stringp keyword) (setq keyword (list keyword))) - (package--ensure-package-menu-mode) (if (not keyword) (package-menu--generate t t) (package-menu--filter-by (lambda (pkg-desc) @@ -3856,7 +3917,8 @@ When called interactively, prompt for NAME-OR-DESCRIPTION. If NAME-OR-DESCRIPTION is nil or the empty string, show all packages." - (interactive (list (read-regexp "Filter by name or description (regexp)"))) + (interactive (list (read-regexp "Filter by name or description (regexp)")) + package-menu-mode) (package--ensure-package-menu-mode) (if (or (not name-or-description) (string-empty-p name-or-description)) (package-menu--generate t t) @@ -3875,7 +3937,8 @@ Display only packages with name that matches regexp NAME. When called interactively, prompt for NAME. If NAME is nil or the empty string, show all packages." - (interactive (list (read-regexp "Filter by name (regexp)"))) + (interactive (list (read-regexp "Filter by name (regexp)")) + package-menu-mode) (package--ensure-package-menu-mode) (if (or (not name) (string-empty-p name)) (package-menu--generate t t) @@ -3905,13 +3968,19 @@ packages." "incompat" "installed" "new" - "unsigned")))) + "unsigned"))) + package-menu-mode) (package--ensure-package-menu-mode) (if (or (not status) (string-empty-p status)) (package-menu--generate t t) - (package-menu--filter-by (lambda (pkg-desc) - (string-match-p status (package-desc-status pkg-desc))) - (format "status:%s" status)))) + (let ((status-list + (if (listp status) + status + (split-string status ",")))) + (package-menu--filter-by + (lambda (pkg-desc) + (member (package-desc-status pkg-desc) status-list)) + (format "status:%s" (string-join status-list ",")))))) (defun package-menu-filter-by-version (version predicate) "Filter the \"*Packages*\" buffer by VERSION and PREDICATE. @@ -3940,7 +4009,9 @@ If VERSION is nil or the empty string, show all packages." ('< "< less than") ('> "> greater than")) "): ")) - choice)))) + choice))) + package-menu-mode) + (package--ensure-package-menu-mode) (unless (equal predicate 'quit) (if (or (not version) (string-empty-p version)) (package-menu--generate t t) @@ -3958,7 +4029,7 @@ If VERSION is nil or the empty string, show all packages." (defun package-menu-filter-marked () "Filter \"*Packages*\" buffer by non-empty upgrade mark. Unlike other filters, this leaves the marks intact." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (widen) (let (found-entries mark pkg-id entry marks) @@ -3986,7 +4057,7 @@ Unlike other filters, this leaves the marks intact." (defun package-menu-filter-upgradable () "Filter \"*Packages*\" buffer to show only upgradable packages." - (interactive) + (interactive nil package-menu-mode) (let ((pkgs (mapcar #'car (package-menu--find-upgrades)))) (package-menu--filter-by (lambda (pkg) @@ -3995,7 +4066,7 @@ Unlike other filters, this leaves the marks intact." (defun package-menu-clear-filter () "Clear any filter currently applied to the \"*Packages*\" buffer." - (interactive) + (interactive nil package-menu-mode) (package--ensure-package-menu-mode) (package-menu--generate t t)) @@ -4016,10 +4087,7 @@ The return value is a string (or nil in case we can't find it)." ;; the version at compile time and hardcodes it into the .elc file! (declare (pure t)) ;; Hack alert! - (let ((file - (or (if (boundp 'byte-compile-current-file) byte-compile-current-file) - load-file-name - buffer-file-name))) + (let ((file (or (macroexp-file-name) buffer-file-name))) (cond ((null file) nil) ;; Packages are normally installed into directories named "<pkg>-<vers>", @@ -4088,6 +4156,10 @@ activations need to be changed, such as when `package-load-list' is modified." (package-activated-list ()) ;; Make sure we can load this file without load-source-file-function. (coding-system-for-write 'emacs-internal) + ;; Ensure that `pp' and `prin1-to-string' calls further down + ;; aren't truncated. + (print-length nil) + (print-level nil) (Info-directory-list '(""))) (dolist (elt package-alist) (condition-case err @@ -4106,7 +4178,8 @@ activations need to be changed, such as when `package-load-list' is modified." (let ((load-suffixes '(".el" ".elc"))) (locate-library (package--autoloads-file-name pkg)))) (pfile (prin1-to-string file))) - (insert "(let ((load-file-name " pfile "))\n") + (insert "(let ((load-true-file-name " pfile ")\ +(load-file-name " pfile "))\n") (insert-file-contents file) ;; Fixup the special #$ reader form and throw away comments. (while (re-search-forward "#\\$\\|^;\\(.*\n\\)" nil 'move) @@ -4155,6 +4228,22 @@ beginning of the line." (package-version-join (package-desc-version package-desc)) (package-desc-summary package-desc)))) +(defun package-browse-url (desc &optional secondary) + "Open the home page of the package under point in a browser. +`browse-url' is used to determine the browser to be used. +If SECONDARY (interactively, the prefix), use the secondary browser." + (interactive (list (tabulated-list-get-id) + current-prefix-arg) + package-menu-mode) + (unless desc + (user-error "No package here")) + (let ((url (cdr (assoc :url (package-desc-extras desc))))) + (unless url + (user-error "No home page for %s" (package-desc-name desc))) + (if secondary + (funcall browse-url-secondary-browser-function url) + (browse-url url)))) + ;;;; Introspection (defun package-get-descriptor (pkg-name) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index ec746fa4747..63b187be02b 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -27,19 +27,10 @@ ;; Todo: -;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't -;; use x, because x is bound separately for the equality constraint -;; (as well as any pred/guard) and for the body, so uses at one place don't -;; count for the other. -;; - provide ways to extend the set of primitives, with some kind of -;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) -;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). -;; But better would be if we could define new ways to match by having the -;; extension provide its own `pcase--split-<foo>' thingy. -;; - along these lines, provide patterns to match CL structs. +;; - Allow to provide new `pcase--split-<foo>' thingy. ;; - provide something like (setq VAR) so a var can be set rather than ;; let-bound. -;; - provide a way to fallthrough to subsequent cases +;; - provide a way to continue matching to subsequent cases ;; (e.g. Like Racket's (=> ID). ;; - try and be more clever to reduce the size of the decision tree, and ;; to reduce the number of leaves that need to be turned into functions: @@ -71,48 +62,37 @@ (defvar pcase--dontwarn-upats '(pcase--dontcare)) -(def-edebug-spec - pcase-PAT - (&or symbolp - ("or" &rest pcase-PAT) - ("and" &rest pcase-PAT) - ("guard" form) - ("let" pcase-PAT form) - ("pred" pcase-FUN) - ("app" pcase-FUN pcase-PAT) - pcase-MACRO - sexp)) - -(def-edebug-spec - pcase-FUN - (&or lambda-expr - ;; Punt on macros/special forms. - (functionp &rest form) - sexp)) - -;; See bug#24717 -(put 'pcase-MACRO 'edebug-form-spec 'pcase--edebug-match-macro) +(def-edebug-elem-spec 'pcase-PAT + '(&or (&interpose symbolp pcase--edebug-match-pat-args) sexp)) + +(def-edebug-elem-spec 'pcase-FUN + '(&or lambda-expr + ;; Punt on macros/special forms. + (functionp &rest form) + sexp)) ;; Only called from edebug. -(declare-function get-edebug-spec "edebug" (symbol)) -(declare-function edebug-match "edebug" (cursor specs)) +(declare-function edebug-get-spec "edebug" (symbol)) +(defun pcase--edebug-match-pat-args (head pf) + ;; (cl-assert (null (cdr head))) + (setq head (car head)) + (or (alist-get head '((quote sexp) + (or &rest pcase-PAT) + (and &rest pcase-PAT) + (guard form) + (pred &or ("not" pcase-FUN) pcase-FUN) + (app pcase-FUN pcase-PAT))) + (let ((me (pcase--get-macroexpander head))) + (funcall pf (and me (symbolp me) (edebug-get-spec me)))))) (defun pcase--get-macroexpander (s) "Return the macroexpander for pcase pattern head S, or nil" (get s 'pcase-macroexpander)) -(defun pcase--edebug-match-macro (cursor) - (let (specs) - (mapatoms - (lambda (s) - (let ((m (pcase--get-macroexpander s))) - (when (and m (get-edebug-spec m)) - (push (cons (symbol-name s) (get-edebug-spec m)) - specs))))) - (edebug-match cursor (cons '&or specs)))) - ;;;###autoload (defmacro pcase (exp &rest cases) + ;; FIXME: Add some "global pattern" to wrap every case? + ;; Could be used to wrap all cases in a ` "Evaluate EXP to get EXPVAL; try passing control to one of CASES. CASES is a list of elements of the form (PATTERN CODE...). For the first CASE whose PATTERN \"matches\" EXPVAL, @@ -227,6 +207,7 @@ If EXP fails to match any of the patterns in CASES, an error is signaled." (pcase--dontwarn-upats (cons x pcase--dontwarn-upats))) (pcase--expand ;; FIXME: Could we add the FILE:LINE data in the error message? + ;; FILE is available from `macroexp-file-name'. exp (append cases `((,x (error "No clause matching `%S'" ,x))))))) ;;;###autoload @@ -336,86 +317,168 @@ of the elements of LIST is performed as if by `pcase-let'. (pcase-let* ((,(car spec) ,tmpvar)) ,@body))))) +;;;###autoload +(defmacro pcase-setq (pat val &rest args) + "Assign values to variables by destructuring with `pcase'. +PATTERNS are normal `pcase' patterns, and VALUES are expression. + +Evaluation happens sequentially as in `setq' (not in parallel). + +An example: (pcase-setq `((,a) [(,b)]) '((1) [(2)])) + +VAL is presumed to match PAT. Failure to match may signal an error or go +undetected, binding variables to arbitrary values, such as nil. + +\(fn PATTERNS VALUE PATTERN VALUES ...)" + (declare (debug (&rest [pcase-PAT form]))) + (cond + (args + (let ((arg-length (length args))) + (unless (= 0 (mod arg-length 2)) + (signal 'wrong-number-of-arguments + (list 'pcase-setq (+ 2 arg-length))))) + (let ((result)) + (while args + (push `(pcase-setq ,(pop args) ,(pop args)) + result)) + `(progn + (pcase-setq ,pat ,val) + ,@(nreverse result)))) + ((pcase--trivial-upat-p pat) + `(setq ,pat ,val)) + (t + (pcase-compile-patterns + val + `((,pat + . ,(lambda (varvals &rest _) + `(setq ,@(mapcan (lambda (varval) + (let ((var (car varval)) + (val (cadr varval))) + (list var val))) + varvals)))) + (pcase--dontcare . ignore)))))) (defun pcase--trivial-upat-p (upat) (and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) -(defun pcase--expand (exp cases) - ;; (message "pid=%S (pcase--expand %S ...hash=%S)" - ;; (emacs-pid) exp (sxhash cases)) +(defun pcase-compile-patterns (exp cases) + "Compile the set of patterns in CASES. +EXP is the expression that will be matched against the patterns. +CASES is a list of elements (PAT . CODEGEN) +where CODEGEN is a function that returns the code to use when +PAT matches. That code has to be in the form of a cons cell. + +CODEGEN will be called with at least 2 arguments, VARVALS and COUNT. +VARVALS is a list of elements of the form (VAR VAL . RESERVED) where VAR +is a variable bound by the pattern and VAL is a duplicable expression +that returns the value this variable should be bound to. +If the pattern PAT uses `or', CODEGEN may be called multiple times, +in which case it may want to generate the code differently to avoid +a potential code explosion. For this reason the COUNT argument indicates +how many time this CODEGEN is called." (macroexp-let2 macroexp-copyable-p val exp - (let* ((defs ()) - (seen '()) - (codegen - (lambda (code vars) - (let ((vars (macroexp--fgrep vars code)) - (prev (assq code seen))) - (if (not prev) - (let ((res (pcase-codegen code vars))) - (push (list code vars res) seen) - res) - ;; Since we use a tree-based pattern matching - ;; technique, the leaves (the places that contain the - ;; code to run once a pattern is matched) can get - ;; copied a very large number of times, so to avoid - ;; code explosion, we need to keep track of how many - ;; times we've used each leaf and move it - ;; to a separate function if that number is too high. - ;; - ;; We've already used this branch. So it is shared. - (let* ((code (car prev)) (cdrprev (cdr prev)) - (prevvars (car cdrprev)) (cddrprev (cdr cdrprev)) - (res (car cddrprev))) - (unless (symbolp res) - ;; This is the first repeat, so we have to move - ;; the branch to a separate function. - (let ((bsym - (make-symbol (format "pcase-%d" (length defs))))) - (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) - defs) - (setcar res 'funcall) - (setcdr res (cons bsym (mapcar #'cdr prevvars))) - (setcar (cddr prev) bsym) - (setq res bsym))) - (setq vars (copy-sequence vars)) - (let ((args (mapcar (lambda (pa) - (let ((v (assq (car pa) vars))) - (setq vars (delq v vars)) - (cdr v))) - prevvars))) - ;; If some of `vars' were not found in `prevvars', that's - ;; OK it just means those vars aren't present in all - ;; branches, so they can be used within the pattern - ;; (e.g. by a `guard/let/pred') but not in the branch. - ;; FIXME: But if some of `prevvars' are not in `vars' we - ;; should remove them from `prevvars'! - `(funcall ,res ,@args))))))) - (used-cases ()) + (let* ((seen '()) + (phcounter 0) (main (pcase--u - (mapcar (lambda (case) - `(,(pcase--match val (pcase--macroexpand (car case))) - ,(lambda (vars) - (unless (memq case used-cases) - ;; Keep track of the cases that are used. - (push case used-cases)) - (funcall - (if (pcase--small-branch-p (cdr case)) - ;; Don't bother sharing multiple - ;; occurrences of this leaf since it's small. - (lambda (code vars) - (pcase-codegen code - (macroexp--fgrep vars code))) - codegen) - (cdr case) - vars)))) - cases)))) + (mapcar + (lambda (case) + `(,(pcase--match val (pcase--macroexpand (car case))) + ,(lambda (vars) + (let ((prev (assq case seen))) + (unless prev + ;; Keep track of the cases that are used. + (push (setq prev (list case)) seen)) + ;; Put a counter in the cdr just so that not + ;; all branches look identical (to avoid things + ;; like `macroexp--if' optimizing them too + ;; optimistically). + (let ((ph (cons 'pcase--placeholder + (setq phcounter (1+ phcounter))))) + (setcdr prev (cons (cons vars ph) (cdr prev))) + ph))))) + cases)))) + ;; Take care of the place holders now. + (dolist (branch seen) + (let ((codegen (cdar branch)) + (uses (cdr branch))) + ;; Find all the vars that are in scope (the union of the + ;; vars provided in each use case). + (let* ((allvarinfo '()) + (_ (dolist (use uses) + (dolist (v (car use)) + (let ((vi (assq (car v) allvarinfo))) + (if vi + (if (cddr v) (setcdr vi 'used)) + (push (cons (car v) (cddr v)) allvarinfo)))))) + (allvars (mapcar #'car allvarinfo))) + (dolist (use uses) + (let* ((vars (car use)) + (varvals + (mapcar (lambda (v) + `(,v ,(cadr (assq v vars)) + ,(cdr (assq v allvarinfo)))) + allvars)) + (placeholder (cdr use)) + (code (funcall codegen varvals (length uses)))) + ;; (cl-assert (eq (car placeholder) 'pcase--placeholder)) + (setcar placeholder (car code)) + (setcdr placeholder (cdr code))))))) (dolist (case cases) - (unless (or (memq case used-cases) + (unless (or (assq case seen) (memq (car case) pcase--dontwarn-upats)) - (message "pcase pattern %S shadowed by previous pcase pattern" - (car case)))) - (macroexp-let* defs main)))) + (setq main + (macroexp-warn-and-return + (format "pcase pattern %S shadowed by previous pcase pattern" + (car case)) + main)))) + main))) + +(defun pcase--expand (exp cases) + ;; (message "pid=%S (pcase--expand %S ...hash=%S)" + ;; (emacs-pid) exp (sxhash cases)) + (let* ((defs ()) + (codegen + (lambda (code) + (if (member code '(nil (nil) ('nil))) + (lambda (&rest _) ''nil) + (let ((bsym ())) + (lambda (varvals count &rest _) + (let* ((ignored-vars + (delq nil (mapcar (lambda (vv) (if (nth 2 vv) (car vv))) + varvals))) + (ignores (if ignored-vars + `((ignore . ,ignored-vars))))) + ;; Since we use a tree-based pattern matching + ;; technique, the leaves (the places that contain the + ;; code to run once a pattern is matched) can get + ;; copied a very large number of times, so to avoid + ;; code explosion, we need to keep track of how many + ;; times we've used each leaf and move it + ;; to a separate function if that number is too high. + (if (or (< count 2) (pcase--small-branch-p code)) + `(let ,(mapcar (lambda (vv) (list (car vv) (cadr vv))) + varvals) + ;; Try and silence some of the most common + ;; spurious "unused var" warnings. + ,@ignores + ,@code) + ;; Several occurrence of this non-small branch in + ;; the output. + (unless bsym + (setq bsym (make-symbol + (format "pcase-%d" (length defs)))) + (push `(,bsym (lambda ,(mapcar #'car varvals) + ,@ignores ,@code)) + defs)) + `(funcall ,bsym ,@(mapcar #'cadr varvals))))))))) + (main + (pcase-compile-patterns + exp + (mapcar (lambda (case) + (cons (car case) (funcall codegen (cdr case)))) + cases)))) + (macroexp-let* defs main))) (defun pcase--macroexpand (pat) "Expands all macro-patterns in PAT." @@ -452,7 +515,13 @@ for the result of evaluating EXP (first arg to `pcase'). (decl (assq 'declare body))) (when decl (setq body (remove decl body))) `(progn - (defun ,fsym ,args ,@body) + ;; FIXME: We use `eval-and-compile' here so that the pcase macro can be + ;; used in the same file where it's defined, but ideally, we should + ;; handle this using something similar to `overriding-plist-environment' + ;; but for `symbol-function' slots so compiling a file doesn't have the + ;; side-effect of defining the function. + (eval-and-compile + (defun ,fsym ,args ,@body)) (define-symbol-prop ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl))) (define-symbol-prop ',name 'pcase-macroexpander #',fsym)))) @@ -468,15 +537,6 @@ for the result of evaluating EXP (first arg to `pcase'). (t `(match ,val . ,upat)))) -(defun pcase-codegen (code vars) - ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding - ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy - ;; codegen from later metamorphosing this let into a funcall. - (if vars - `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) - ,@code) - `(progn ,@code))) - (defun pcase--small-branch-p (code) (and (= 1 (length code)) (or (not (consp (car code))) @@ -489,8 +549,10 @@ for the result of evaluating EXP (first arg to `pcase'). ;; the depth of the generated tree. (defun pcase--if (test then else) (cond - ((eq else :pcase--dontcare) then) - ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen? + ((eq else :pcase--dontcare) `(progn (ignore ,test) ,then)) + ;; This happens very rarely. Known case: + ;; (pcase EXP ((and 1 pcase--dontcare) FOO)) + ((eq then :pcase--dontcare) `(progn (ignore ,test) ,else)) (t (macroexp-if test then else)))) ;; Note about MATCH: @@ -515,11 +577,14 @@ for the result of evaluating EXP (first arg to `pcase'). "Expand matcher for rules BRANCHES. Each BRANCH has the form (MATCH CODE . VARS) where CODE is the code generator for that branch. -VARS is the set of vars already bound by earlier matches. MATCH is the pattern that needs to be matched, of the form: (match VAR . PAT) (and MATCH ...) - (or MATCH ...)" + (or MATCH ...) +VARS is the set of vars already bound by earlier matches. +It is a list of (NAME VAL . USED) where NAME is the variable's symbol, +VAL is the expression to which it should be bound and USED is a boolean +recording whether the var has been referenced by earlier parts of the match." (when (setq branches (delq nil branches)) (let* ((carbranch (car branches)) (match (car carbranch)) (cdarbranch (cdr carbranch)) @@ -662,7 +727,7 @@ MATCH is the pattern that needs to be matched, of the form: (defun pcase--split-pred (vars upat pat) "Indicate the overlap or mutual-exclusion between UPAT and PAT. -More specifically retuns a pair (A . B) where A indicates whether PAT +More specifically returns a pair (A . B) where A indicates whether PAT can match when UPAT has matched, and B does the same for the case where UPAT failed to match. A and B can be one of: @@ -679,7 +744,7 @@ A and B can be one of: ;; run, but we don't have the environment in which `pat' will ;; run, so we can't do a reliable verification. But let's try ;; and catch at least the easy cases such as (bug#14773). - (not (macroexp--fgrep (mapcar #'car vars) (cadr upat))))) + (not (macroexp--fgrep vars (cadr upat))))) '(:pcase--succeed . :pcase--fail)) ;; In case PAT is of the form (pred (not PRED)) ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat)))) @@ -766,8 +831,11 @@ A and B can be one of: ((symbolp fun) `(,fun ,arg)) ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars))) (t - (let* (;; `env' is an upper bound on the bindings we need. - (env (mapcar (lambda (x) (list (car x) (cdr x))) + (let* (;; `env' is hopefully an upper bound on the bindings we need, + ;; FIXME: See bug#46786 for a counter example :-( + (env (mapcar (lambda (x) + (setcdr (cdr x) 'used) + (list (car x) (cadr x))) (macroexp--fgrep vars fun))) (call (progn (when (assq arg env) @@ -775,7 +843,7 @@ A and B can be one of: (let ((newsym (gensym "x"))) (push (list newsym arg) env) (setq arg newsym))) - (if (functionp fun) + (if (or (functionp fun) (not (consp fun))) `(funcall #',fun ,arg) `(,@fun ,arg))))) (if (null env) @@ -788,10 +856,12 @@ A and B can be one of: (defun pcase--eval (exp vars) "Build an expression that will evaluate EXP." (let* ((found (assq exp vars))) - (if found (cdr found) + (if found (progn (setcdr (cdr found) 'used) (cadr found)) (let* ((env (macroexp--fgrep vars exp))) (if env - (macroexp-let* (mapcar (lambda (x) (list (car x) (cdr x))) + (macroexp-let* (mapcar (lambda (x) + (setcdr (cdr x) 'used) + (list (car x) (cadr x))) env) exp) exp))))) @@ -804,7 +874,7 @@ Otherwise, it defers to REST which is a list of branches of the form \(ELSE-MATCH ELSE-CODE . ELSE-VARS)." ;; Depending on the order in which we choose to check each of the MATCHES, ;; the resulting tree may be smaller or bigger. So in general, we'd want - ;; to be careful to chose the "optimal" order. But predicate + ;; to be careful to choose the "optimal" order. But predicate ;; patterns make this harder because they create dependencies ;; between matches. So we don't bother trying to reorder anything. (cond @@ -865,7 +935,7 @@ Otherwise, it defers to REST which is a list of branches of the form ((memq upat '(t _)) (let ((code (pcase--u1 matches code vars rest))) (if (eq upat '_) code - (macroexp--warn-and-return + (macroexp-warn-and-return "Pattern t is deprecated. Use `_' instead" code)))) ((eq upat 'pcase--dontcare) :pcase--dontcare) @@ -883,12 +953,14 @@ Otherwise, it defers to REST which is a list of branches of the form (pcase--u else-rest)))) ((and (symbolp upat) upat) (pcase--mark-used sym) - (if (not (assq upat vars)) - (pcase--u1 matches code (cons (cons upat sym) vars) rest) - ;; Non-linear pattern. Turn it into an `eq' test. - (pcase--u1 (cons `(match ,sym . (pred (eql ,(cdr (assq upat vars))))) - matches) - code vars rest))) + (let ((v (assq upat vars))) + (if (not v) + (pcase--u1 matches code (cons (list upat sym) vars) rest) + ;; Non-linear pattern. Turn it into an `eq' test. + (setcdr (cdr v) 'used) + (pcase--u1 (cons `(match ,sym . (pred (eql ,(cadr v)))) + matches) + code vars rest)))) ((eq (car-safe upat) 'app) ;; A upat of the form (app FUN PAT) (pcase--mark-used sym) @@ -946,14 +1018,13 @@ Otherwise, it defers to REST which is a list of branches of the form (t (error "Unknown pattern `%S'" upat))))) (t (error "Incorrect MATCH %S" (car matches))))) -(def-edebug-spec - pcase-QPAT +(def-edebug-elem-spec 'pcase-QPAT ;; Cf. edebug spec for `backquote-form' in edebug.el. - (&or ("," pcase-PAT) - (pcase-QPAT [&rest [¬ ","] pcase-QPAT] - . [&or nil pcase-QPAT]) - (vector &rest pcase-QPAT) - sexp)) + '(&or ("," pcase-PAT) + (pcase-QPAT [&rest [¬ ","] pcase-QPAT] + . [&or nil pcase-QPAT]) + (vector &rest pcase-QPAT) + sexp)) (pcase-defmacro \` (qpat) "Backquote-style pcase patterns: \\=`QPAT @@ -992,8 +1063,8 @@ The predicate is the logical-AND of: (nreverse upats)))) ((consp qpat) `(and (pred consp) - (app car ,(list '\` (car qpat))) - (app cdr ,(list '\` (cdr qpat))))) + (app car-safe ,(list '\` (car qpat))) + (app cdr-safe ,(list '\` (cdr qpat))))) ((or (stringp qpat) (numberp qpat) (symbolp qpat)) `',qpat) ;; In all other cases just raise an error so we can't break ;; backward compatibility when adding \` support for other @@ -1002,7 +1073,13 @@ The predicate is the logical-AND of: (pcase-defmacro let (pat expr) "Matches if EXPR matches PAT." + (declare (debug (pcase-PAT form))) `(app (lambda (_) ,expr) ,pat)) +;; (pcase-defmacro guard (expr) +;; "Matches if EXPR is non-nil." +;; (declare (debug (form))) +;; `(pred (lambda (_) ,expr))) + (provide 'pcase) ;;; pcase.el ends here diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index ef4c9603284..0bf774dffd8 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -127,8 +127,9 @@ Also add the value to the front of the list in the variable `values'." (interactive (list (read--expression "Eval: "))) (message "Evaluating...") - (push (eval expression lexical-binding) values) - (pp-display-expression (car values) "*Pp Eval Output*")) + (let ((result (eval expression lexical-binding))) + (values--store-value result) + (pp-display-expression result "*Pp Eval Output*"))) ;;;###autoload (defun pp-macroexpand-expression (expression) @@ -138,7 +139,7 @@ Also add the value to the front of the list in the variable `values'." (pp-display-expression (macroexpand-1 expression) "*Pp Macroexpand Output*")) (defun pp-last-sexp () - "Read sexp before point. Ignores leading comment characters." + "Read sexp before point. Ignore leading comment characters." (with-syntax-table emacs-lisp-mode-syntax-table (let ((pt (point))) (save-excursion @@ -158,7 +159,7 @@ Also add the value to the front of the list in the variable `values'." ;;;###autoload (defun pp-eval-last-sexp (arg) "Run `pp-eval-expression' on sexp before point. -With argument, pretty-print output into current buffer. +With ARG, pretty-print output into current buffer. Ignores leading comment characters." (interactive "P") (if arg @@ -171,7 +172,7 @@ Ignores leading comment characters." ;;;###autoload (defun pp-macroexpand-last-sexp (arg) "Run `pp-macroexpand-expression' on sexp before point. -With argument, pretty-print output into current buffer. +With ARG, pretty-print output into current buffer. Ignores leading comment characters." (interactive "P") (if arg diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el index 0905ac608bb..a529ed025d6 100644 --- a/lisp/emacs-lisp/radix-tree.el +++ b/lisp/emacs-lisp/radix-tree.el @@ -194,14 +194,13 @@ If not found, return nil." "Return an alist of all bindings in TREE for prefixes of STRING." (radix-tree--prefixes tree string 0 nil)) -(eval-and-compile - (pcase-defmacro radix-tree-leaf (vpat) - "Pattern which matches a radix-tree leaf. +(pcase-defmacro radix-tree-leaf (vpat) + "Pattern which matches a radix-tree leaf. The pattern VPAT is matched against the leaf's carried value." - ;; We used to use `(pred atom)', but `pcase' doesn't understand that - ;; `atom' is equivalent to the negation of `consp' and hence generates - ;; suboptimal code. - `(or `(t . ,,vpat) (and (pred (not consp)) ,vpat)))) + ;; We used to use `(pred atom)', but `pcase' doesn't understand that + ;; `atom' is equivalent to the negation of `consp' and hence generates + ;; suboptimal code. + `(or `(t . ,,vpat) (and (pred (not consp)) ,vpat))) (defun radix-tree-iter-subtrees (tree fun) "Apply FUN to every immediate subtree of radix TREE. @@ -241,7 +240,7 @@ PREFIX is only used internally." (declare-function map-apply "map" (function map)) (defun radix-tree-from-map (map) - ;; Aka (cl-defmethod map-into (map (type (eql radix-tree)))) ...) + ;; Aka (cl-defmethod map-into (map (type (eql 'radix-tree)))) ...) (require 'map) (let ((rt nil)) (map-apply (lambda (k v) (setq rt (radix-tree-insert rt k v))) map) diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index ce8d98df807..aec438ed994 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -217,8 +217,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.") ;; Define the local "\C-c" keymap (defvar reb-mode-map - (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap))) + (let ((map (make-sparse-keymap))) (define-key map "\C-c\C-c" 'reb-toggle-case) (define-key map "\C-c\C-q" 'reb-quit) (define-key map "\C-c\C-w" 'reb-copy) @@ -228,43 +227,37 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (define-key map "\C-c\C-e" 'reb-enter-subexp-mode) (define-key map "\C-c\C-b" 'reb-change-target-buffer) (define-key map "\C-c\C-u" 'reb-force-update) - (define-key map [menu-bar reb-mode] (cons "Re-Builder" menu-map)) - (define-key menu-map [rq] - '(menu-item "Quit" reb-quit - :help "Quit the RE Builder mode")) - (define-key menu-map [div1] '(menu-item "--")) - (define-key menu-map [rt] - '(menu-item "Case sensitive" reb-toggle-case - :button (:toggle . (with-current-buffer - reb-target-buffer - (null case-fold-search))) - :help "Toggle case sensitivity of searches for RE Builder target buffer")) - (define-key menu-map [rb] - '(menu-item "Change target buffer..." reb-change-target-buffer - :help "Change the target buffer and display it in the target window")) - (define-key menu-map [rs] - '(menu-item "Change syntax..." reb-change-syntax - :help "Change the syntax used by the RE Builder")) - (define-key menu-map [div2] '(menu-item "--")) - (define-key menu-map [re] - '(menu-item "Enter subexpression mode" reb-enter-subexp-mode - :help "Enter the subexpression mode in the RE Builder")) - (define-key menu-map [ru] - '(menu-item "Force update" reb-force-update - :help "Force an update in the RE Builder target window without a match limit")) - (define-key menu-map [rn] - '(menu-item "Go to next match" reb-next-match - :help "Go to next match in the RE Builder target window")) - (define-key menu-map [rp] - '(menu-item "Go to previous match" reb-prev-match - :help "Go to previous match in the RE Builder target window")) - (define-key menu-map [div3] '(menu-item "--")) - (define-key menu-map [rc] - '(menu-item "Copy current RE" reb-copy - :help "Copy current RE into the kill ring for later insertion")) map) "Keymap used by the RE Builder.") +(easy-menu-define reb-mode-menu reb-mode-map + "Menu for the RE Builder." + '("Re-Builder" + ["Copy current RE" reb-copy + :help "Copy current RE into the kill ring for later insertion"] + "---" + ["Go to previous match" reb-prev-match + :help "Go to previous match in the RE Builder target window"] + ["Go to next match" reb-next-match + :help "Go to next match in the RE Builder target window"] + ["Force update" reb-force-update + :help "Force an update in the RE Builder target window without a match limit"] + ["Enter subexpression mode" reb-enter-subexp-mode + :help "Enter the subexpression mode in the RE Builder"] + "---" + ["Change syntax..." reb-change-syntax + :help "Change the syntax used by the RE Builder"] + ["Change target buffer..." reb-change-target-buffer + :help "Change the target buffer and display it in the target window"] + ["Case sensitive" reb-toggle-case + :style toggle + :selected (with-current-buffer reb-target-buffer + (null case-fold-search)) + :help "Toggle case sensitivity of searches for RE Builder target buffer"] + "---" + ["Quit" reb-quit + :help "Quit the RE Builder mode"])) + (define-derived-mode reb-mode nil "RE Builder" "Major mode for interactively building Regular Expressions." (setq-local blink-matching-paren nil) @@ -348,7 +341,12 @@ the regexp builder. It displays a buffer named \"*RE-Builder*\" in another window, initially containing an empty regexp. As you edit the regexp in the \"*RE-Builder*\" buffer, the -matching parts of the target buffer will be highlighted." +matching parts of the target buffer will be highlighted. + +Case-sensitivity can be toggled with \\[reb-toggle-case]. The +regexp builder supports three different forms of input which can +be set with \\[reb-change-syntax]. More options and details are +provided in the Commentary section of this library." (interactive) (if (and (string= (buffer-name) reb-buffer) (reb-mode-buffer-p)) @@ -357,18 +355,22 @@ matching parts of the target buffer will be highlighted." (reb-delete-overlays)) (setq reb-target-buffer (current-buffer) reb-target-window (selected-window)) - (select-window (or (get-buffer-window reb-buffer) - (progn - (setq reb-window-config (current-window-configuration)) - (split-window (selected-window) (- (window-height) 4))))) - (switch-to-buffer (get-buffer-create reb-buffer)) + (select-window + (or (get-buffer-window reb-buffer) + (let ((dir (if (window-parameter nil 'window-side) + 'bottom 'down))) + (setq reb-window-config (current-window-configuration)) + (display-buffer + (get-buffer-create reb-buffer) + `((display-buffer-in-direction) + (direction . ,dir) + (dedicated . t)))))) (font-lock-mode 1) (reb-initialize-buffer))) (defun reb-change-target-buffer (buf) "Change the target buffer and display it in the target window." (interactive "bSet target buffer to: ") - (let ((buffer (get-buffer buf))) (if (not buffer) (error "No such buffer") @@ -381,7 +383,6 @@ matching parts of the target buffer will be highlighted." (defun reb-force-update () "Force an update in the RE Builder target window without a match limit." (interactive) - (let ((reb-auto-match-limit nil)) (reb-update-overlays (if reb-subexp-mode reb-subexp-displayed nil)))) @@ -389,7 +390,6 @@ matching parts of the target buffer will be highlighted." (defun reb-quit () "Quit the RE Builder mode." (interactive) - (setq reb-subexp-mode nil reb-subexp-displayed nil) (reb-delete-overlays) @@ -399,7 +399,6 @@ matching parts of the target buffer will be highlighted." (defun reb-next-match () "Go to next match in the RE Builder target window." (interactive) - (reb-assert-buffer-in-window) (with-selected-window reb-target-window (if (not (re-search-forward reb-regexp (point-max) t)) @@ -411,7 +410,6 @@ matching parts of the target buffer will be highlighted." (defun reb-prev-match () "Go to previous match in the RE Builder target window." (interactive) - (reb-assert-buffer-in-window) (with-selected-window reb-target-window (let ((p (point))) @@ -426,7 +424,6 @@ matching parts of the target buffer will be highlighted." (defun reb-toggle-case () "Toggle case sensitivity of searches for RE Builder target buffer." (interactive) - (with-current-buffer reb-target-buffer (setq case-fold-search (not case-fold-search))) (reb-update-modestring) @@ -435,12 +432,11 @@ matching parts of the target buffer will be highlighted." (defun reb-copy () "Copy current RE into the kill ring for later insertion." (interactive) - (reb-update-regexp) (let ((re (with-output-to-string (print (reb-target-binding reb-regexp))))) (setq re (substring re 1 (1- (length re)))) - (setq re (replace-regexp-in-string "\n" "\\n" re nil t)) + (setq re (string-replace "\n" "\\n" re)) (kill-new re) (message "Copied regexp `%s' to kill-ring" re))) @@ -503,7 +499,6 @@ Optional argument SYNTAX must be specified if called non-interactively." (defun reb-do-update (&optional subexp) "Update matches in the RE Builder target window. If SUBEXP is non-nil mark only the corresponding sub-expressions." - (reb-assert-buffer-in-window) (reb-update-regexp) (reb-update-overlays subexp)) @@ -541,7 +536,6 @@ optional fourth argument FORCE is non-nil." (defun reb-assert-buffer-in-window () "Assert that `reb-target-buffer' is displayed in `reb-target-window'." - (if (not (eq reb-target-buffer (window-buffer reb-target-window))) (set-window-buffer reb-target-window reb-target-buffer))) @@ -560,7 +554,6 @@ optional fourth argument FORCE is non-nil." (defun reb-display-subexp (&optional subexp) "Highlight only subexpression SUBEXP in the RE Builder." (interactive) - (setq reb-subexp-displayed (or subexp (string-to-number (format "%c" last-command-event)))) (reb-update-modestring) @@ -568,7 +561,6 @@ optional fourth argument FORCE is non-nil." (defun reb-kill-buffer () "When the RE Builder buffer is killed make sure no overlays stay around." - (when (reb-mode-buffer-p) (reb-delete-overlays))) @@ -600,7 +592,6 @@ optional fourth argument FORCE is non-nil." (defun reb-insert-regexp () "Insert current RE." - (let ((re (or (reb-target-binding reb-regexp) (reb-empty-regexp)))) (cond ((eq reb-re-syntax 'read) @@ -636,7 +627,6 @@ Return t if the (cooked) expression changed." ;; And now the real core of the whole thing (defun reb-count-subexps (re) "Return number of sub-expressions in the regexp RE." - (let ((i 0) (beg 0)) (while (string-match "\\\\(" re beg) (setq i (1+ i) diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el index 96894655b45..ea27bb3c31b 100644 --- a/lisp/emacs-lisp/ring.el +++ b/lisp/emacs-lisp/ring.el @@ -248,8 +248,6 @@ If SEQ is already a ring, return it." (ring-insert-at-beginning ring (elt seq count)))) ring))) -;;; provide ourself: - (provide 'ring) ;;; ring.el ends here diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el index bedf598d442..8abe570e64b 100644 --- a/lisp/emacs-lisp/rmc.el +++ b/lisp/emacs-lisp/rmc.el @@ -26,29 +26,38 @@ (require 'seq) ;;;###autoload -(defun read-multiple-choice (prompt choices) - "Ask user a multiple choice question. -PROMPT should be a string that will be displayed as the prompt. - -CHOICES is a list of (KEY NAME [DESCRIPTION]). KEY is a -character to be entered. NAME is a short name for the entry to -be displayed while prompting (if there's room, it might be -shortened). DESCRIPTION is an optional longer explanation that -will be displayed in a help buffer if the user requests more -help. +(defun read-multiple-choice (prompt choices &optional help-string) + "Ask user to select an entry from CHOICES, promting with PROMPT. +This function allows to ask the user a multiple-choice question. + +CHOICES should be a list of the form (KEY NAME [DESCRIPTION]). +KEY is a character the user should type to select the entry. +NAME is a short name for the entry to be displayed while prompting +\(if there's no room, it might be shortened). +DESCRIPTION is an optional longer description of the entry; it will +be displayed in a help buffer if the user requests more help. This +help description has a fixed format in columns. For greater +flexibility, instead of passing a DESCRIPTION, the caller can pass +the optional argument HELP-STRING. This argument is a string that +should contain a more detailed description of all of the possible +choices. `read-multiple-choice' will display that description in a +help buffer if the user requests that. This function translates user input into responses by consulting the bindings in `query-replace-map'; see the documentation of -that variable for more information. In this case, the useful -bindings are `recenter', `scroll-up', and `scroll-down'. If the -user enters `recenter', `scroll-up', or `scroll-down' responses, -perform the requested window recentering or scrolling and ask -again. - -When `use-dialog-box' is t (the default), this function can pop -up a dialog window to collect the user input. That functionality -requires `display-popup-menus-p' to return t. Otherwise, a -text dialog will be used. +that variable for more information. The relevant bindings for the +purposes of this function are `recenter', `scroll-up', `scroll-down', +and `edit'. +If the user types the `recenter', `scroll-up', or `scroll-down' +responses, the function performs the requested window recentering or +scrolling, and then asks the question again. If the user enters `edit', +the function starts a recursive edit. When the user exit the recursive +edit, the multiple-choice prompt gains focus again. + +When `use-dialog-box' is t (the default), and the command using this +function was invoked via the mouse, this function pops up a GUI dialog +to collect the user input, but only if Emacs is capable of using GUI +dialogs. Otherwise, the function will always use text-mode dialogs. The return value is the matching entry from the CHOICES list. @@ -133,6 +142,13 @@ Usage example: (ignore-errors (scroll-other-window)) t) ((eq answer 'scroll-other-window-down) (ignore-errors (scroll-other-window-down)) t) + ((eq answer 'edit) + (save-match-data + (save-excursion + (message "%s" + (substitute-command-keys + "Recursive edit; type \\[exit-recursive-edit] to return to help screen")) + (recursive-edit)))) (t tchar))) (when (eq tchar t) (setq wrong-char nil @@ -141,57 +157,61 @@ Usage example: ;; help messages. (when (and (not (eq tchar nil)) (not (assq tchar choices))) - (setq wrong-char (not (memq tchar '(?? ?\C-h))) + (setq wrong-char (not (memq tchar `(?? ,help-char))) tchar nil) (when wrong-char (ding)) - (with-help-window (setq buf (get-buffer-create - "*Multiple Choice Help*")) - (with-current-buffer buf - (erase-buffer) - (pop-to-buffer buf) - (insert prompt "\n\n") - (let* ((columns (/ (window-width) 25)) - (fill-column 21) - (times 0) - (start (point))) - (dolist (elem choices) - (goto-char start) - (unless (zerop times) - (if (zerop (mod times columns)) - ;; Go to the next "line". - (goto-char (setq start (point-max))) - ;; Add padding. - (while (not (eobp)) - (end-of-line) - (insert (make-string (max (- (* (mod times columns) - (+ fill-column 4)) - (current-column)) - 0) - ?\s)) - (forward-line 1)))) - (setq times (1+ times)) - (let ((text - (with-temp-buffer - (insert (format - "%c: %s\n" - (car elem) - (cdr (assq (car elem) altered-names)))) - (fill-region (point-min) (point-max)) - (when (nth 2 elem) - (let ((start (point))) - (insert (nth 2 elem)) - (unless (bolp) - (insert "\n")) - (fill-region start (point-max)))) - (buffer-string)))) + (setq buf (get-buffer-create "*Multiple Choice Help*")) + (if (stringp help-string) + (with-help-window buf + (with-current-buffer buf + (insert help-string))) + (with-help-window buf + (with-current-buffer buf + (erase-buffer) + (pop-to-buffer buf) + (insert prompt "\n\n") + (let* ((columns (/ (window-width) 25)) + (fill-column 21) + (times 0) + (start (point))) + (dolist (elem choices) (goto-char start) - (dolist (line (split-string text "\n")) - (end-of-line) - (if (bolp) - (insert line "\n") - (insert line)) - (forward-line 1))))))))))) + (unless (zerop times) + (if (zerop (mod times columns)) + ;; Go to the next "line". + (goto-char (setq start (point-max))) + ;; Add padding. + (while (not (eobp)) + (end-of-line) + (insert (make-string (max (- (* (mod times columns) + (+ fill-column 4)) + (current-column)) + 0) + ?\s)) + (forward-line 1)))) + (setq times (1+ times)) + (let ((text + (with-temp-buffer + (insert (format + "%c: %s\n" + (car elem) + (cdr (assq (car elem) altered-names)))) + (fill-region (point-min) (point-max)) + (when (nth 2 elem) + (let ((start (point))) + (insert (nth 2 elem)) + (unless (bolp) + (insert "\n")) + (fill-region start (point-max)))) + (buffer-string)))) + (goto-char start) + (dolist (line (split-string text "\n")) + (end-of-line) + (if (bolp) + (insert line "\n") + (insert line)) + (forward-line 1)))))))))))) (when (buffer-live-p buf) (kill-buffer buf)) (assq tchar choices))) diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index b29b870061d..071d390f0e4 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -890,7 +890,7 @@ Return (REGEXP . PRECEDENCE)." (* (or (seq "[:" (+ (any "a-z")) ":]") (not (any "]")))) "]") - anything + (not (any "*+?^$[\\")) (seq "\\" (or anything (seq (any "sScC_") anything) @@ -1210,7 +1210,7 @@ unmatchable Never match anything at all. CHARCLASS Match a character from a character class. One of: alpha, alphabetic, letter Alphabetic characters (defined by Unicode). alnum, alphanumeric Alphabetic or decimal digit chars (Unicode). - digit numeric, num 0-9. + digit, numeric, num 0-9. xdigit, hex-digit, hex 0-9, A-F, a-f. cntrl, control ASCII codes 0-31. blank Horizontal whitespace (Unicode). @@ -1418,6 +1418,12 @@ into a plain rx-expression, collecting names into `rx--pcase-vars'." (cons head (mapcar #'rx--pcase-transform rest))) (_ rx))) +(defun rx--reduce-right (f l) + "Right-reduction on L by F. L must be non-empty." + (if (cdr l) + (funcall f (car l) (rx--reduce-right f (cdr l))) + (car l))) + ;;;###autoload (pcase-defmacro rx (&rest regexps) "A pattern that matches strings against `rx' REGEXPS in sexp form. @@ -1437,12 +1443,37 @@ following constructs: construct." (let* ((rx--pcase-vars nil) (regexp (rx--to-expr (rx--pcase-transform (cons 'seq regexps))))) - `(and (pred (string-match ,regexp)) - ,@(let ((i 0)) - (mapcar (lambda (name) - (setq i (1+ i)) - `(app (match-string ,i) ,name)) - (reverse rx--pcase-vars)))))) + `(and (pred stringp) + ,(pcase (length rx--pcase-vars) + (0 + ;; No variables bound: a single predicate suffices. + `(pred (string-match ,regexp))) + (1 + ;; Create a match value that on a successful regexp match + ;; is the submatch value, 0 on failure. We can't use nil + ;; for failure because it is a valid submatch value. + `(app (lambda (s) + (if (string-match ,regexp s) + (match-string 1 s) + 0)) + (and ,(car rx--pcase-vars) (pred (not numberp))))) + (nvars + ;; Pack the submatches into a dotted list which is then + ;; immediately destructured into individual variables again. + ;; This is of course slightly inefficient. + ;; A dotted list is used to reduce the number of conses + ;; to create and take apart. + `(app (lambda (s) + (and (string-match ,regexp s) + ,(rx--reduce-right + (lambda (a b) `(cons ,a ,b)) + (mapcar (lambda (i) `(match-string ,i s)) + (number-sequence 1 nvars))))) + ,(list '\` + (rx--reduce-right + #'cons + (mapcar (lambda (name) (list '\, name)) + (reverse rx--pcase-vars)))))))))) ;; Obsolete internal symbol, used in old versions of the `flycheck' package. (define-obsolete-function-alias 'rx-submatch-n 'rx-to-string "27.1") diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 31c15fea90d..f0dc283f57d 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -93,6 +93,14 @@ name to be bound to the rest of SEQUENCE." (declare (indent 2) (debug (sexp form body))) `(pcase-let ((,(seq--make-pcase-patterns args) ,sequence)) ,@body)) + +(defmacro seq-setq (args sequence) + "Assign to the variables in ARGS the elements of SEQUENCE. + +ARGS can also include the `&rest' marker followed by a variable +name to be bound to the rest of SEQUENCE." + (declare (debug (sexp form))) + `(pcase-setq ,(seq--make-pcase-patterns args) ,sequence)) ;;; Basic seq functions that have to be implemented by new sequence types @@ -134,9 +142,10 @@ Unlike `seq-map', FUNCTION takes two arguments: the element of the sequence, and its index within the sequence." (let ((index 0)) (seq-do (lambda (elt) - (funcall function elt index) - (setq index (1+ index))) - sequence))) + (funcall function elt index) + (setq index (1+ index))) + sequence)) + nil) (cl-defgeneric seqp (object) "Return non-nil if OBJECT is a sequence, nil otherwise." @@ -146,6 +155,7 @@ the sequence, and its index within the sequence." "Return a shallow copy of SEQUENCE." (copy-sequence sequence)) +;;;###autoload (cl-defgeneric seq-subseq (sequence start &optional end) "Return the sequence of elements of SEQUENCE from START to END. END is exclusive. @@ -392,14 +402,15 @@ found or not." (setq count (+ 1 count)))) count)) -(cl-defgeneric seq-contains (sequence elt &optional testfn) - (declare (obsolete seq-contains-p "27.1")) - "Return the first element in SEQUENCE that is equal to ELT. +(with-suppressed-warnings ((obsolete seq-contains)) + (cl-defgeneric seq-contains (sequence elt &optional testfn) + "Return the first element in SEQUENCE that is equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." - (seq-some (lambda (e) - (when (funcall (or testfn #'equal) elt e) - e)) - sequence)) + (declare (obsolete seq-contains-p "27.1")) + (seq-some (lambda (e) + (when (funcall (or testfn #'equal) elt e) + e)) + sequence))) (cl-defgeneric seq-contains-p (sequence elt &optional testfn) "Return non-nil if SEQUENCE contains an element equal to ELT. @@ -429,6 +440,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." (setq index (1+ index))) nil))) +;;;###autoload (cl-defgeneric seq-uniq (sequence &optional testfn) "Return a list of the elements of SEQUENCE with duplicates removed. TESTFN is used to compare elements, or `equal' if TESTFN is nil." @@ -455,6 +467,7 @@ negative integer or 0, nil is returned." (setq sequence (seq-drop sequence n))) (nreverse result)))) +;;;###autoload (cl-defgeneric seq-intersection (sequence1 sequence2 &optional testfn) "Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2. Equality is defined by TESTFN if non-nil or by `equal' if nil." @@ -465,6 +478,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." (seq-reverse sequence1) '())) +;;;###autoload (cl-defgeneric seq-difference (sequence1 sequence2 &optional testfn) "Return a list of the elements that appear in SEQUENCE1 but not in SEQUENCE2. Equality is defined by TESTFN if non-nil or by `equal' if nil." diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index c1d05941239..02f2ad3d816 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -115,9 +115,12 @@ See the documentation for `list-load-path-shadows' for further information." ;; FILE now contains the current file name, with no suffix. (unless (or (member file files-seen-this-dir) ;; Ignore these files. - (member file (list "subdirs" "leim-list" - (file-name-sans-extension - dir-locals-file)))) + (member file + (list "subdirs" "leim-list" + (file-name-sans-extension dir-locals-file) + (concat + (file-name-sans-extension dir-locals-file) + "-2")))) ;; File has not been seen yet in this directory. ;; This test prevents us declaring that XXX.el shadows ;; XXX.elc (or vice-versa) when they are in the same directory. diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 39e69f5aab9..7d4a69f42a9 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -32,13 +32,10 @@ "Short documentation." :group 'lisp) -(defface shortdoc-separator - '((((class color) (background dark)) - :height 0.1 :background "#505050" :extend t) - (((class color) (background light)) - :height 0.1 :background "#a0a0a0" :extend t) - (t :height 0.1 :inverse-video t :extend t)) - "Face used to separate sections.") +(defface shortdoc-heading + '((t :inherit variable-pitch :height 1.3 :weight bold)) + "Face used for a heading." + :version "28.1") (defface shortdoc-section '((t :inherit variable-pitch)) @@ -55,8 +52,10 @@ FUNCTIONS is a list of elements on the form: :args ARGS :eval EXAMPLE-FORM :no-eval EXAMPLE-FORM + :no-eval* EXAMPLE-FORM :no-value EXAMPLE-FORM :result RESULT-FORM + :result-string RESULT-FORM :eg-result RESULT-FORM :eg-result-string RESULT-FORM) @@ -155,6 +154,10 @@ There can be any number of :example/:result elements." :eval (split-string "foo bar") :eval (split-string "|foo|bar|" "|") :eval (split-string "|foo|bar|" "|" t)) + (split-string-and-unquote + :eval (split-string-and-unquote "foo \"bar zot\"")) + (split-string-shell-command + :eval (split-string-shell-command "ls /tmp/'foo bar'")) (string-lines :eval (string-lines "foo\n\nbar") :eval (string-lines "foo\n\nbar" t)) @@ -163,15 +166,12 @@ There can be any number of :example/:result elements." (replace-regexp-in-string :eval (replace-regexp-in-string "[a-z]+" "_" "*foo*")) (string-trim - :no-manual t :args (string) :doc "Trim STRING of leading and trailing white space." :eval (string-trim " foo ")) (string-trim-left - :no-manual t :eval (string-trim-left "oofoo" "o+")) (string-trim-right - :no-manual t :eval (string-trim-right "barkss" "s+")) (string-truncate-left :no-manual t @@ -219,7 +219,7 @@ There can be any number of :example/:result elements." (string-greaterp :eval (string-greaterp "foo" "bar")) (string-version-lessp - :eval (string-lessp "foo32.png" "bar4.png")) + :eval (string-version-lessp "pic4.png" "pic32.png")) (string-prefix-p :eval (string-prefix-p "foo" "foobar")) (string-suffix-p @@ -264,14 +264,25 @@ There can be any number of :example/:result elements." :eval (file-name-extension "/tmp/foo.txt")) (file-name-sans-extension :eval (file-name-sans-extension "/tmp/foo.txt")) + (file-name-with-extension + :eval (file-name-with-extension "foo.txt" "bin") + :eval (file-name-with-extension "foo" "bin")) (file-name-base :eval (file-name-base "/tmp/foo.txt")) (file-relative-name :eval (file-relative-name "/tmp/foo" "/tmp")) (make-temp-name :eval (make-temp-name "/tmp/foo-")) + (file-name-concat + :eval (file-name-concat "/tmp/" "foo") + :eval (file-name-concat "/tmp" "foo") + :eval (file-name-concat "/tmp" "foo" "bar/" "zot") + :eval (file-name-concat "/tmp" "~")) (expand-file-name - :eval (expand-file-name "foo" "/tmp/")) + :eval (expand-file-name "foo" "/tmp/") + :eval (expand-file-name "foo" "/tmp///") + :eval (expand-file-name "foo" "/tmp/foo/.././") + :eval (expand-file-name "~" "/tmp/")) (substitute-in-file-name :eval (substitute-in-file-name "$HOME/foo")) "Directory Functions" @@ -492,9 +503,13 @@ There can be any number of :example/:result elements." (flatten-tree :eval (flatten-tree '(1 (2 3) 4))) (car - :eval (car '(one two three))) + :eval (car '(one two three)) + :eval (car '(one . two)) + :eval (car nil)) (cdr - :eval (cdr '(one two three))) + :eval (cdr '(one two three)) + :eval (cdr '(one . two)) + :eval (cdr nil)) (last :eval (last '(one two three))) (butlast @@ -611,7 +626,7 @@ There can be any number of :example/:result elements." (lax-plist-get :eval (lax-plist-get '("a" 1 "b" 2 "c" 3) "b")) (lax-plist-put - :no-eval (setq plist (plist-put plist "d" 4)) + :no-eval (setq plist (lax-plist-put plist "d" 4)) :eq-result '("a" 1 "b" 2 "c" 3 "d" 4)) (plist-member :eval (plist-member '(a 1 b 2 c 3) 'b)) @@ -623,7 +638,7 @@ There can be any number of :example/:result elements." (length> :eval (length> '(a b c) 1)) (length= - :eval (length> '(a b c) 3)) + :eval (length= '(a b c) 3)) (safe-length :eval (safe-length '(a b c)))) @@ -664,7 +679,7 @@ There can be any number of :example/:result elements." :no-eval (re-search-backward "^foo$" nil t) :eg-result 43) (looking-at-p - :no-eval (looking-at "f[0-9]") + :no-eval (looking-at-p "f[0-9]") :eg-result t) "Match Data" (match-string @@ -685,6 +700,8 @@ There can be any number of :example/:result elements." (match-substitute-replacement :no-eval (match-substitute-replacement "new") :eg-result "new") + (replace-regexp-in-region + :no-value (replace-regexp-in-region "[0-9]+" "Num \\&")) "Utilities" (regexp-quote :eval (regexp-quote "foo.*bar")) @@ -836,7 +853,7 @@ There can be any number of :example/:result elements." (point :eval (point)) (point-min - :eval (point-max)) + :eval (point-min)) (point-max :eval (point-max)) (line-beginning-position @@ -879,11 +896,61 @@ There can be any number of :example/:result elements." :no-value (erase-buffer)) (insert :no-value (insert "This string will be inserted in the buffer\n")) + (subst-char-in-region + :no-eval "(subst-char-in-region (point-min) (point-max) ?+ ?-)") + (replace-string-in-region + :no-value (replace-string-in-region "foo" "bar")) "Locking" (lock-buffer :no-value (lock-buffer "/tmp/foo")) (unlock-buffer - :no-value (lock-buffer))) + :no-value (unlock-buffer))) + +(define-short-documentation-group overlay + "Predicates" + (overlayp + :no-eval (overlayp some-overlay) + :eg-result t) + "Creation and Deletion" + (make-overlay + :args (beg end &optional buffer) + :no-eval (make-overlay 1 10) + :eg-result-string "#<overlay from 1 to 10 in *foo*>") + (delete-overlay + :no-eval (delete-overlay foo) + :eg-result t) + "Searching Overlays" + (overlays-at + :no-eval (overlays-at 15) + :eg-result-string "(#<overlay from 1 to 10 in *foo*>)") + (overlays-in + :no-eval (overlays-in 1 30) + :eg-result-string "(#<overlay from 1 to 10 in *foo*>)") + (next-overlay-change + :no-eval (next-overlay-change 1) + :eg-result 20) + (previous-overlay-change + :no-eval (previous-overlay-change 30) + :eg-result 20) + "Overlay Properties" + (overlay-start + :no-eval (overlay-start foo) + :eg-result 1) + (overlay-end + :no-eval (overlay-end foo) + :eg-result 10) + (overlay-put + :no-eval (overlay-put foo 'happy t) + :eg-result t) + (overlay-get + :no-eval (overlay-get foo 'happy) + :eg-result t) + (overlay-buffer + :no-eval (overlay-buffer foo)) + "Moving Overlays" + (move-overlay + :no-eval (move-overlay foo 5 20) + :eg-result-string "#<overlay from 5 to 20 in *foo*>")) (define-short-documentation-group process (make-process @@ -1054,7 +1121,7 @@ There can be any number of :example/:result elements." (logb :eval (logb 10.5)) (ffloor - :eval (floor 1.2)) + :eval (ffloor 1.2)) (fceiling :eval (fceiling 1.2)) (ftruncate @@ -1084,8 +1151,9 @@ There can be any number of :example/:result elements." :eval (sqrt -1))) ;;;###autoload -(defun shortdoc-display-group (group) - "Pop to a buffer with short documentation summary for functions in GROUP." +(defun shortdoc-display-group (group &optional function) + "Pop to a buffer with short documentation summary for functions in GROUP. +If FUNCTION is non-nil, place point on the entry for FUNCTION (if any)." (interactive (list (completing-read "Show summary for functions in: " (mapcar #'car shortdoc--groups)))) (when (stringp group) @@ -1107,24 +1175,26 @@ There can be any number of :example/:result elements." (insert "\n")) (insert (propertize (concat (substitute-command-keys data) "\n\n") - 'face '(variable-pitch (:height 1.3 :weight bold)) + 'face 'shortdoc-heading 'shortdoc-section t))) ;; There may be functions not yet defined in the data. ((fboundp (car data)) (when prev - (insert (propertize "\n" 'face 'shortdoc-separator))) + (insert (make-separator-line))) (setq prev t) (shortdoc--display-function data)))) (cdr (assq group shortdoc--groups)))) - (goto-char (point-min))) + (goto-char (point-min)) + (when function + (text-property-search-forward 'shortdoc-function function t) + (beginning-of-line))) (defun shortdoc--display-function (data) (let ((function (pop data)) (start-section (point)) arglist-start) ;; Function calling convention. - (insert (propertize "(" - 'shortdoc-function t)) + (insert (propertize "(" 'shortdoc-function function)) (if (plist-get data :no-manual) (insert-text-button (symbol-name function) @@ -1175,7 +1245,7 @@ function's documentation in the Info manual"))) (prin1 value (current-buffer))) (insert "\n " single-arrow " " (propertize "[it depends]" - 'face 'variable-pitch) + 'face 'shortdoc-section) "\n")) (:no-value (if (stringp value) @@ -1233,11 +1303,11 @@ Example: (let ((glist (assq group shortdoc--groups))) (unless glist (setq glist (list group)) - (setq shortdoc--groups (append shortdoc--groups (list glist)))) + (push glist shortdoc--groups)) (let ((slist (member section glist))) (unless slist (setq slist (list section)) - (setq slist (append glist slist))) + (nconc glist slist)) (while (and (cdr slist) (not (stringp (cadr slist)))) (setq slist (cdr slist))) @@ -1250,41 +1320,45 @@ Example: (define-key map (kbd "C-c C-n") 'shortdoc-next-section) (define-key map (kbd "C-c C-p") 'shortdoc-previous-section) map) - "Keymap for `shortdoc-mode'") + "Keymap for `shortdoc-mode'.") (define-derived-mode shortdoc-mode special-mode "shortdoc" - "Mode for shortdoc.") + "Mode for shortdoc." + :interactive nil) -(defmacro shortdoc--goto-section (arg sym &optional reverse) - `(progn - (unless (natnump ,arg) - (setq ,arg 1)) - (while (< 0 ,arg) - (,(if reverse - 'text-property-search-backward - 'text-property-search-forward) - ,sym t) - (setq ,arg (1- ,arg))))) +(defun shortdoc--goto-section (arg sym &optional reverse) + (unless (natnump arg) + (setq arg 1)) + (while (> arg 0) + (funcall + (if reverse 'text-property-search-backward + 'text-property-search-forward) + sym nil t t) + (setq arg (1- arg)))) (defun shortdoc-next (&optional arg) - "Move cursor to next function." - (interactive "p") + "Move cursor to the next function. +With ARG, do it that many times." + (interactive "p" shortdoc-mode) (shortdoc--goto-section arg 'shortdoc-function)) (defun shortdoc-previous (&optional arg) - "Move cursor to previous function." - (interactive "p") + "Move cursor to the previous function. +With ARG, do it that many times." + (interactive "p" shortdoc-mode) (shortdoc--goto-section arg 'shortdoc-function t) (backward-char 1)) (defun shortdoc-next-section (&optional arg) - "Move cursor to next section." - (interactive "p") + "Move cursor to the next section. +With ARG, do it that many times." + (interactive "p" shortdoc-mode) (shortdoc--goto-section arg 'shortdoc-section)) (defun shortdoc-previous-section (&optional arg) - "Move cursor to previous section." - (interactive "p") + "Move cursor to the previous section. +With ARG, do it that many times." + (interactive "p" shortdoc-mode) (shortdoc--goto-section arg 'shortdoc-section t) (forward-line -2)) diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 44be9afbfae..d775f152b36 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -57,18 +57,18 @@ ;; ;; SMIE: Weakness is Power! Auto-indentation with incomplete information ;; Stefan Monnier, <Programming> Journal 2020, volumn 5, issue 1. -;; doi: 10.22152/programming-journal.org/2020/5/1 +;; doi: 10.22152/programming-journal.org/2021/5/1 ;; A good background to understand the development (especially the parts ;; building the 2D precedence tables and then computing the precedence levels ;; from it) can be found in pages 187-194 of "Parsing techniques" by Dick Grune ;; and Ceriel Jacobs (BookBody.pdf available at -;; http://dickgrune.com/Books/PTAPG_1st_Edition/). +;; https://dickgrune.com/Books/PTAPG_1st_Edition/). ;; ;; OTOH we had to kill many chickens, read many coffee grounds, and practice ;; untold numbers of black magic spells, to come up with the indentation code. ;; Since then, some of that code has been beaten into submission, but the -;; smie-indent-keyword is still pretty obscure. +;; `smie-indent-keyword' function is still pretty obscure. ;; Conflict resolution: @@ -247,7 +247,7 @@ be either: ;; (exp (exp (or "+" "*" "=" ..) exp)). ;; Basically, make it EBNF (except for the specification of a separator in ;; the repetition, maybe). - (let* ((nts (mapcar 'car bnf)) ;Non-terminals. + (let* ((nts (mapcar #'car bnf)) ;Non-terminals. (first-ops-table ()) (last-ops-table ()) (first-nts-table ()) @@ -266,7 +266,7 @@ be either: (push resolver precs)) (t (error "Unknown resolver %S" resolver)))) (apply #'smie-merge-prec2s over - (mapcar 'smie-precs->prec2 precs)))) + (mapcar #'smie-precs->prec2 precs)))) again) (dolist (rules bnf) (let ((nt (car rules)) @@ -497,7 +497,7 @@ CSTS is a list of pairs representing arcs in a graph." res)) cycle))) (mapconcat - (lambda (elems) (mapconcat 'identity elems "=")) + (lambda (elems) (mapconcat #'identity elems "=")) (append names (list (car names))) " < "))) @@ -567,7 +567,7 @@ PREC2 is a table as returned by `smie-precs->prec2' or ;; Then eliminate trivial constraints iteratively. (let ((i 0)) (while csts - (let ((rhvs (mapcar 'cdr csts)) + (let ((rhvs (mapcar #'cdr csts)) (progress nil)) (dolist (cst csts) (unless (memq (car cst) rhvs) @@ -657,8 +657,8 @@ use syntax-tables to handle them in efficient C code.") Same calling convention as `smie-forward-token-function' except it should move backward to the beginning of the previous token.") -(defalias 'smie-op-left 'car) -(defalias 'smie-op-right 'cadr) +(defalias 'smie-op-left #'car) +(defalias 'smie-op-right #'cadr) (defun smie-default-backward-token () (forward-comment (- (point))) @@ -974,8 +974,7 @@ I.e. a good choice can be: (defcustom smie-blink-matching-inners t "Whether SMIE should blink to matching opener for inner keywords. If non-nil, it will blink not only for \"begin..end\" but also for \"if...else\"." - :type 'boolean - :group 'smie) + :type 'boolean) (defun smie-blink-matching-check (start end) (save-excursion @@ -1141,8 +1140,7 @@ OPENER is non-nil if TOKEN is an opener and nil if it's a closer." (defcustom smie-indent-basic 4 "Basic amount of indentation." - :type 'integer - :group 'smie) + :type 'integer) (defvar smie-rules-function #'ignore "Function providing the indentation rules. @@ -1189,7 +1187,7 @@ designed specifically for use in this function.") (and ;; (looking-at comment-start-skip) ;(bug#16041). (forward-comment (point-max)))))) -(defalias 'smie-rule-hanging-p 'smie-indent--hanging-p) +(defalias 'smie-rule-hanging-p #'smie-indent--hanging-p) (defun smie-indent--hanging-p () "Return non-nil if the current token is \"hanging\". A hanging keyword is one that's at the end of a line except it's not at @@ -1205,7 +1203,7 @@ the beginning of a line." (funcall smie--hanging-eolp-function) (point)))))) -(defalias 'smie-rule-bolp 'smie-indent--bolp) +(defalias 'smie-rule-bolp #'smie-indent--bolp) (defun smie-indent--bolp () "Return non-nil if the current token is the first on the line." (save-excursion (skip-chars-backward " \t") (bolp))) @@ -1409,7 +1407,9 @@ BASE-POS is the position relative to which offsets should be applied." (funcall smie-rules-function method token))) (defun smie-indent-forward-token () - "Skip token forward and return it, along with its levels." + "Skip token forward and return it, along with its levels. +Point should be between tokens when calling this function (i.e., +not in the middle of a string/comment)." (let ((tok (funcall smie-forward-token-function))) (cond ((< 0 (length tok)) (assoc tok smie-grammar)) @@ -1421,7 +1421,7 @@ BASE-POS is the position relative to which offsets should be applied." (forward-sexp 1) nil) ((eobp) nil) - (t (error "Bumped into unknown token"))))) + (t (error "Bumped into unknown token: %S" tok))))) (defun smie-indent-backward-token () "Skip token backward and return it, along with its levels." @@ -1810,9 +1810,11 @@ Each function is called with no argument, shouldn't move point, and should return either nil if it has no opinion, or an integer representing the column to which that point should be aligned, if we were to reindent it.") +(defalias 'smie--funcall #'funcall) ;Debugging/tracing convenience indirection. + (defun smie-indent-calculate () "Compute the indentation to use for point." - (run-hook-with-args-until-success 'smie-indent-functions)) + (run-hook-wrapped 'smie-indent-functions #'smie--funcall)) (defun smie-indent-line () "Indent current line using the SMIE indentation engine." @@ -2016,7 +2018,7 @@ value with which to replace it." ;; FIXME improve value-type. :type '(choice (const nil) (alist :key-type symbol)) - :initialize 'custom-initialize-set + :initialize #'custom-initialize-set :set #'smie-config--setter) (defun smie-config-local (rules) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index a4514454c0b..4204d20249d 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -127,7 +127,7 @@ This is like `if-let' but doesn't handle a VARLIST of the form \(SYMBOL SOMETHING) specially." (declare (indent 2) (debug ((&rest [&or symbolp (symbolp form) (form)]) - form body))) + body))) (if varlist `(let* ,(setq varlist (internal--build-bindings varlist)) (if ,(caar (last varlist)) @@ -146,9 +146,7 @@ This is like `when-let' but doesn't handle a VARLIST of the form "Bind variables according to VARLIST and conditionally evaluate BODY. Like `when-let*', except if BODY is empty and all the bindings are non-nil, then the result is non-nil." - (declare (indent 1) - (debug ((&rest [&or symbolp (symbolp form) (form)]) - body))) + (declare (indent 1) (debug if-let*)) (let (res) (if varlist `(let* ,(setq varlist (internal--build-bindings varlist)) @@ -174,9 +172,9 @@ As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING) like \((SYMBOL SOMETHING)). This exists for backward compatibility with an old syntax that accepted only one binding." (declare (indent 2) - (debug ([&or (&rest [&or symbolp (symbolp form) (form)]) - (symbolp form)] - form body))) + (debug ([&or (symbolp form) ; must be first, Bug#48489 + (&rest [&or symbolp (symbolp form) (form)])] + body))) (when (and (<= (length spec) 2) (not (listp (car spec)))) ;; Adjust the single binding case @@ -215,28 +213,6 @@ The variable list SPEC is the same as in `if-let'." (define-obsolete-function-alias 'string-reverse 'reverse "25.1") -(defsubst string-trim-left (string &optional regexp) - "Trim STRING of leading string matching REGEXP. - -REGEXP defaults to \"[ \\t\\n\\r]+\"." - (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string) - (substring string (match-end 0)) - string)) - -(defsubst string-trim-right (string &optional regexp) - "Trim STRING of trailing string matching REGEXP. - -REGEXP defaults to \"[ \\t\\n\\r]+\"." - (let ((i (string-match-p (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") - string))) - (if i (substring string 0 i) string))) - -(defsubst string-trim (string &optional trim-left trim-right) - "Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT. - -TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"." - (string-trim-left (string-trim-right string trim-right) trim-left)) - ;;;###autoload (defun string-truncate-left (string length) "Truncate STRING to LENGTH, replacing initial surplus with \"...\"." @@ -264,6 +240,7 @@ carriage return." (substring string 0 (- (length string) (length suffix))) string)) +;;;###autoload (defun string-clean-whitespace (string) "Clean up whitespace in STRING. All sequences of whitespaces in STRING are collapsed into a @@ -311,6 +288,18 @@ than this function." (let ((result nil) (result-length 0) (index (if end (1- (length string)) 0))) + ;; FIXME: This implementation, which uses encode-coding-char + ;; to encode the string one character at a time, is in general + ;; incorrect: coding-systems that produce prefix or suffix + ;; bytes, such as ISO-2022-based or UTF-8/16 with BOM, will + ;; produce those bytes for each character, instead of just + ;; once for the entire string. encode-coding-char attempts to + ;; remove those extra bytes at least in some situations, but + ;; it cannot do that in all cases. And in any case, producing + ;; what is supposed to be a UTF-16 or ISO-2022-CN encoded + ;; string which lacks the BOM bytes at the beginning and the + ;; charset designation sequences at the head and tail of the + ;; result will definitely surprise the callers in some cases. (while (let ((encoded (encode-coding-char (aref string index) coding-system))) (and (<= (+ (length encoded) result-length) length) @@ -329,6 +318,7 @@ than this function." (end (substring string (- (length string) length))) (t (substring string 0 length))))) +;;;###autoload (defun string-lines (string &optional omit-nulls) "Split STRING into a list of lines. If OMIT-NULLS, empty lines will be removed from the results." diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index bee2f9639e7..0bb1b8916b1 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -125,6 +125,10 @@ otherwise nil. That construct can be a two character comment delimiter or an Escaped or Char-quoted character.")) (defun syntax-propertize-wholelines (start end) + "Extend the region delimited by START and END to whole lines. +This function is useful for +`syntax-propertize-extend-region-functions'; +see Info node `(elisp) Syntax Properties'." (goto-char start) (cons (line-beginning-position) (progn (goto-char end) @@ -290,12 +294,13 @@ all RULES in total." ',(string-to-syntax (nth 1 action))) ,@(nthcdr 2 action)) `((let ((mb (match-beginning ,gn)) - (me (match-end ,gn)) - (syntax ,(nth 1 action))) - (if syntax - (put-text-property - mb me 'syntax-table syntax)) - ,@(nthcdr 2 action))))) + (me (match-end ,gn))) + ,(macroexp-let2 nil syntax (nth 1 action) + `(progn + (if ,syntax + (put-text-property + mb me 'syntax-table ,syntax)) + ,@(nthcdr 2 action))))))) (t `((let ((mb (match-beginning ,gn)) (me (match-end ,gn)) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 0c299b48b90..f0ee78745ac 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -36,6 +36,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup tabulated-list nil "Tabulated-list customization group." :group 'convenience @@ -212,6 +214,8 @@ If ADVANCE is non-nil, move forward by one line afterwards." special-mode-map)) (define-key map "n" 'next-line) (define-key map "p" 'previous-line) + (define-key map (kbd "M-<left>") 'tabulated-list-previous-column) + (define-key map (kbd "M-<right>") 'tabulated-list-next-column) (define-key map "S" 'tabulated-list-sort) (define-key map "}" 'tabulated-list-widen-current-column) (define-key map "{" 'tabulated-list-narrow-current-column) @@ -410,8 +414,7 @@ specified by `tabulated-list-sort-key'. It then erases the buffer and inserts the entries with `tabulated-list-printer'. Optional argument REMEMBER-POS, if non-nil, means to move point -to the entry with the same ID element as the current line and -recenter window line accordingly. +to the entry with the same ID element as the current line. Non-nil UPDATE argument means to use an alternative printing method which is faster if most entries haven't changed since the @@ -424,18 +427,10 @@ changing `tabulated-list-sort-key'." (funcall tabulated-list-entries) tabulated-list-entries)) (sorter (tabulated-list--get-sorter)) - entry-id saved-pt saved-col window-line) + entry-id saved-pt saved-col) (and remember-pos (setq entry-id (tabulated-list-get-id)) - (setq saved-col (current-column)) - (when (eq (window-buffer) (current-buffer)) - (setq window-line - (save-excursion - (save-restriction - (widen) - (narrow-to-region (window-start) (point)) - (goto-char (point-min)) - (vertical-motion (buffer-size))))))) + (setq saved-col (current-column))) ;; Sort the entries, if necessary. (when sorter (setq entries (sort entries sorter))) @@ -490,9 +485,7 @@ changing `tabulated-list-sort-key'." ;; If REMEMBER-POS was specified, move to the "old" location. (if saved-pt (progn (goto-char saved-pt) - (move-to-column saved-col) - (when window-line - (recenter window-line))) + (move-to-column saved-col)) (goto-char (point-min))))) (defun tabulated-list-print-entry (id cols) @@ -656,18 +649,41 @@ this is the vector stored within it." (defun tabulated-list-sort (&optional n) "Sort Tabulated List entries by the column at point. -With a numeric prefix argument N, sort the Nth column." +With a numeric prefix argument N, sort the Nth column. + +If the numeric prefix is -1, restore order the list was +originally displayed in." (interactive "P") - (let ((name (if n - (car (aref tabulated-list-format n)) - (get-text-property (point) - 'tabulated-list-column-name)))) - (if (nth 2 (assoc name (append tabulated-list-format nil))) - (tabulated-list--sort-by-column-name name) - (user-error "Cannot sort by %s" name)))) + (if (equal n -1) + ;; Restore original order. + (progn + (unless tabulated-list--original-order + (error "Order is already in original order")) + (setq tabulated-list-entries + (sort tabulated-list-entries + (lambda (e1 e2) + (< (gethash e1 tabulated-list--original-order) + (gethash e2 tabulated-list--original-order))))) + (setq tabulated-list-sort-key nil) + (tabulated-list-init-header) + (tabulated-list-print t)) + ;; Sort based on a column name. + (let ((name (if n + (car (aref tabulated-list-format n)) + (get-text-property (point) + 'tabulated-list-column-name)))) + (if (nth 2 (assoc name (append tabulated-list-format nil))) + (tabulated-list--sort-by-column-name name) + (user-error "Cannot sort by %s" name))))) (defun tabulated-list--sort-by-column-name (name) (when (and name (derived-mode-p 'tabulated-list-mode)) + (unless tabulated-list--original-order + ;; Store the original order so that we can restore it later. + (setq tabulated-list--original-order (make-hash-table)) + (cl-loop for elem in tabulated-list-entries + for i from 0 + do (setf (gethash elem tabulated-list--original-order) i))) ;; Flip the sort order on a second click. (if (equal name (car tabulated-list-sort-key)) (setcdr tabulated-list-sort-key @@ -726,8 +742,32 @@ Interactively, N is the prefix numeric argument, and defaults to (setq-local tabulated-list--current-lnum-width lnum-width) (tabulated-list-init-header))))) +(defun tabulated-list-next-column (&optional arg) + "Go to the start of the next column after point on the current line. +If ARG is provided, move that many columns." + (interactive "p") + (dotimes (_ (or arg 1)) + (let ((next (or (next-single-property-change + (point) 'tabulated-list-column-name) + (point-max)))) + (when (<= next (line-end-position)) + (goto-char next))))) + +(defun tabulated-list-previous-column (&optional arg) + "Go to the start of the column point is in on the current line. +If ARG is provided, move that many columns." + (interactive "p") + (dotimes (_ (or arg 1)) + (let ((prev (or (previous-single-property-change + (point) 'tabulated-list-column-name) + 1))) + (unless (< prev (line-beginning-position)) + (goto-char prev))))) + ;;; The mode definition: +(defvar tabulated-list--original-order nil) + (define-derived-mode tabulated-list-mode special-mode "Tabulated" "Generic major mode for browsing a list of items. This mode is usually not used directly; instead, other major @@ -768,6 +808,7 @@ as the ewoc pretty-printer." (setq-local glyphless-char-display (tabulated-list-make-glyphless-char-display-table)) (setq-local text-scale-remap-header-line t) + (setq-local tabulated-list--original-order nil) ;; Avoid messing up the entries' display just because the first ;; column of the first entry happens to begin with a R2L letter. (setq bidi-paragraph-direction 'left-to-right) diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index fb9cd8f47df..4460fef97bd 100644 --- a/lisp/emacs-lisp/tcover-ses.el +++ b/lisp/emacs-lisp/tcover-ses.el @@ -1,4 +1,4 @@ -;;;; testcover-ses.el -- Example use of `testcover' to test "SES" -*- lexical-binding: t; -*- +;;; tcover-ses.el --- Example use of `testcover' to test "SES" -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. @@ -6,6 +6,8 @@ ;; Keywords: spreadsheet lisp utility ;; Package: testcover +;; 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 @@ -30,8 +32,8 @@ ;;;Here are some macros that exercise SES. Set `pause' to t if you want the ;;;macros to pause after each step. -(let* ((pause nil) - (x (if pause "\^Xq" "")) +(let* (;; (pause nil) + (x (if nil "\^Xq" "")) ;; pause (y "\^X\^Fses-test.ses\r\^[<")) ;;Fiddle with the existing spreadsheet (fset 'ses-exercise-example @@ -714,4 +716,4 @@ spreadsheet files with invalid formatting." ;;Could do this here: (testcover-end "ses.el") (message "Done")) -;;; testcover-ses.el ends here. +;;; tcover-ses.el ends here diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index 75b27d08e56..e75f15140aa 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -1,4 +1,4 @@ -;;;; testcover.el -- Visual code-coverage tool -*- lexical-binding:t -*- +;;; testcover.el --- Visual code-coverage tool -*- lexical-binding:t -*- ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. @@ -675,4 +675,4 @@ The list is 1valued if all of its constituent elements are also 1valued." (testcover-analyze-coverage (cadr form))) (t (testcover-analyze-coverage-backquote form)))) -;; testcover.el ends here. +;;; testcover.el ends here diff --git a/lisp/emacs-lisp/text-property-search.el b/lisp/emacs-lisp/text-property-search.el index e909e4bf760..7da02a9cb2d 100644 --- a/lisp/emacs-lisp/text-property-search.el +++ b/lisp/emacs-lisp/text-property-search.el @@ -31,28 +31,40 @@ (defun text-property-search-forward (property &optional value predicate not-current) - "Search for the next region of text whose PROPERTY matches VALUE. - -If not found, return nil and don't move point. -If found, move point to the start of the region and return a -`prop-match' object describing the match. To access the details -of the match, use `prop-match-beginning' and `prop-match-end' for -the buffer positions that limit the region, and -`prop-match-value' for the value of PROPERTY in the region. - + "Search for the next region of text where PREDICATE is true. PREDICATE is used to decide whether a value of PROPERTY should be considered as matching VALUE. -If PREDICATE is t, that means a value must `equal' VALUE to be -considered a match. -If PREDICATE is nil, a value will match if it is non-nil and -is NOT `equal' to VALUE. + If PREDICATE is a function, it will be called with two arguments: VALUE and the value of PROPERTY. The function should return non-nil if these two values are to be considered a match. +Two special values of PREDICATE can also be used: +If PREDICATE is t, that means a value must `equal' VALUE to be +considered a match. +If PREDICATE is nil (which is the default value), a value will +match if is not `equal' to VALUE. Furthermore, a nil PREDICATE +means that the match region is ended if the value changes. For +instance, this means that if you loop with + + (while (setq prop (text-property-search-forward 'face)) + ...) + +you will get all distinct regions with non-nil `face' values in +the buffer, and the `prop' object will have the details about the +match. See the manual for more details and examples about how +VALUE and PREDICATE interact. + If NOT-CURRENT is non-nil, the function will search for the first region that doesn't include point and has a value of PROPERTY -that matches VALUE." +that matches VALUE. + +If no matches can be found, return nil and don't move point. +If found, move point to the end of the region and return a +`prop-match' object describing the match. To access the details +of the match, use `prop-match-beginning' and `prop-match-end' for +the buffer positions that limit the region, and +`prop-match-value' for the value of PROPERTY in the region." (interactive (list (let ((string (completing-read "Search for property: " obarray))) @@ -125,7 +137,7 @@ that matches VALUE." "Search for the previous region of text whose PROPERTY matches VALUE. Like `text-property-search-forward', which see, but searches backward, -and if a matching region is found, place point at its end." +and if a matching region is found, place point at the start of the region." (interactive (list (let ((string (completing-read "Search for property: " obarray))) @@ -214,3 +226,5 @@ and if a matching region is found, place point at its end." (funcall predicate value prop-value)) (provide 'text-property-search) + +;;; text-property-search.el ends here diff --git a/lisp/emacs-lisp/thunk.el b/lisp/emacs-lisp/thunk.el index 83e0fa75aa7..7e349d22a49 100644 --- a/lisp/emacs-lisp/thunk.el +++ b/lisp/emacs-lisp/thunk.el @@ -52,7 +52,7 @@ (defmacro thunk-delay (&rest body) "Delay the evaluation of BODY." - (declare (debug t)) + (declare (debug (def-body))) (cl-assert lexical-binding) `(let (forced (val (lambda () ,@body))) diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index fa07d622484..9354687b081 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -161,7 +161,7 @@ "Helper function to get internal values. You can call this function to add internal values in the trace buffer." (unless inhibit-trace - (with-current-buffer trace-buffer + (with-current-buffer (get-buffer-create trace-buffer) (goto-char (point-max)) (insert (trace-entry-message @@ -174,7 +174,7 @@ and CONTEXT is a string describing the dynamic context (e.g. values of some global variables)." (let ((print-circle t)) (format "%s%s%d -> %S%s\n" - (mapconcat 'char-to-string (make-string (1- level) ?|) " ") + (mapconcat 'char-to-string (make-string (max 0 (1- level)) ?|) " ") (if (> level 1) " " "") level ;; FIXME: Make it so we can click the function name to jump to its diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index d52a6c796db..fa4e0583ed3 100644 --- a/lisp/emacs-lisp/unsafep.el +++ b/lisp/emacs-lisp/unsafep.el @@ -1,4 +1,4 @@ -;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate -*- lexical-binding: t; -*- +;;; unsafep.el --- Determine whether a Lisp form is safe to evaluate -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 67de690e67d..36b275e2d3c 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -307,7 +307,7 @@ entirely by setting `warning-suppress-types' or 'type 'warning-suppress-log-warning 'warning-type type)) (funcall newline) - (when (and warning-fill-prefix (not (string-match "\n" message))) + (when (and warning-fill-prefix (not (string-search "\n" message))) (let ((fill-prefix warning-fill-prefix) (fill-column warning-fill-column)) (fill-region start (point)))) |