diff options
Diffstat (limited to 'lisp/emacs-lisp')
60 files changed, 7412 insertions, 4620 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 56f0ae2212c..a6974e07cb2 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2042,7 +2042,7 @@ in that CLASS." function class name))) (error "ad-remove-advice: `%s' is not advised" function))) -(declare-function comp-subr-trampoline-install "comp") +(declare-function comp-subr-trampoline-install "comp-run") ;;;###autoload (defun ad-add-advice (function advice class position) @@ -2067,9 +2067,6 @@ 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 @@ -3131,6 +3128,7 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) [DOCSTRING] [INTERACTIVE-FORM] BODY...)" (declare (doc-string 3) (indent 2) + (obsolete "use `advice-add' or `define-advice'" "30.1") (debug (&define name ;; thing being advised. (name ;; class is [&or "before" "around" "after" ;; "activation" "deactivation"] diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 53e17693933..1beeb523f08 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -135,8 +135,7 @@ frames before its nearest activation frame are discarded." ;; Font Locking support (defconst backtrace--font-lock-keywords - '((backtrace--match-ellipsis-in-string - (1 'button prepend))) + '() "Expressions to fontify in Backtrace mode. Fontify these in addition to the expressions Emacs Lisp mode fontifies.") @@ -154,16 +153,6 @@ fontifies.") backtrace--font-lock-keywords) "Gaudy level highlighting for Backtrace mode.") -(defun backtrace--match-ellipsis-in-string (bound) - ;; Fontify ellipses within strings as buttons. - ;; This is necessary because ellipses are text property buttons - ;; instead of overlay buttons, which is done because there could - ;; be a large number of them. - (when (re-search-forward "\\(\\.\\.\\.\\)\"" bound t) - (and (get-text-property (- (point) 2) 'cl-print-ellipsis) - (get-text-property (- (point) 3) 'cl-print-ellipsis) - (get-text-property (- (point) 4) 'cl-print-ellipsis)))) - ;;; Xref support (defun backtrace--xref-backend () 'elisp) @@ -424,12 +413,12 @@ the buffer." (overlay-put o 'evaporate t)))) (defun backtrace--change-button-skip (beg end value) - "Change the skip property on all buttons between BEG and END. -Set it to VALUE unless the button is a `backtrace-ellipsis' button." + "Change the `skip' property on all buttons between BEG and END. +Set it to VALUE unless the button is a `cl-print-ellipsis' button." (let ((inhibit-read-only t)) (setq beg (next-button beg)) (while (and beg (< beg end)) - (unless (eq (button-type beg) 'backtrace-ellipsis) + (unless (eq (button-type beg) 'cl-print-ellipsis) (button-put beg 'skip value)) (setq beg (next-button beg))))) @@ -497,34 +486,15 @@ Reprint the frame with the new view plist." `(backtrace-index ,index backtrace-view ,view)) (goto-char min))) -(defun backtrace-expand-ellipsis (button) - "Expand display of the elided form at BUTTON." - (interactive) - (goto-char (button-start button)) - (unless (get-text-property (point) 'cl-print-ellipsis) - (if (and (> (point) (point-min)) - (get-text-property (1- (point)) 'cl-print-ellipsis)) - (backward-char) - (user-error "No ellipsis to expand here"))) - (let* ((end (next-single-property-change (point) 'cl-print-ellipsis)) - (begin (previous-single-property-change end 'cl-print-ellipsis)) - (value (get-text-property begin 'cl-print-ellipsis)) - (props (backtrace-get-text-properties begin)) +(defun backtrace--expand-ellipsis (orig-fun begin end val _length &rest args) + "Wrapper to expand an ellipsis. +For use on `cl-print-expand-ellipsis-function'." + (let* ((props (backtrace-get-text-properties begin)) (inhibit-read-only t)) (backtrace--with-output-variables (backtrace-get-view) - (delete-region begin end) - (insert (cl-print-to-string-with-limit #'cl-print-expand-ellipsis value - backtrace-line-length)) - (setq end (point)) - (goto-char begin) - (while (< (point) end) - (let ((next (next-single-property-change (point) 'cl-print-ellipsis - nil end))) - (when (get-text-property (point) 'cl-print-ellipsis) - (make-text-button (point) next :type 'backtrace-ellipsis)) - (goto-char next))) - (goto-char begin) - (add-text-properties begin end props)))) + (let ((end (apply orig-fun begin end val backtrace-line-length args))) + (add-text-properties begin end props) + end)))) (defun backtrace-expand-ellipses (&optional no-limit) "Expand display of all \"...\"s in the backtrace frame at point. @@ -697,13 +667,6 @@ line and recenter window line accordingly." (recenter window-line))) (goto-char (point-min))))) -;; Define button type used for ...'s. -;; Set skip property so you don't have to TAB through 100 of them to -;; get to the next function name. -(define-button-type 'backtrace-ellipsis - 'skip t 'action #'backtrace-expand-ellipsis - 'help-echo "mouse-2, RET: expand this ellipsis") - (defun backtrace-print-to-string (obj &optional limit) "Return a printed representation of OBJ formatted for backtraces. Attempt to get the length of the returned string under LIMIT @@ -720,15 +683,6 @@ characters with appropriate settings of `print-level' and (insert (cl-print-to-string-with-limit #'backtrace--print sexp limit)) ;; Add a unique backtrace-form property. (put-text-property (point-min) (point) 'backtrace-form (gensym)) - ;; Make buttons from all the "..."s. Since there might be many of - ;; them, use text property buttons. - (goto-char (point-min)) - (while (< (point) (point-max)) - (let ((end (next-single-property-change (point) 'cl-print-ellipsis - nil (point-max)))) - (when (get-text-property (point) 'cl-print-ellipsis) - (make-text-button (point) end :type 'backtrace-ellipsis)) - (goto-char end))) (buffer-string))) (defun backtrace-print-frame (frame view) @@ -919,6 +873,8 @@ followed by `backtrace-print-frame', once for each stack frame." (setq-local filter-buffer-substring-function #'backtrace--filter-visible) (setq-local indent-line-function 'lisp-indent-line) (setq-local indent-region-function 'lisp-indent-region) + (add-function :around (local 'cl-print-expand-ellipsis-function) + #'backtrace--expand-ellipsis) (add-hook 'xref-backend-functions #'backtrace--xref-backend nil t)) (put 'backtrace-mode 'mode-class 'special) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 937300cf0c0..a9fe1d06275 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -72,34 +72,40 @@ (require 'macroexp) (eval-when-compile (require 'subr-x)) +(defun bytecomp--log-lap-arg (arg) + ;; Convert an argument that may be a LAP operation to something printable. + (cond + ;; Symbols are just stripped of their -byte prefix if any. + ((symbolp arg) + (intern (string-remove-prefix "byte-" (symbol-name arg)))) + ;; Conses are assumed to be LAP ops or tags. + ((and (consp arg) (symbolp (car arg))) + (let* ((head (car arg)) + (tail (cdr arg)) + (op (intern (string-remove-prefix "byte-" (symbol-name head))))) + (cond + ((eq head 'TAG) + (format "%d:" (car tail))) + ((memq head byte-goto-ops) + (format "(%s %d)" op (cadr tail))) + ((memq head byte-constref-ops) + (format "(%s %s)" + (if (eq op 'constant) 'const op) + (if (numberp tail) + (format "<V%d>" tail) ; closure var reference + (format "%S" (car tail))))) ; actual constant + ;; Ops with an immediate argument. + ((memq op '( stack-ref stack-set call unbind + listN concatN insertN discardN discardN-preserve-tos)) + (format "(%s %S)" op tail)) + ;; Without immediate, print just the symbol. + (t op)))) + ;; Anything else is printed as-is. + (t arg))) + (defun byte-compile-log-lap-1 (format &rest args) (byte-compile-log-1 - (apply #'format-message format - (let (c a) - (mapcar (lambda (arg) - (if (not (consp arg)) - (if (and (symbolp arg) - (string-match "^byte-" (symbol-name arg))) - (intern (substring (symbol-name arg) 5)) - arg) - (if (integerp (setq c (car arg))) - (error "Non-symbolic byte-op %s" c)) - (if (eq c 'TAG) - (setq c arg) - (setq a (cond ((memq c byte-goto-ops) - (car (cdr (cdr arg)))) - ((memq c byte-constref-ops) - (car (cdr arg))) - (t (cdr arg)))) - (setq c (symbol-name c)) - (if (string-match "^byte-." c) - (setq c (intern (substring c 5))))) - (if (eq c 'constant) (setq c 'const)) - (if (and (eq (cdr arg) 0) - (not (memq c '(unbind call const)))) - c - (format "(%s %s)" c a)))) - args))))) + (apply #'format-message format (mapcar #'bytecomp--log-lap-arg args)))) (defmacro byte-compile-log-lap (format-string &rest args) `(and (memq byte-optimize-log '(t byte)) @@ -161,8 +167,8 @@ Earlier variables shadow later ones with the same name.") ((or `(lambda . ,_) `(closure . ,_)) ;; 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. + ;; can only inline dynbind source into dynbind source or lexbind + ;; source into lexbind 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 @@ -170,7 +176,10 @@ Earlier variables shadow later ones with the same name.") ;; the build more reproducible. (if (eq fn localfn) ;; From the same file => same mode. - (macroexp--unfold-lambda `(,fn ,@(cdr form))) + (let* ((newform `(,fn ,@(cdr form))) + (unfolded (macroexp--unfold-lambda newform))) + ;; Use the newform only if it could be optimized. + (if (eq unfolded newform) form unfolded)) ;; Since we are called from inside the optimizer, we need to make ;; sure not to propagate lexvar values. (let ((byte-optimize--lexvars nil) @@ -208,28 +217,24 @@ This indicates the loop discovery phase.") (defvar byte-optimize--aliased-vars nil "List of variables which may be aliased by other lexical variables. -If an entry in `byte-optimize--lexvars' has another variable as its VALUE, -then that other variable must be in this list. -This variable thus carries no essential information but is maintained -for speeding up processing.") +Each element is (NAME . ALIAS) where NAME is the aliased variable +and ALIAS the variable record (in the format described for +`byte-optimize--lexvars') for an alias, which may have NAME as its VALUE. +There can be multiple entries for the same NAME if it has several aliases.") (defun byte-optimize--substitutable-p (expr) "Whether EXPR is a constant that can be propagated." - ;; Only consider numbers, symbols and strings to be values for substitution - ;; purposes. Numbers and symbols are immutable, and mutating string - ;; literals (or results from constant-evaluated string-returning functions) - ;; can be considered undefined. - ;; (What about other quoted values, like conses?) (or (booleanp expr) (numberp expr) - (stringp expr) - (and (consp expr) - (or (and (memq (car expr) '(quote function)) - (symbolp (cadr expr))) - ;; (internal-get-closed-var N) can be considered constant for - ;; const-prop purposes. - (and (eq (car expr) 'internal-get-closed-var) - (integerp (cadr expr))))) + (arrayp expr) + (let ((head (car-safe expr))) + (cond ((eq head 'quote) t) + ;; Don't substitute #'(lambda ...) since that would enable + ;; uncontrolled inlining. + ((eq head 'function) (symbolp (cadr expr))) + ;; (internal-get-closed-var N) can be considered constant for + ;; const-prop purposes. + ((eq head 'internal-get-closed-var) (integerp (cadr expr))))) (keywordp expr))) (defmacro byte-optimize--pcase (exp &rest cases) @@ -266,6 +271,14 @@ for speeding up processing.") . ,(cdr case))) cases))) +(defsubst byte-opt--fget (f prop) + "Simpler and faster version of `function-get'." + (let ((val nil)) + (while (and (symbolp f) f + (null (setq val (get f prop)))) + (setq f (symbol-function f))) + val)) + (defun byte-optimize-form-code-walker (form for-effect) ;; ;; For normal function calls, We can just mapcar the optimizer the cdr. But @@ -410,7 +423,10 @@ for speeding up processing.") (`(condition-case ,var ,exp . ,clauses) `(,fn ,var ;Not evaluated. - ,(byte-optimize-form exp for-effect) + ,(byte-optimize-form exp + (if (assq :success clauses) + (null var) + for-effect)) ,@(mapcar (lambda (clause) (let ((byte-optimize--lexvars (and lexical-binding @@ -422,40 +438,22 @@ for speeding up processing.") (byte-optimize-body (cdr clause) for-effect)))) clauses))) - ;; `unwind-protect' is a special form which here takes the shape - ;; (unwind-protect EXPR :fun-body UNWIND-FUN). - ;; We can treat it as if it were a plain function at this point, - ;; although there are specific optimizations possible. - ;; In particular, the return value of UNWIND-FUN is never used - ;; so its body should really be compiled for-effect, but we - ;; don't do that right now. + (`(unwind-protect ,protected-expr :fun-body ,unwind-fun) + ;; FIXME: The return value of UNWIND-FUN is never used so we + ;; could potentially optimize it for-effect, but we don't do + ;; that right no. + `(,fn ,(byte-optimize-form protected-expr for-effect) + :fun-body ,(byte-optimize-form unwind-fun))) (`(catch ,tag . ,exps) `(,fn ,(byte-optimize-form tag nil) . ,(byte-optimize-body exps for-effect))) ;; Needed as long as we run byte-optimize-form after cconv. - (`(internal-make-closure . ,_) - (and (not for-effect) - (progn - ;; Look up free vars and mark them to be kept, so that they - ;; won't be optimized away. - (dolist (var (caddr form)) - (let ((lexvar (assq var byte-optimize--lexvars))) - (when lexvar - (setcar (cdr lexvar) t)))) - form))) - - (`((lambda . ,_) . ,_) - (let ((newform (macroexp--unfold-lambda form))) - (if (eq newform form) - ;; Some error occurred, avoid infinite recursion. - form - (byte-optimize-form newform for-effect)))) - - ;; FIXME: Strictly speaking, I think this is a bug: (closure...) - ;; is a *value* and shouldn't appear in the car. - (`((closure . ,_) . ,_) form) + (`(internal-make-closure ,vars ,env . ,rest) + (if for-effect + `(progn ,@(byte-optimize-body env t)) + `(,fn ,vars ,(mapcar #'byte-optimize-form env) . ,rest))) (`(setq ,var ,expr) (let ((lexvar (assq var byte-optimize--lexvars)) @@ -464,13 +462,17 @@ for speeding up processing.") (setcar (cdr lexvar) t) ; Mark variable to be kept. (setcdr (cdr lexvar) nil) ; Inhibit further substitution. - (when (memq var byte-optimize--aliased-vars) - ;; Cancel aliasing of variables aliased to this one. - (dolist (v byte-optimize--lexvars) - (when (eq (nth 2 v) var) - ;; V is bound to VAR but VAR is now mutated: - ;; cancel aliasing. - (setcdr (cdr v) nil))))) + ;; Cancel substitution of variables aliasing this one. + (let ((aliased-vars byte-optimize--aliased-vars)) + (while + (let ((alias (assq var aliased-vars))) + (and alias + (progn + ;; Found a variable bound to VAR but VAR is + ;; now mutated; cancel aliasing. + (setcdr (cddr alias) nil) + (setq aliased-vars (cdr (memq alias aliased-vars))) + t)))))) `(,fn ,var ,value))) (`(defvar ,(and (pred symbolp) name) . ,rest) @@ -483,31 +485,19 @@ for speeding up processing.") (`(,(pred byte-code-function-p) . ,exps) (cons fn (mapcar #'byte-optimize-form exps))) - (`(,(pred (not symbolp)) . ,_) - (byte-compile-warn-x fn "`%s' is a malformed function" fn) - form) - ((guard (when for-effect - (if-let ((tmp (get fn 'side-effect-free))) + (if-let ((tmp (byte-opt--fget fn 'side-effect-free))) (or byte-compile-delete-errors - (eq tmp 'error-free) - (progn - (byte-compile-warn-x - form - "value returned from %s is unused" - form) - nil))))) + (eq tmp 'error-free))))) (byte-compile-log " %s called for effect; deleted" fn) - ;; appending a nil here might not be necessary, but it can't hurt. - (byte-optimize-form - (cons 'progn (append (cdr form) '(nil))) t)) + (byte-optimize-form (cons 'progn (cdr form)) t)) (_ ;; Otherwise, no args can be considered to be for-effect, ;; even if the called function is for-effect, because we ;; don't know anything about that function. (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form))))) - (if (get fn 'pure) + (if (byte-opt--fget fn 'pure) (byte-optimize-constant-args form) form)))))) @@ -529,7 +519,7 @@ for speeding up processing.") ;; until a fixpoint has been reached. (and (consp form) (symbolp (car form)) - (let ((opt (function-get (car form) 'byte-optimizer))) + (let ((opt (byte-opt--fget (car form) 'byte-optimizer))) (and opt (let ((old form) (new (funcall opt form))) @@ -597,7 +587,6 @@ for speeding up processing.") (let* ((byte-optimize--lexvars byte-optimize--lexvars) (byte-optimize--aliased-vars byte-optimize--aliased-vars) (new-lexvars nil) - (new-aliased-vars nil) (let-vars nil) (body (cdr form)) (bindings (car form))) @@ -607,7 +596,7 @@ for speeding up processing.") (expr (byte-optimize-form (cadr binding) nil))) (setq bindings (cdr bindings)) (when (and (eq head 'let*) - (memq name byte-optimize--aliased-vars)) + (assq name byte-optimize--aliased-vars)) ;; New variable shadows an aliased variable -- α-rename ;; it in this and all subsequent bindings. (let ((new-name (make-symbol (symbol-name name)))) @@ -620,14 +609,12 @@ for speeding up processing.") bindings)) (setq body (byte-optimize--rename-var-body name new-name body)) (setq name new-name))) - (let* ((aliased nil) - (value (and - (or (byte-optimize--substitutable-p expr) - ;; Aliasing another lexvar. - (setq aliased - (and (symbolp expr) - (assq expr byte-optimize--lexvars)))) - (list expr))) + (let* ((aliased + ;; Aliasing another lexvar. + (and (symbolp expr) (assq expr byte-optimize--lexvars))) + (value (and (or aliased + (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)))) @@ -636,20 +623,16 @@ for speeding up processing.") (when lexinfo (push lexinfo (if (eq head 'let*) byte-optimize--lexvars - new-lexvars))) - (when aliased - (push expr (if (eq head 'let*) - byte-optimize--aliased-vars - new-aliased-vars)))))) - - (setq byte-optimize--aliased-vars - (append new-aliased-vars byte-optimize--aliased-vars)) + new-lexvars)) + (when aliased + (push (cons expr lexinfo) byte-optimize--aliased-vars)))))) + (when (and (eq head 'let) byte-optimize--aliased-vars) ;; Find new variables that shadow aliased variables. (let ((shadowing-vars nil)) (dolist (lexvar new-lexvars) (let ((name (car lexvar))) - (when (and (memq name byte-optimize--aliased-vars) + (when (and (assq name byte-optimize--aliased-vars) (not (memq name shadowing-vars))) (push name shadowing-vars)))) ;; α-rename them @@ -755,7 +738,8 @@ for speeding up processing.") ((eq head 'list) (cdr form)) ((memq head ;; FIXME: Replace this list with a function property? - '( length safe-length cons lambda + '( lambda internal-make-closure + length safe-length cons string unibyte-string make-string concat format format-message substring substring-no-properties string-replace @@ -795,6 +779,17 @@ for speeding up processing.") make-marker copy-marker point-marker mark-marker set-marker kbd key-description + skip-chars-forward skip-chars-backward + skip-syntax-forward skip-syntax-backward + current-column current-indentation + char-syntax syntax-class-to-char + parse-partial-sexp goto-char forward-line + next-window previous-window minibuffer-window + selected-frame selected-window + standard-case-table standard-syntax-table + syntax-table + frame-first-window frame-root-window + frame-selected-window always)) t) ((eq head 'if) @@ -815,8 +810,29 @@ for speeding up processing.") (or (not form) ; assume (quote nil) always being normalized to nil (and (consp form) (let ((head (car form))) - ;; FIXME: There are many other expressions that are statically nil. - (cond ((memq head '(while ignore)) t) + (cond ((memq head + ;; Some forms that are statically nil. + ;; FIXME: Replace with a function property? + '( while ignore + insert insert-and-inherit insert-before-markers + insert-before-markers-and-inherit + insert-char insert-byte insert-buffer-substring + delete-region delete-char + widen narrow-to-region transpose-regions + forward-char backward-char + beginning-of-line end-of-line + erase-buffer buffer-swap-text + delete-overlay delete-all-overlays + remhash + maphash + map-charset-chars map-char-table + mapbacktrace + mapatoms + ding beep sleep-for + json-insert + set-match-data + )) + t) ((eq head 'if) (and (byte-compile-nilconstp (nth 2 form)) (byte-compile-nilconstp (car (last (cdddr form)))))) @@ -878,7 +894,13 @@ for speeding up processing.") (cons accum args)) (defun byte-optimize-plus (form) - (let ((args (remq 0 (byte-opt--arith-reduce #'+ 0 (cdr form))))) + (let* ((not-0 (remq 0 (byte-opt--arith-reduce #'+ 0 (cdr form)))) + (args (if (and (= (length not-0) 1) + (> (length form) 2)) + ;; We removed numbers and only one arg remains: add a 0 + ;; so that it isn't turned into (* X 1) later on. + (append not-0 '(0)) + not-0))) (cond ;; (+) -> 0 ((null args) 0) @@ -971,17 +993,52 @@ for speeding up processing.") (t ;; Moving the constant to the end can enable some lapcode optimizations. (list (car form) (nth 2 form) (nth 1 form))))) +(defun byte-opt--nary-comparison (form) + "Optimize n-ary comparisons such as `=', `<' etc." + (let ((nargs (length (cdr form)))) + (cond + ((= nargs 1) + `(progn ,(cadr form) t)) + ((>= nargs 3) + ;; At least 3 arguments: transform to N-1 binary comparisons, + ;; since those have their own byte-ops which are particularly + ;; fast for fixnums. + (let* ((op (car form)) + (bindings nil) + (rev-args nil)) + (if (memq nil (mapcar #'macroexp-copyable-p (cddr form))) + ;; At least one arg beyond the first is non-constant non-variable: + ;; create temporaries for all args to guard against side-effects. + ;; The optimizer will eliminate trivial bindings later. + (let ((i 1)) + (dolist (arg (cdr form)) + (let ((var (make-symbol (format "arg%d" i)))) + (push var rev-args) + (push (list var arg) bindings) + (setq i (1+ i))))) + ;; All args beyond the first are copyable: no temporary variables + ;; required. + (setq rev-args (reverse (cdr form)))) + (let ((prev (car rev-args)) + (exprs nil)) + (dolist (arg (cdr rev-args)) + (push (list op arg prev) exprs) + (setq prev arg)) + (let ((and-expr (cons 'and exprs))) + (if bindings + (list 'let (nreverse bindings) and-expr) + and-expr))))) + (t form)))) + (defun byte-optimize-constant-args (form) - (let ((ok t) - (rest (cdr form))) - (while (and rest ok) - (setq ok (macroexp-const-p (car rest)) - rest (cdr rest))) - (if ok - (condition-case () - (list 'quote (eval form)) - (error form)) - form))) + (let ((rest (cdr form))) + (while (and rest (macroexp-const-p (car rest))) + (setq rest (cdr rest))) + (if rest + form + (condition-case () + (list 'quote (eval form t)) + (error form))))) (defun byte-optimize-identity (form) (if (and (cdr form) (null (cdr (cdr form)))) @@ -989,8 +1046,19 @@ for speeding up processing.") form)) (defun byte-optimize--constant-symbol-p (expr) - "Whether EXPR is a constant symbol." - (and (macroexp-const-p expr) (symbolp (eval expr)))) + "Whether EXPR is a constant symbol, like (quote hello), nil, t, or :keyword." + (if (consp expr) + (and (memq (car expr) '(quote function)) + (symbolp (cadr expr))) + (or (memq expr '(nil t)) + (keywordp expr)))) + +(defsubst byteopt--eval-const (expr) + "Evaluate EXPR which must be a constant (quoted or self-evaluating). +Ie, (macroexp-const-p EXPR) must be true." + (if (consp expr) + (cadr expr) ; assumed to be 'VALUE or #'SYMBOL + expr)) (defun byte-optimize--fixnump (o) "Return whether O is guaranteed to be a fixnum in all Emacsen. @@ -998,23 +1066,26 @@ See Info node `(elisp) Integer Basics'." (and (integerp o) (<= -536870912 o 536870911))) (defun byte-optimize-equal (form) - ;; 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--fixnump (nth 1 form)) - (byte-optimize--fixnump (nth 2 form))) - (cons 'eq (cdr form)) - form) - ;; Arity errors reported elsewhere. - form))) + (cond ((/= (length (cdr form)) 2) form) ; Arity errors reported elsewhere. + ;; Anything is identical to itself. + ((and (eq (nth 1 form) (nth 2 form)) (symbolp (nth 1 form))) t) + ;; Replace `equal' or `eql' with `eq' if at least one arg is a + ;; symbol or fixnum. + ((or (byte-optimize--constant-symbol-p (nth 1 form)) + (byte-optimize--constant-symbol-p (nth 2 form)) + (byte-optimize--fixnump (nth 1 form)) + (byte-optimize--fixnump (nth 2 form))) + (byte-optimize-binary-predicate (cons 'eq (cdr form)))) + (t (byte-optimize-binary-predicate form)))) (defun byte-optimize-eq (form) - (pcase (cdr form) - ((or `(,x nil) `(nil ,x)) `(not ,x)) - (_ (byte-optimize-binary-predicate form)))) + (cond ((/= (length (cdr form)) 2) form) ; arity error + ;; Anything is identical to itself. + ((and (eq (nth 1 form) (nth 2 form)) (symbolp (nth 1 form))) t) + ;; Strength-reduce comparison with `nil'. + ((null (nth 1 form)) `(not ,(nth 2 form))) + ((null (nth 2 form)) `(not ,(nth 1 form))) + (t (byte-optimize-binary-predicate form)))) (defun byte-optimize-member (form) (cond @@ -1027,7 +1098,7 @@ See Info node `(elisp) Integer Basics'." (byte-optimize--fixnump (nth 1 form)) (let ((arg2 (nth 2 form))) (and (macroexp-const-p arg2) - (let ((listval (eval arg2))) + (let ((listval (byteopt--eval-const arg2))) (and (listp listval) (not (memq nil (mapcar (lambda (o) @@ -1076,21 +1147,31 @@ See Info node `(elisp) Integer Basics'." form)) (defun byte-optimize-concat (form) - "Merge adjacent constant arguments to `concat'." + "Merge adjacent constant arguments to `concat' and flatten nested forms." (let ((args (cdr form)) (newargs nil)) (while args - (let ((strings nil) - val) - (while (and args (macroexp-const-p (car args)) - (progn - (setq val (eval (car args))) - (and (or (stringp val) - (and (or (listp val) (vectorp val)) - (not (memq nil - (mapcar #'characterp val)))))))) - (push val strings) - (setq args (cdr args))) + (let ((strings nil)) + (while + (and args + (let ((arg (car args))) + (pcase arg + ;; Merge consecutive constant arguments. + ((pred macroexp-const-p) + (let ((val (byteopt--eval-const arg))) + (and (or (stringp val) + (and (or (listp val) (vectorp val)) + (not (memq nil + (mapcar #'characterp val))))) + (progn + (push val strings) + (setq args (cdr args)) + t)))) + ;; Flatten nested `concat' form. + (`(concat . ,nested-args) + (setq args (append nested-args (cdr args))) + t))))) + (when strings (let ((s (apply #'concat (nreverse strings)))) (when (not (zerop (length s))) @@ -1126,13 +1207,18 @@ See Info node `(elisp) Integer Basics'." (put 'max 'byte-optimizer #'byte-optimize-min-max) (put 'min 'byte-optimizer #'byte-optimize-min-max) -(put '= '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) (put 'string-equal 'byte-optimizer #'byte-optimize-binary-predicate) +(put '= 'byte-optimizer #'byte-opt--nary-comparison) +(put '< 'byte-optimizer #'byte-opt--nary-comparison) +(put '<= 'byte-optimizer #'byte-opt--nary-comparison) +(put '> 'byte-optimizer #'byte-opt--nary-comparison) +(put '>= 'byte-optimizer #'byte-opt--nary-comparison) + (put 'string-greaterp 'byte-optimizer #'byte-optimize-string-greaterp) (put 'string> 'byte-optimizer #'byte-optimize-string-greaterp) @@ -1297,11 +1383,8 @@ See Info node `(elisp) Integer Basics'." (if else `(progn ,condition ,@else) condition)) - ;; (if X nil t) -> (not X) - ((and (eq then nil) (eq else '(t))) - `(not ,condition)) - ;; (if X t [nil]) -> (not (not X)) - ((and (eq then t) (or (null else) (eq else '(nil)))) + ;; (if X t) -> (not (not X)) + ((and (eq then t) (null else)) `(not ,(byte-opt--negate condition))) ;; (if VAR VAR X...) -> (or VAR (progn X...)) ((and (symbolp condition) (eq condition then)) @@ -1353,12 +1436,15 @@ See Info node `(elisp) Integer Basics'." (defun byte-optimize-funcall (form) - ;; (funcall (lambda ...) ...) ==> ((lambda ...) ...) - ;; (funcall foo ...) ==> (foo ...) - (let ((fn (nth 1 form))) - (if (memq (car-safe fn) '(quote function)) - (cons (nth 1 fn) (cdr (cdr form))) - form))) + ;; (funcall #'(lambda ...) ...) -> (let ...) + ;; (funcall #'SYM ...) -> (SYM ...) + ;; (funcall 'SYM ...) -> (SYM ...) + (pcase form + (`(,_ #'(lambda . ,_) . ,_) + (macroexp--unfold-lambda form)) + (`(,_ ,(or `#',f `',(and f (pred symbolp))) . ,actuals) + `(,f ,@actuals)) + (_ form))) (defun byte-optimize-apply (form) (let ((len (length form))) @@ -1379,6 +1465,9 @@ See Info node `(elisp) Integer Basics'." ;; (apply F ... (list X Y ...)) -> (funcall F ... X Y ...) ((eq (car-safe last) 'list) `(funcall ,fn ,@(butlast (cddr form)) ,@(cdr last))) + ;; (apply F ... (cons X Y)) -> (apply F ... X Y) + ((eq (car-safe last) 'cons) + (append (butlast form) (cdr last))) (t form))) form))) @@ -1450,6 +1539,44 @@ See Info node `(elisp) Integer Basics'." ;; (list) -> nil (and (cdr form) form)) +(put 'nconc 'byte-optimizer #'byte-optimize-nconc) +(defun byte-optimize-nconc (form) + (pcase (cdr form) + ('nil nil) ; (nconc) -> nil + (`(,x) x) ; (nconc X) -> X + (_ (named-let loop ((args (cdr form)) (newargs nil)) + (if args + (let ((arg (car args)) + (prev (car newargs))) + (cond + ;; Elide null args. + ((and (null arg) + ;; Don't elide a terminal nil unless preceded by + ;; a nonempty proper list, since that will have + ;; its last cdr forced to nil. + (or (cdr args) + ;; FIXME: prove the 'nonempty proper list' property + ;; for more forms than just `list', such as + ;; `append', `mapcar' etc. + (eq 'list (car-safe (car newargs))))) + (loop (cdr args) newargs)) + ;; Merge consecutive `list' args. + ((and (eq (car-safe arg) 'list) + (eq (car-safe prev) 'list)) + (loop (cons (cons (car prev) (append (cdr prev) (cdr arg))) + (cdr args)) + (cdr newargs))) + ;; (nconc ... (list A) B ...) -> (nconc ... (cons A B) ...) + ((and (eq (car-safe prev) 'list) (cdr prev) (null (cddr prev))) + (loop (cdr args) + (cons (list 'cons (cadr prev) arg) + (cdr newargs)))) + (t (loop (cdr args) (cons arg newargs))))) + (let ((new-form (cons (car form) (nreverse newargs)))) + (if (equal new-form form) + form + new-form))))))) + (put 'append 'byte-optimizer #'byte-optimize-append) (defun byte-optimize-append (form) ;; There is (probably) too much code relying on `append' to return a @@ -1476,7 +1603,7 @@ See Info node `(elisp) Integer Basics'." (cond ((macroexp-const-p arg) ;; constant arg - (let ((val (eval arg))) + (let ((val (byteopt--eval-const arg))) (cond ;; Elide empty arguments (nil, empty string, etc). ((zerop (length val)) @@ -1486,7 +1613,7 @@ See Info node `(elisp) Integer Basics'." (loop (cdr args) (cons (list 'quote - (append (eval prev) val nil)) + (append (byteopt--eval-const prev) val nil)) (cdr newargs)))) (t (loop (cdr args) (cons arg newargs)))))) @@ -1502,11 +1629,9 @@ See Info node `(elisp) Integer Basics'." ;; (append X) -> X ((null newargs) arg) - ;; (append (list Xs...) nil) -> (list Xs...) - ((and (null arg) - newargs (null (cdr newargs)) - (consp prev) (eq (car prev) 'list)) - prev) + ;; (append ... (list Xs...) nil) -> (append ... (list Xs...)) + ((and (null arg) (eq (car-safe prev) 'list)) + (cons (car form) (nreverse newargs))) ;; (append '(X) Y) -> (cons 'X Y) ;; (append (list X) Y) -> (cons X Y) @@ -1517,13 +1642,13 @@ See Info node `(elisp) Integer Basics'." (= (length (cadr prev)) 1))) ((eq (car prev) 'list) (= (length (cdr prev)) 1)))) - (list 'cons (if (eq (car prev) 'quote) - (macroexp-quote (caadr prev)) - (cadr prev)) - arg)) + `(cons ,(if (eq (car prev) 'quote) + (macroexp-quote (caadr prev)) + (cadr prev)) + ,arg)) (t - (let ((new-form (cons 'append (nreverse (cons arg newargs))))) + (let ((new-form (cons (car form) (nreverse (cons arg newargs))))) (if (equal new-form form) form new-form)))))))) @@ -1566,106 +1691,242 @@ See Info node `(elisp) Integer Basics'." ;; I wonder if I missed any :-\) (let ((side-effect-free-fns - '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan - assq - base64-decode-string base64-encode-string base64url-encode-string + '( + ;; alloc.c + make-bool-vector make-byte-code make-list make-record make-string + make-symbol make-vector + ;; buffer.c + buffer-base-buffer buffer-chars-modified-tick buffer-file-name + buffer-local-value buffer-local-variables buffer-modified-p + buffer-modified-tick buffer-name get-buffer next-overlay-change + overlay-buffer overlay-end overlay-get overlay-properties + overlay-start overlays-at overlays-in previous-overlay-change + ;; callint.c + prefix-numeric-value + ;; casefiddle.c + capitalize downcase upcase upcase-initials + ;; category.c + category-docstring category-set-mnemonics char-category-set + copy-category-table get-unused-category make-category-set + ;; character.c + char-width get-byte multibyte-char-to-unibyte string string-width + unibyte-char-to-multibyte unibyte-string + ;; charset.c + decode-char encode-char + ;; chartab.c + make-char-table + ;; data.c + % * + - / /= 1+ 1- < <= = > >= + aref ash bare-symbol bool-vector-count-consecutive bool-vector-count-population bool-vector-subsetp - boundp buffer-file-name buffer-local-variables buffer-modified-p - buffer-substring byte-code-function-p - capitalize car-less-than-car car cdr ceiling char-after char-before - char-equal char-to-string char-width compare-strings - window-configuration-equal-p concat coordinates-in-window-p - copy-alist copy-sequence copy-marker copysign cos count-lines - current-time-string current-time-zone - decode-char - decode-time default-boundp default-value documentation downcase - 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 - frame-visible-p fround ftruncate - get gethash get-buffer get-buffer-window getenv get-file-buffer - hash-table-count - int-to-string intern-soft isnan - keymap-parent - lax-plist-get ldexp - length length< length> length= - line-beginning-position line-end-position pos-bol pos-eol - 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 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 - prefix-numeric-value previous-window prin1-to-string propertize - degrees-to-radians - 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-blank-p - string-search string-to-char - string-to-number string-to-syntax substring - sxhash sxhash-equal sxhash-eq sxhash-eql - symbol-function symbol-name symbol-plist symbol-value string-make-unibyte - string-make-multibyte string-as-multibyte string-as-unibyte - string-to-multibyte - take tan time-convert truncate - unibyte-char-to-multibyte upcase user-full-name - user-login-name user-original-login-name custom-variable-p - vconcat - window-absolute-pixel-edges window-at window-body-height - window-body-width window-buffer window-dedicated-p window-display-table - window-combination-limit window-edges window-frame window-fringes - window-height window-hscroll window-inside-edges - window-inside-absolute-pixel-edges window-inside-pixel-edges - window-left-child window-left-column window-margins window-minibuffer-p - window-next-buffers window-next-sibling window-new-normal - window-new-total window-normal-size window-parameter window-parameters - window-parent window-pixel-edges window-point window-prev-buffers - window-prev-sibling window-scroll-bars - window-start window-text-height window-top-child window-top-line - window-total-height window-total-width window-use-time window-vscroll - window-width zerop)) + boundp car cdr default-boundp default-value fboundp + get-variable-watchers indirect-variable + local-variable-if-set-p local-variable-p + logand logcount logior lognot logxor max min mod + number-to-string position-symbol string-to-number + subr-arity subr-name subr-native-lambda-list subr-type + symbol-function symbol-name symbol-plist symbol-value + symbol-with-pos-pos variable-binding-locus + ;; doc.c + documentation + ;; editfns.c + buffer-substring buffer-substring-no-properties + byte-to-position byte-to-string + char-after char-before char-equal char-to-string + compare-buffer-substrings + format format-message + group-name + line-beginning-position line-end-position ngettext pos-bol pos-eol + propertize region-beginning region-end string-to-char + user-full-name user-login-name + ;; eval.c + special-variable-p + ;; fileio.c + car-less-than-car directory-name-p file-directory-p file-exists-p + file-name-absolute-p file-name-concat file-newer-than-file-p + file-readable-p file-symlink-p file-writable-p + ;; filelock.c + file-locked-p + ;; floatfns.c + abs acos asin atan ceiling copysign cos exp expt fceiling ffloor + float floor frexp fround ftruncate isnan ldexp log logb round + sin sqrt tan + truncate + ;; fns.c + append assq + base64-decode-string base64-encode-string base64url-encode-string + buffer-hash buffer-line-statistics + compare-strings concat copy-alist copy-hash-table copy-sequence elt + equal equal-including-properties + featurep get + gethash hash-table-count hash-table-rehash-size + hash-table-rehash-threshold hash-table-size hash-table-test + hash-table-weakness + length length< length= length> + line-number-at-pos load-average locale-info make-hash-table md5 + member memq memql nth nthcdr + object-intervals rassoc rassq reverse secure-hash + string-as-multibyte string-as-unibyte string-bytes + string-collate-equalp string-collate-lessp string-distance + string-equal string-lessp string-make-multibyte string-make-unibyte + string-search string-to-multibyte string-to-unibyte + string-version-lessp + substring substring-no-properties + sxhash-eq sxhash-eql sxhash-equal sxhash-equal-including-properties + take vconcat + ;; frame.c + frame-ancestor-p frame-bottom-divider-width frame-char-height + frame-char-width frame-child-frame-border-width frame-focus + frame-fringe-width frame-internal-border-width frame-native-height + frame-native-width frame-parameter frame-parameters frame-parent + frame-pointer-visible-p frame-position frame-right-divider-width + frame-scale-factor frame-scroll-bar-height frame-scroll-bar-width + frame-text-cols frame-text-height frame-text-lines frame-text-width + frame-total-cols frame-total-lines frame-visible-p + frame-window-state-change next-frame previous-frame + tool-bar-pixel-width window-system + ;; fringe.c + fringe-bitmaps-at-pos + ;; keyboard.c + posn-at-point posn-at-x-y + ;; keymap.c + copy-keymap keymap-parent keymap-prompt make-keymap make-sparse-keymap + ;; lread.c + intern-soft read-from-string + ;; marker.c + copy-marker marker-buffer marker-insertion-type marker-position + ;; minibuf.c + active-minibuffer-window assoc-string innermost-minibuffer-p + minibuffer-innermost-command-loop-p minibufferp + ;; print.c + error-message-string prin1-to-string + ;; process.c + format-network-address get-buffer-process get-process + process-buffer process-coding-system process-command process-filter + process-id process-inherit-coding-system-flag process-mark + process-name process-plist process-query-on-exit-flag + process-running-child-p process-sentinel process-thread + process-tty-name process-type + ;; search.c + match-beginning match-end regexp-quote + ;; sqlite.c + sqlite-columns sqlite-more-p sqlite-version + ;; syntax.c + char-syntax copy-syntax-table matching-paren string-to-syntax + syntax-class-to-char + ;; term.c + controlling-tty-p tty-display-color-cells tty-display-color-p + tty-top-frame tty-type + ;; terminal.c + frame-terminal terminal-list terminal-live-p terminal-name + terminal-parameter terminal-parameters + ;; textprop.c + get-char-property get-char-property-and-overlay get-text-property + next-char-property-change next-property-change + next-single-char-property-change next-single-property-change + previous-char-property-change previous-property-change + previous-single-char-property-change previous-single-property-change + text-properties-at text-property-any text-property-not-all + ;; thread.c + all-threads condition-mutex condition-name mutex-name thread-live-p + thread-name + ;; timefns.c + current-cpu-time + current-time-string current-time-zone decode-time encode-time + float-time format-time-string time-add time-convert time-equal-p + time-less-p time-subtract + ;; window.c + coordinates-in-window-p frame-first-window frame-root-window + frame-selected-window get-buffer-window minibuffer-selected-window + minibuffer-window next-window previous-window window-at + window-body-height window-body-width window-buffer + window-combination-limit window-configuration-equal-p + window-dedicated-p window-display-table window-frame window-fringes + window-hscroll window-left-child window-left-column window-margins + window-minibuffer-p window-new-normal window-new-total + window-next-buffers window-next-sibling window-normal-size + window-parameter window-parameters window-parent window-point + window-prev-buffers window-prev-sibling window-scroll-bars + window-start window-text-height window-top-child window-top-line + window-total-height window-total-width window-use-time window-vscroll + ;; xdisp.c + buffer-text-pixel-size current-bidi-paragraph-direction + get-display-property invisible-p line-pixel-height lookup-image-map + tab-bar-height tool-bar-height window-text-pixel-size + )) (side-effect-and-error-free-fns - '(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 - charsetp commandp cons consp - current-buffer current-global-map current-indentation - current-local-map current-minor-mode-maps current-time - eobp eolp eq equal eventp - fixnump floatp following-char framep - get-largest-window get-lru-window - hash-table-p - ;; `ignore' isn't here because we don't want calls to it elided; - ;; see `byte-compile-ignore'. - identity integerp integer-or-marker-p interactive-p - invocation-directory invocation-name - keymapp keywordp - list listp - make-marker mark-marker markerp max-char - memory-limit - mouse-movement-p - natnump nlistp not null number-or-marker-p numberp - one-window-p overlayp - point point-marker point-min point-max preceding-char primary-charset - processp proper-list-p - recent-keys recursion-depth - safe-length selected-frame selected-window sequencep - standard-case-table standard-syntax-table stringp subrp symbolp - syntax-table syntax-table-p - this-command-keys this-command-keys-vector this-single-command-keys - this-single-command-raw-keys type-of - user-real-login-name user-real-uid user-uid - vector vectorp visible-frame-list - wholenump window-configuration-p window-live-p - window-valid-p windowp))) + '( + ;; alloc.c + bool-vector cons list make-marker purecopy record vector + ;; buffer.c + buffer-list buffer-live-p current-buffer overlay-lists overlayp + ;; casetab.c + case-table-p current-case-table standard-case-table + ;; category.c + category-table category-table-p make-category-table + standard-category-table + ;; character.c + characterp max-char + ;; charset.c + charsetp + ;; data.c + arrayp atom bare-symbol-p bool-vector-p bufferp byte-code-function-p + byteorder car-safe cdr-safe char-or-string-p char-table-p + condition-variable-p consp eq floatp indirect-function + integer-or-marker-p integerp keywordp listp markerp + module-function-p multibyte-string-p mutexp natnump nlistp null + number-or-marker-p numberp recordp remove-pos-from-symbol + sequencep stringp subr-native-elisp-p subrp symbol-with-pos-p symbolp + threadp type-of user-ptrp vector-or-char-table-p vectorp wholenump + ;; editfns.c + bobp bolp buffer-size buffer-string current-message emacs-pid + eobp eolp following-char gap-position gap-size group-gid + group-real-gid mark-marker point point-marker point-max point-min + position-bytes preceding-char system-name + user-real-login-name user-real-uid user-uid + ;; emacs.c + invocation-directory invocation-name + ;; eval.c + commandp functionp + ;; fileio.c + default-file-modes + ;; fns.c + eql + hash-table-p identity proper-list-p safe-length + secure-hash-algorithms + ;; frame.c + frame-list frame-live-p framep last-nonminibuffer-frame + old-selected-frame selected-frame visible-frame-list + ;; image.c + imagep + ;; indent.c + current-column current-indentation + ;; keyboard.c + current-idle-time current-input-mode recent-keys recursion-depth + this-command-keys this-command-keys-vector this-single-command-keys + this-single-command-raw-keys + ;; keymap.c + current-global-map current-local-map current-minor-mode-maps keymapp + ;; minibuf.c + minibuffer-contents minibuffer-contents-no-properties minibuffer-depth + minibuffer-prompt minibuffer-prompt-end + ;; process.c + process-list processp signal-names waiting-for-user-input-p + ;; sqlite.c + sqlite-available-p sqlitep + ;; syntax.c + standard-syntax-table syntax-table syntax-table-p + ;; thread.c + current-thread + ;; timefns.c + current-time + ;; window.c + selected-window window-configuration-p window-live-p window-valid-p + windowp + ;; xdisp.c + long-line-optimizations-p + ))) (while side-effect-free-fns (put (car side-effect-free-fns) 'side-effect-free t) (setq side-effect-free-fns (cdr side-effect-free-fns))) @@ -1690,43 +1951,35 @@ See Info node `(elisp) Integer Basics'." ;; values if a marker is moved. (let ((pure-fns - '(concat regexp-opt regexp-quote - string-to-char string-to-syntax symbol-name - eq eql - = /= < <= >= > min max - + - * / % mod abs ash 1+ 1- sqrt - logand logior lognot logxor logcount - copysign isnan ldexp float logb - floor ceiling round truncate - ffloor fceiling fround ftruncate - string= string-equal string< string-lessp string> string-greaterp - string-empty-p string-blank-p - string-search - consp atom listp nlistp proper-list-p - sequencep arrayp vectorp stringp bool-vector-p hash-table-p - null not - numberp integerp floatp natnump characterp - integer-or-marker-p number-or-marker-p char-or-string-p - symbolp keywordp - type-of - identity ignore - - ;; The following functions are pure up to mutation of their - ;; arguments. This is pure enough for the purposes of - ;; constant folding, but not necessarily for all kinds of - ;; code motion. - car cdr car-safe cdr-safe nth nthcdr last take - equal - length safe-length - memq memql member - ;; `assoc' and `assoc-default' are excluded since they are - ;; impure if the test function is (consider `string-match'). - assq rassq rassoc - lax-plist-get - aref elt - base64-decode-string base64-encode-string base64url-encode-string - bool-vector-subsetp - bool-vector-count-population bool-vector-count-consecutive + '( + ;; character.c + characterp max-char + ;; data.c + % * + - / /= 1+ 1- < <= = > >= aref arrayp ash atom bare-symbol + bool-vector-count-consecutive bool-vector-count-population + bool-vector-p bool-vector-subsetp + bufferp car car-safe cdr cdr-safe char-or-string-p char-table-p + condition-variable-p consp eq floatp integer-or-marker-p integerp + keywordp listp logand logcount logior lognot logxor markerp max min + mod multibyte-string-p mutexp natnump nlistp null number-or-marker-p + numberp recordp remove-pos-from-symbol sequencep stringp symbol-name + symbolp threadp type-of vector-or-char-table-p vectorp + ;; editfns.c + string-to-char + ;; floatfns.c + abs ceiling copysign fceiling ffloor float floor fround ftruncate + isnan ldexp logb round sqrt truncate + ;; fns.c + assq base64-decode-string base64-encode-string base64url-encode-string + concat elt eql equal equal-including-properties + hash-table-p identity length length< length= + length> member memq memql nth nthcdr proper-list-p rassoc rassq + safe-length string-bytes string-distance string-equal string-lessp + string-search string-version-lessp take + ;; search.c + regexp-quote + ;; syntax.c + string-to-syntax ))) (while pure-fns (put (car pure-fns) 'pure t) @@ -1904,8 +2157,9 @@ See Info node `(elisp) Integer Basics'." (defconst byte-after-unbind-ops '(byte-constant byte-dup byte-stack-ref byte-stack-set byte-discard + byte-discardN byte-discardN-preserve-tos byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp - byte-eq byte-not + byte-not byte-cons byte-list1 byte-list2 byte-list3 byte-list4 byte-listN byte-interactive-p) ;; How about other side-effect-free-ops? Is it safe to move an @@ -1913,11 +2167,16 @@ See Info node `(elisp) Integer Basics'." ;; No, it is not, because the unwind-protect forms can alter ;; the inside of the object to which nth would apply. ;; For the same reason, byte-equal was deleted from this list. + ;; + ;; In particular, `byte-eq' isn't here despite `eq' being nominally + ;; pure because it is currently affected by `symbols-with-pos-enabled' + ;; and so cannot be sunk past an unwind op that might end a binding of + ;; that variable. Yes, this is unsatisfactory. "Byte-codes that can be moved past an unbind.") (defconst byte-compile-side-effect-and-error-free-ops '(byte-constant byte-dup byte-symbolp byte-consp byte-stringp byte-listp - byte-integerp byte-numberp byte-eq byte-equal byte-not byte-car-safe + byte-integerp byte-numberp byte-eq byte-not byte-car-safe byte-cdr-safe byte-cons byte-list1 byte-list2 byte-list3 byte-list4 byte-listN byte-point byte-point-max byte-point-min byte-following-char byte-preceding-char @@ -1928,10 +2187,11 @@ See Info node `(elisp) Integer Basics'." (append '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1 - byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate - byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax - byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt - byte-member byte-assq byte-quo byte-rem byte-substring) + byte-eqlsign byte-equal byte-gtr byte-lss byte-leq byte-geq byte-diff + byte-negate byte-plus byte-max byte-min byte-mult byte-char-after + byte-char-syntax byte-buffer-substring byte-string= byte-string< + byte-nthcdr byte-elt byte-member byte-assq byte-quo byte-rem + byte-substring) byte-compile-side-effect-and-error-free-ops)) ;; This crock is because of the way DEFVAR_BOOL variables work. @@ -1967,574 +2227,800 @@ See Info node `(elisp) Integer Basics'." (defun byte-optimize-lapcode (lap &optional _for-effect) "Simple peephole optimizer. LAP is both modified and returned. If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." - (let (lap0 - lap1 - lap2 - (keep-going 'first-time) - (add-depth 0) - rest tmp tmp2 tmp3 - (side-effect-free (if byte-compile-delete-errors + (let ((side-effect-free (if byte-compile-delete-errors byte-compile-side-effect-free-ops - byte-compile-side-effect-and-error-free-ops))) + byte-compile-side-effect-and-error-free-ops)) + ;; Ops taking and produce a single value on the stack. + (unary-ops '( byte-not byte-length byte-list1 byte-nreverse + byte-car byte-cdr byte-car-safe byte-cdr-safe + byte-symbolp byte-consp byte-stringp + byte-listp byte-integerp byte-numberp + byte-add1 byte-sub1 byte-negate + ;; There are more of these but the list is + ;; getting long and the gain is typically small. + )) + ;; Ops producing a single result without looking at the stack. + (producer-ops '( byte-constant byte-varref + byte-point byte-point-max byte-point-min + byte-following-char byte-preceding-char + byte-current-column + byte-eolp byte-eobp byte-bolp byte-bobp + byte-current-buffer byte-widen)) + (add-depth 0) + (keep-going 'first-time) + ;; Create a cons cell as head of the list so that removing the first + ;; element does not need special-casing: `setcdr' always works. + (lap-head (cons nil lap))) (while keep-going - (or (eq keep-going 'first-time) - (byte-compile-log-lap " ---- next pass")) - (setq rest lap - keep-going nil) - (while rest - (setq lap0 (car rest) - lap1 (nth 1 rest) - lap2 (nth 2 rest)) - - ;; You may notice that sequences like "dup varset discard" are - ;; optimized but sequences like "dup varset TAG1: discard" are not. - ;; You may be tempted to change this; resist that temptation. - (cond - ;; <side-effect-free> pop --> <deleted> - ;; ...including: - ;; const-X pop --> <deleted> - ;; varref-X pop --> <deleted> - ;; dup pop --> <deleted> - ;; - ((and (eq 'byte-discard (car lap1)) - (memq (car lap0) side-effect-free)) - (setq keep-going t) - (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) - (setq rest (cdr rest)) - (cond ((eql tmp 1) - (byte-compile-log-lap - " %s discard\t-->\t<deleted>" lap0) - (setq lap (delq lap0 (delq lap1 lap)))) - ((eql tmp 0) - (byte-compile-log-lap - " %s discard\t-->\t<deleted> discard" lap0) - (setq lap (delq lap0 lap))) - ((eql tmp -1) - (byte-compile-log-lap - " %s discard\t-->\tdiscard discard" lap0) - (setcar lap0 'byte-discard) - (setcdr lap0 0)) - (t (error "Optimizer error: too much on the stack")))) - ;; - ;; goto*-X X: --> X: - ;; - ((and (memq (car lap0) byte-goto-ops) - (eq (cdr lap0) lap1)) - (cond ((eq (car lap0) 'byte-goto) - (setq lap (delq lap0 lap)) - (setq tmp "<deleted>")) - ((memq (car lap0) byte-goto-always-pop-ops) - (setcar lap0 (setq tmp 'byte-discard)) - (setcdr lap0 0)) - ((error "Depth conflict at tag %d" (nth 2 lap0)))) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " (goto %s) %s:\t-->\t%s %s:" - (nth 1 lap1) (nth 1 lap1) - tmp (nth 1 lap1))) - (setq keep-going t)) - ;; - ;; varset-X varref-X --> dup varset-X - ;; varbind-X varref-X --> dup varbind-X - ;; const/dup varset-X varref-X --> const/dup varset-X const/dup - ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup - ;; The latter two can enable other optimizations. - ;; - ;; For lexical variables, we could do the same - ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 - ;; but this is a very minor gain, since dup is stack-ref-0, - ;; i.e. it's only better if X>5, and even then it comes - ;; at the cost of an extra stack slot. Let's not bother. - ((and (eq 'byte-varref (car lap2)) - (eq (cdr lap1) (cdr lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) - (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) - (not (eq (car lap0) 'byte-constant))) - nil - (setq keep-going t) - (if (memq (car lap0) '(byte-constant byte-dup)) - (progn - (setq tmp (if (or (not tmp) - (macroexp--const-symbol-p - (car (cdr lap0)))) - (cdr lap0) - (byte-compile-get-constant t))) - (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" - lap0 lap1 lap2 lap0 lap1 - (cons (car lap0) tmp)) - (setcar lap2 (car lap0)) - (setcdr lap2 tmp)) - (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1) - (setcar lap2 (car lap1)) - (setcar lap1 'byte-dup) - (setcdr lap1 0) - ;; The stack depth gets locally increased, so we will - ;; increase maxdepth in case depth = maxdepth here. - ;; This can cause the third argument to byte-code to - ;; be larger than necessary. - (setq add-depth 1)))) - ;; - ;; dup varset-X discard --> varset-X - ;; dup varbind-X discard --> varbind-X - ;; dup stack-set-X discard --> stack-set-X-1 - ;; (the varbind variant can emerge from other optimizations) - ;; - ((and (eq 'byte-dup (car lap0)) - (eq 'byte-discard (car lap2)) - (memq (car lap1) '(byte-varset byte-varbind - byte-stack-set))) - (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) - (setq keep-going t - rest (cdr rest)) - (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1))) - (setq lap (delq lap0 (delq lap2 lap)))) - ;; - ;; not goto-X-if-nil --> goto-X-if-non-nil - ;; not goto-X-if-non-nil --> goto-X-if-nil - ;; - ;; it is wrong to do the same thing for the -else-pop variants. - ;; - ((and (eq 'byte-not (car lap0)) - (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) - (byte-compile-log-lap " not %s\t-->\t%s" - lap1 - (cons - (if (eq (car lap1) 'byte-goto-if-nil) - 'byte-goto-if-not-nil - 'byte-goto-if-nil) - (cdr lap1))) - (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) - 'byte-goto-if-not-nil - 'byte-goto-if-nil)) - (setq lap (delq lap0 lap)) - (setq keep-going t)) - ;; - ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: - ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: - ;; - ;; it is wrong to do the same thing for the -else-pop variants. - ;; - ((and (memq (car lap0) - '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX - (eq 'byte-goto (car lap1)) ; gotoY - (eq (cdr lap0) lap2)) ; TAG X - (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) - 'byte-goto-if-not-nil 'byte-goto-if-nil))) - (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" - lap0 lap1 lap2 - (cons inverse (cdr lap1)) lap2) - (setq lap (delq lap0 lap)) - (setcar lap1 inverse) - (setq keep-going t))) - ;; - ;; const goto-if-* --> whatever - ;; - ((and (eq 'byte-constant (car lap0)) - (memq (car lap1) byte-conditional-ops) - ;; If the `byte-constant's cdr is not a cons cell, it has - ;; to be an index into the constant pool); even though - ;; it'll be a constant, that constant is not known yet - ;; (it's typically a free variable of a closure, so will - ;; only be known when the closure will be built at - ;; run-time). - (consp (cdr lap0))) - (cond ((if (memq (car lap1) '(byte-goto-if-nil - byte-goto-if-nil-else-pop)) - (car (cdr lap0)) - (not (car (cdr lap0)))) - (byte-compile-log-lap " %s %s\t-->\t<deleted>" - lap0 lap1) - (setq rest (cdr rest) - lap (delq lap0 (delq lap1 lap)))) - (t - (byte-compile-log-lap " %s %s\t-->\t%s" - lap0 lap1 - (cons 'byte-goto (cdr lap1))) - (when (memq (car lap1) byte-goto-always-pop-ops) - (setq lap (delq lap0 lap))) - (setcar lap1 'byte-goto))) - (setq keep-going t)) - ;; - ;; varref-X varref-X --> varref-X dup - ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup - ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup - ;; We don't optimize the const-X variations on this here, - ;; because that would inhibit some goto optimizations; we - ;; optimize the const-X case after all other optimizations. - ;; - ((and (memq (car lap0) '(byte-varref byte-stack-ref)) - (progn - (setq tmp (cdr rest)) - (setq tmp2 0) - (while (eq (car (car tmp)) 'byte-dup) - (setq tmp2 (1+ tmp2)) - (setq tmp (cdr tmp))) - t) - (eq (if (eq 'byte-stack-ref (car lap0)) - (+ tmp2 1 (cdr lap0)) - (cdr lap0)) - (cdr (car tmp))) - (eq (car lap0) (car (car tmp)))) - (if (memq byte-optimize-log '(t byte)) - (let ((str "")) - (setq tmp2 (cdr rest)) - (while (not (eq tmp tmp2)) - (setq tmp2 (cdr tmp2) - str (concat str " dup"))) - (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" - lap0 str lap0 lap0 str))) - (setq keep-going t) - (setcar (car tmp) 'byte-dup) - (setcdr (car tmp) 0) - (setq rest tmp)) - ;; - ;; TAG1: TAG2: --> TAG1: <deleted> - ;; (and other references to TAG2 are replaced with TAG1) - ;; - ((and (eq (car lap0) 'TAG) - (eq (car lap1) 'TAG)) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " adjacent tags %d and %d merged" - (nth 1 lap1) (nth 1 lap0))) - (setq tmp3 lap) - (while (setq tmp2 (rassq lap0 tmp3)) - (setcdr tmp2 lap1) - (setq tmp3 (cdr (memq tmp2 tmp3)))) - (setq lap (delq lap0 lap) - keep-going t) - ;; replace references to tag in jump tables, if any - (dolist (table byte-compile-jump-tables) - (maphash #'(lambda (value tag) - (when (equal tag lap0) - (puthash value lap1 table))) - table))) - ;; - ;; unused-TAG: --> <deleted> - ;; - ((and (eq 'TAG (car lap0)) - (not (rassq lap0 lap)) - ;; make sure this tag isn't used in a jump-table - (cl-loop for table in byte-compile-jump-tables - when (member lap0 (hash-table-values table)) - return nil finally return t)) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " unused tag %d removed" (nth 1 lap0))) - (setq lap (delq lap0 lap) - keep-going t)) - ;; - ;; goto ... --> goto <delete until TAG or end> - ;; return ... --> return <delete until TAG or end> - ;; (unless a jump-table is being used, where deleting may affect - ;; other valid case bodies) - ;; - ((and (memq (car lap0) '(byte-goto byte-return)) - (not (memq (car lap1) '(TAG nil))) - ;; FIXME: Instead of deferring simply when jump-tables are - ;; being used, keep a list of tags used for switch tags and - ;; use them instead (see `byte-compile-inline-lapcode'). - (not byte-compile-jump-tables)) - (setq tmp rest) - (let ((i 0) - (opt-p (memq byte-optimize-log '(t lap))) - str deleted) - (while (and (setq tmp (cdr tmp)) - (not (eq 'TAG (car (car tmp))))) - (if opt-p (setq deleted (cons (car tmp) deleted) - str (concat str " %s") - i (1+ i)))) - (if opt-p - (let ((tagstr - (if (eq 'TAG (car (car tmp))) - (format "%d:" (car (cdr (car tmp)))) - (or (car tmp) "")))) - (if (< i 6) - (apply 'byte-compile-log-lap-1 - (concat " %s" str - " %s\t-->\t%s <deleted> %s") - lap0 - (nconc (nreverse deleted) - (list tagstr lap0 tagstr))) - (byte-compile-log-lap - " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s" - lap0 i (if (= i 1) "" "s") - tagstr lap0 tagstr)))) - (rplacd rest tmp)) - (setq keep-going t)) - ;; - ;; <safe-op> unbind --> unbind <safe-op> - ;; (this may enable other optimizations.) - ;; - ((and (eq 'byte-unbind (car lap1)) - (memq (car lap0) byte-after-unbind-ops)) - (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) - (setcar rest lap1) - (setcar (cdr rest) lap0) - (setq keep-going t)) - ;; - ;; varbind-X unbind-N --> discard unbind-(N-1) - ;; save-excursion unbind-N --> unbind-(N-1) - ;; save-restriction unbind-N --> unbind-(N-1) - ;; save-current-buffer unbind-N --> unbind-(N-1) - ;; - ((and (eq 'byte-unbind (car lap1)) - (memq (car lap0) '(byte-varbind byte-save-excursion - byte-save-restriction - byte-save-current-buffer)) - (< 0 (cdr lap1))) - (if (zerop (setcdr lap1 (1- (cdr lap1)))) - (delq lap1 rest)) - (if (eq (car lap0) 'byte-varbind) - (setcar rest (cons 'byte-discard 0)) - (setq lap (delq lap0 lap))) - (byte-compile-log-lap " %s %s\t-->\t%s %s" - lap0 (cons (car lap1) (1+ (cdr lap1))) - (if (eq (car lap0) 'byte-varbind) - (car rest) - (car (cdr rest))) - (if (and (/= 0 (cdr lap1)) - (eq (car lap0) 'byte-varbind)) - (car (cdr rest)) - "")) - (setq keep-going t)) - ;; - ;; goto*-X ... X: goto-Y --> goto*-Y - ;; goto-X ... X: return --> return - ;; - ((and (memq (car lap0) byte-goto-ops) - (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) - '(byte-goto byte-return))) - (cond ((and (or (eq (car lap0) 'byte-goto) - (eq (car tmp) 'byte-goto)) - (not (eq (cdr tmp) (cdr lap0)))) - (byte-compile-log-lap " %s [%s]\t-->\t%s" - (car lap0) tmp tmp) - (if (eq (car tmp) 'byte-return) - (setcar lap0 'byte-return)) - (setcdr lap0 (cdr tmp)) - (setq keep-going t)))) - ;; - ;; goto-*-else-pop X ... X: goto-if-* --> whatever - ;; goto-*-else-pop X ... X: discard --> whatever - ;; - ((and (memq (car lap0) '(byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop)) - (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) - (eval-when-compile - (cons 'byte-discard byte-conditional-ops))) - (not (eq lap0 (car tmp)))) - (setq tmp2 (car tmp)) - (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop - byte-goto-if-nil) - (byte-goto-if-not-nil-else-pop - byte-goto-if-not-nil)))) - (if (memq (car tmp2) tmp3) - (progn (setcar lap0 (car tmp2)) - (setcdr lap0 (cdr tmp2)) - (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" - (car lap0) tmp2 lap0)) - ;; Get rid of the -else-pop's and jump one step further. - (or (eq 'TAG (car (nth 1 tmp))) - (setcdr tmp (cons (byte-compile-make-tag) - (cdr tmp)))) - (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>" - (car lap0) tmp2 (nth 1 tmp3)) - (setcar lap0 (nth 1 tmp3)) - (setcdr lap0 (nth 1 tmp))) - (setq keep-going t)) - ;; - ;; const goto-X ... X: goto-if-* --> whatever - ;; const goto-X ... X: discard --> whatever - ;; - ((and (eq (car lap0) 'byte-constant) - (eq (car lap1) 'byte-goto) - (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) - (eval-when-compile - (cons 'byte-discard byte-conditional-ops))) - (not (eq lap1 (car tmp)))) - (setq tmp2 (car tmp)) - (cond ((when (consp (cdr lap0)) - (memq (car tmp2) - (if (null (car (cdr lap0))) - '(byte-goto-if-nil byte-goto-if-nil-else-pop) - '(byte-goto-if-not-nil - byte-goto-if-not-nil-else-pop)))) - (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" - lap0 tmp2 lap0 tmp2) - (setcar lap1 (car tmp2)) - (setcdr lap1 (cdr tmp2)) - ;; Let next step fix the (const,goto-if*) sequence. - (setq rest (cons nil rest)) - (setq keep-going t)) - ((or (consp (cdr lap0)) - (eq (car tmp2) 'byte-discard)) - ;; Jump one step further - (byte-compile-log-lap - " %s goto [%s]\t-->\t<deleted> goto <skip>" - lap0 tmp2) - (or (eq 'TAG (car (nth 1 tmp))) - (setcdr tmp (cons (byte-compile-make-tag) - (cdr tmp)))) - (setcdr lap1 (car (cdr tmp))) - (setq lap (delq lap0 lap)) - (setq keep-going t)))) - ;; - ;; X: varref-Y ... varset-Y goto-X --> - ;; X: varref-Y Z: ... dup varset-Y goto-Z - ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) - ;; (This is so usual for while loops that it is worth handling). - ;; - ;; Here again, we could do it for stack-ref/stack-set, but - ;; that's replacing a stack-ref-Y with a stack-ref-0, which - ;; is a very minor improvement (if any), at the cost of - ;; more stack use and more byte-code. Let's not do it. - ;; - ((and (eq (car lap1) 'byte-varset) - (eq (car lap2) 'byte-goto) - (not (memq (cdr lap2) rest)) ;Backwards jump - (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) - 'byte-varref) - (eq (cdr (car tmp)) (cdr lap1)) - (not (memq (car (cdr lap1)) byte-boolean-vars))) - ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) - (let ((newtag (byte-compile-make-tag))) - (byte-compile-log-lap - " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" - (nth 1 (cdr lap2)) (car tmp) - lap1 lap2 - (nth 1 (cdr lap2)) (car tmp) - (nth 1 newtag) 'byte-dup lap1 - (cons 'byte-goto newtag) - ) - (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) - (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) - (setq add-depth 1) - (setq keep-going t)) - ;; - ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: - ;; (This can pull the loop test to the end of the loop) - ;; - ((and (eq (car lap0) 'byte-goto) - (eq (car lap1) 'TAG) - (eq lap1 - (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) - (memq (car (car tmp)) - '(byte-goto byte-goto-if-nil byte-goto-if-not-nil - byte-goto-if-nil-else-pop))) - ;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" - ;; lap0 lap1 (cdr lap0) (car tmp)) - (let ((newtag (byte-compile-make-tag))) - (byte-compile-log-lap - "%s %s: ... %s: %s\t-->\t%s ... %s:" - lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) - (cons (cdr (assq (car (car tmp)) - '((byte-goto-if-nil . byte-goto-if-not-nil) - (byte-goto-if-not-nil . byte-goto-if-nil) - (byte-goto-if-nil-else-pop . - byte-goto-if-not-nil-else-pop) - (byte-goto-if-not-nil-else-pop . - byte-goto-if-nil-else-pop)))) - newtag) - - (nth 1 newtag) - ) - (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) - (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) - ;; We can handle this case but not the -if-not-nil case, - ;; because we won't know which non-nil constant to push. - (setcdr rest (cons (cons 'byte-constant - (byte-compile-get-constant nil)) - (cdr rest)))) - (setcar lap0 (nth 1 (memq (car (car tmp)) - '(byte-goto-if-nil-else-pop - byte-goto-if-not-nil - byte-goto-if-nil - byte-goto-if-not-nil - byte-goto byte-goto)))) - ) - (setq keep-going t)) - - ;; - ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos - ;; stack-set-M [discard/discardN ...] --> discardN - ;; - ((and (eq (car lap0) 'byte-stack-set) - (memq (car lap1) '(byte-discard byte-discardN)) - (progn - ;; See if enough discard operations follow to expose or - ;; destroy the value stored by the stack-set. - (setq tmp (cdr rest)) - (setq tmp2 (1- (cdr lap0))) - (setq tmp3 0) - (while (memq (car (car tmp)) '(byte-discard byte-discardN)) - (setq tmp3 - (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) - 1 - (cdr (car tmp))))) - (setq tmp (cdr tmp))) - (>= tmp3 tmp2))) - ;; Do the optimization. - (setq lap (delq lap0 lap)) - (setcar lap1 - (if (= tmp2 tmp3) - ;; The value stored is the new TOS, so pop one more - ;; value (to get rid of the old value) using the - ;; TOS-preserving discard operator. - 'byte-discardN-preserve-tos - ;; Otherwise, the value stored is lost, so just use a - ;; normal discard. - 'byte-discardN)) - (setcdr lap1 (1+ tmp3)) - (setcdr (cdr rest) tmp) - (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" - lap0 lap1)) - - ;; - ;; discardN-preserve-tos return --> return - ;; dup return --> return - ;; stack-set-N return --> return ; where N is TOS-1 - ;; - ((and (eq (car lap1) 'byte-return) - (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) - (and (eq (car lap0) 'byte-stack-set) - (= (cdr lap0) 1)))) - (setq keep-going t) - ;; The byte-code interpreter will pop the stack for us, so - ;; we can just leave stuff on it. - (setq lap (delq lap0 lap)) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) - - ;; - ;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y: - ;; - ((and (eq (car lap0) 'byte-goto) - (setq tmp (cdr (memq (cdr lap0) lap))) - (memq (caar tmp) '(byte-discard byte-discardN - byte-discardN-preserve-tos))) - (byte-compile-log-lap - " goto-X .. X: \t-->\t%s goto-X.. X: %s Y:" - (car tmp) (car tmp)) - (setq keep-going t) - (let* ((newtag (byte-compile-make-tag)) - ;; Make a copy, since we sometimes modify insts in-place! - (newdiscard (cons (caar tmp) (cdar tmp))) - (newjmp (cons (car lap0) newtag))) - (push newtag (cdr tmp)) ;Push new tag after the discard. - (setcar rest newdiscard) - (push newjmp (cdr rest)))) - - ;; - ;; const discardN-preserve-tos ==> discardN const - ;; - ((and (eq (car lap0) 'byte-constant) - (eq (car lap1) 'byte-discardN-preserve-tos)) - (setq keep-going t) - (let ((newdiscard (cons 'byte-discardN (cdr lap1)))) - (byte-compile-log-lap - " %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0) - (setf (car rest) newdiscard) - (setf (cadr rest) lap0))) - ) - (setq rest (cdr rest))) - ) + (byte-compile-log-lap " ---- %s pass" + (if (eq keep-going 'first-time) "first" "next")) + (setq keep-going nil) + (let ((prev lap-head)) + (while (cdr prev) + (let* ((rest (cdr prev)) + (lap0 (car rest)) + (lap1 (nth 1 rest)) + (lap2 (nth 2 rest))) + + ;; You may notice that sequences like "dup varset discard" are + ;; optimized but sequences like "dup varset TAG1: discard" are not. + ;; You may be tempted to change this; resist that temptation. + + ;; Each clause in this `cond' statement must keep `prev' the + ;; predecessor of the remainder of the list for inspection. + (cond + ;; + ;; PUSH(K) discard(N) --> <deleted> discard(N-K), N>K + ;; PUSH(K) discard(N) --> <deleted>, N=K + ;; where PUSH(K) is a side-effect-free op such as + ;; const, varref, dup + ;; + ((and (memq (car lap1) '(byte-discard byte-discardN)) + (memq (car lap0) side-effect-free)) + (setq keep-going t) + (let* ((pushes (aref byte-stack+-info (symbol-value (car lap0)))) + (pops (if (eq (car lap1) 'byte-discardN) (cdr lap1) 1)) + (net-pops (- pops pushes))) + (cond ((= net-pops 0) + (byte-compile-log-lap " %s %s\t-->\t<deleted>" + lap0 lap1) + (setcdr prev (cddr rest))) + ((> net-pops 0) + (byte-compile-log-lap + " %s %s\t-->\t<deleted> discard(%d)" + lap0 lap1 net-pops) + (setcar rest (if (eql net-pops 1) + (cons 'byte-discard nil) + (cons 'byte-discardN net-pops))) + (setcdr rest (cddr rest))) + (t (error "Optimizer error: too much on the stack"))))) + ;; + ;; goto(X) X: --> X: + ;; goto-if-[not-]nil(X) X: --> discard X: + ;; + ((and (memq (car lap0) byte-goto-ops) + (eq (cdr lap0) lap1)) + (cond ((eq (car lap0) 'byte-goto) + (byte-compile-log-lap " %s %s\t-->\t<deleted> %s" + lap0 lap1 lap1) + (setcdr prev (cdr rest))) + ((memq (car lap0) byte-goto-always-pop-ops) + (byte-compile-log-lap " %s %s\t-->\tdiscard %s" + lap0 lap1 lap1) + (setcar lap0 'byte-discard) + (setcdr lap0 0)) + ;; goto-*-else-pop(X) cannot occur here because it would + ;; be a depth conflict. + (t (error "Depth conflict at tag %d" (nth 2 lap0)))) + (setq keep-going t)) + ;; + ;; varset-X varref-X --> dup varset-X + ;; varbind-X varref-X --> dup varbind-X + ;; const/dup varset-X varref-X --> const/dup varset-X const/dup + ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup + ;; The latter two can enable other optimizations. + ;; + ;; For lexical variables, we could do the same + ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 + ;; but this is a very minor gain, since dup is stack-ref-0, + ;; i.e. it's only better if X>5, and even then it comes + ;; at the cost of an extra stack slot. Let's not bother. + ((and (eq 'byte-varref (car lap2)) + (eq (cdr lap1) (cdr lap2)) + (memq (car lap1) '(byte-varset byte-varbind)) + (let ((tmp (memq (car (cdr lap2)) byte-boolean-vars))) + (and + (not (and tmp (not (eq (car lap0) 'byte-constant)))) + (progn + (setq keep-going t) + (if (memq (car lap0) '(byte-constant byte-dup)) + (let ((tmp (if (or (not tmp) + (macroexp--const-symbol-p + (car (cdr lap0)))) + (cdr lap0) + (byte-compile-get-constant t)))) + (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" + lap0 lap1 lap2 lap0 lap1 + (cons (car lap0) tmp)) + (setcar lap2 (car lap0)) + (setcdr lap2 tmp)) + (byte-compile-log-lap " %s %s\t-->\tdup %s" + lap1 lap2 lap1) + (setcar lap2 (car lap1)) + (setcar lap1 'byte-dup) + (setcdr lap1 0) + ;; The stack depth gets locally increased, so we will + ;; increase maxdepth in case depth = maxdepth here. + ;; This can cause the third argument to byte-code to + ;; be larger than necessary. + (setq add-depth 1)) + t))))) + ;; + ;; dup varset discard(N) --> varset discard(N-1) + ;; dup varbind discard(N) --> varbind discard(N-1) + ;; dup stack-set(M) discard(N) --> stack-set(M-1) discard(N-1), M>1 + ;; (the varbind variant can emerge from other optimizations) + ;; + ((and (eq 'byte-dup (car lap0)) + (memq (car lap2) '(byte-discard byte-discardN)) + (or (memq (car lap1) '(byte-varset byte-varbind)) + (and (eq (car lap1) 'byte-stack-set) + (> (cdr lap1) 1)))) + (setcdr prev (cdr rest)) ; remove dup + (let ((new1 (if (eq (car lap1) 'byte-stack-set) + (cons 'byte-stack-set (1- (cdr lap1))) + lap1)) + (n (if (eq (car lap2) 'byte-discard) 1 (cdr lap2)))) + (setcar (cdr rest) new1) + (cl-assert (> n 0)) + (cond + ((> n 1) + (let ((new2 (if (> n 2) + (cons 'byte-discardN (1- n)) + (cons 'byte-discard nil)))) + (byte-compile-log-lap " %s %s %s\t-->\t%s %s" + lap0 lap1 lap2 new1 new2) + (setcar (cddr rest) new2))) + (t + (byte-compile-log-lap " %s %s %s\t-->\t%s" + lap0 lap1 lap2 new1) + ;; discard(0) = nop, remove + (setcdr (cdr rest) (cdddr rest))))) + (setq keep-going t)) + + ;; + ;; not goto-X-if-nil --> goto-X-if-non-nil + ;; not goto-X-if-non-nil --> goto-X-if-nil + ;; + ;; it is wrong to do the same thing for the -else-pop variants. + ;; + ((and (eq 'byte-not (car lap0)) + (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) + (let ((not-goto (if (eq (car lap1) 'byte-goto-if-nil) + 'byte-goto-if-not-nil + 'byte-goto-if-nil))) + (byte-compile-log-lap " not %s\t-->\t%s" + lap1 (cons not-goto (cdr lap1))) + (setcar lap1 not-goto) + (setcdr prev (cdr rest)) ; delete not + (setq keep-going t))) + ;; + ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: + ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: + ;; + ;; it is wrong to do the same thing for the -else-pop variants. + ;; + ((and (memq (car lap0) + '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX + (eq 'byte-goto (car lap1)) ; gotoY + (eq (cdr lap0) lap2)) ; TAG X + (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) + 'byte-goto-if-not-nil 'byte-goto-if-nil))) + (byte-compile-log-lap " %s %s %s\t-->\t%s %s" + lap0 lap1 lap2 + (cons inverse (cdr lap1)) lap2) + (setcdr prev (cdr rest)) + (setcar lap1 inverse) + (setq keep-going t))) + ;; + ;; const goto-if-* --> whatever + ;; + ((and (eq 'byte-constant (car lap0)) + (memq (car lap1) byte-conditional-ops) + ;; Must be an actual constant, not a closure variable. + (consp (cdr lap0))) + (cond ((if (memq (car lap1) '(byte-goto-if-nil + byte-goto-if-nil-else-pop)) + (car (cdr lap0)) + (not (car (cdr lap0)))) + ;; Branch not taken. + (byte-compile-log-lap " %s %s\t-->\t<deleted>" + lap0 lap1) + (setcdr prev (cddr rest))) ; delete both + ((memq (car lap1) byte-goto-always-pop-ops) + ;; Always-pop branch taken. + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 + (cons 'byte-goto (cdr lap1))) + (setcdr prev (cdr rest)) ; delete const + (setcar lap1 'byte-goto)) + (t ; -else-pop branch taken: keep const + (byte-compile-log-lap " %s %s\t-->\t%s %s" + lap0 lap1 + lap0 (cons 'byte-goto (cdr lap1))) + (setcar lap1 'byte-goto))) + (setq keep-going t)) + ;; + ;; varref-X varref-X --> varref-X dup + ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup + ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup + ;; We don't optimize the const-X variations on this here, + ;; because that would inhibit some goto optimizations; we + ;; optimize the const-X case after all other optimizations. + ;; + ((and (memq (car lap0) '(byte-varref byte-stack-ref)) + (let ((tmp (cdr rest)) + (tmp2 0)) + (while (eq (car (car tmp)) 'byte-dup) + (setq tmp2 (1+ tmp2)) + (setq tmp (cdr tmp))) + (and (eq (if (eq 'byte-stack-ref (car lap0)) + (+ tmp2 1 (cdr lap0)) + (cdr lap0)) + (cdr (car tmp))) + (eq (car lap0) (car (car tmp))) + (progn + (when (memq byte-optimize-log '(t byte)) + (let ((str "") + (tmp2 (cdr rest))) + (while (not (eq tmp tmp2)) + (setq tmp2 (cdr tmp2)) + (setq str (concat str " dup"))) + (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" + lap0 str lap0 lap0 str))) + (setq keep-going t) + (setcar (car tmp) 'byte-dup) + (setcdr (car tmp) 0) + t))))) + ;; + ;; TAG1: TAG2: --> <deleted> TAG2: + ;; (and other references to TAG1 are replaced with TAG2) + ;; + ((and (eq (car lap0) 'TAG) + (eq (car lap1) 'TAG)) + (byte-compile-log-lap " adjacent tags %d and %d merged" + (nth 1 lap1) (nth 1 lap0)) + (let ((tmp3 (cdr lap-head))) + (while (let ((tmp2 (rassq lap0 tmp3))) + (and tmp2 + (progn + (setcdr tmp2 lap1) + (setq tmp3 (cdr (memq tmp2 tmp3))) + t)))) + (setcdr prev (cdr rest)) + (setq keep-going t) + ;; replace references to tag in jump tables, if any + (dolist (table byte-compile-jump-tables) + (maphash #'(lambda (value tag) + (when (equal tag lap0) + (puthash value lap1 table))) + table)))) + ;; + ;; unused-TAG: --> <deleted> + ;; + ((and (eq 'TAG (car lap0)) + (not (rassq lap0 (cdr lap-head))) + ;; make sure this tag isn't used in a jump-table + (cl-loop for table in byte-compile-jump-tables + when (member lap0 (hash-table-values table)) + return nil finally return t)) + (byte-compile-log-lap " unused tag %d removed" (nth 1 lap0)) + (setcdr prev (cdr rest)) + (setq keep-going t)) + ;; + ;; goto ... --> goto <delete until TAG or end> + ;; return ... --> return <delete until TAG or end> + ;; + ((and (memq (car lap0) '(byte-goto byte-return)) + (not (memq (car lap1) '(TAG nil)))) + (let ((i 0) + (tmp rest) + (opt-p (memq byte-optimize-log '(t byte))) + str deleted) + (while (and (setq tmp (cdr tmp)) + (not (eq 'TAG (car (car tmp))))) + (if opt-p (setq deleted (cons (car tmp) deleted) + str (concat str " %s") + i (1+ i)))) + (if opt-p + (let ((tagstr + (if (eq 'TAG (car (car tmp))) + (format "%d:" (car (cdr (car tmp)))) + (or (car tmp) "")))) + (if (< i 6) + (apply 'byte-compile-log-lap-1 + (concat " %s" str + " %s\t-->\t%s <deleted> %s") + lap0 + (nconc (nreverse deleted) + (list tagstr lap0 tagstr))) + (byte-compile-log-lap + " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s" + lap0 i (if (= i 1) "" "s") + tagstr lap0 tagstr)))) + (setcdr rest tmp) + (setq keep-going t))) + ;; + ;; <safe-op> unbind --> unbind <safe-op> + ;; (this may enable other optimizations.) + ;; + ((and (eq 'byte-unbind (car lap1)) + (memq (car lap0) byte-after-unbind-ops)) + (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) + (setcar rest lap1) + (setcar (cdr rest) lap0) + (setq keep-going t)) + ;; + ;; varbind-X unbind-N --> discard unbind-(N-1) + ;; save-excursion unbind-N --> unbind-(N-1) + ;; save-restriction unbind-N --> unbind-(N-1) + ;; save-current-buffer unbind-N --> unbind-(N-1) + ;; + ((and (eq 'byte-unbind (car lap1)) + (memq (car lap0) '(byte-varbind byte-save-excursion + byte-save-restriction + byte-save-current-buffer)) + (< 0 (cdr lap1))) + (setcdr lap1 (1- (cdr lap1))) + (when (zerop (cdr lap1)) + (setcdr rest (cddr rest))) + (if (eq (car lap0) 'byte-varbind) + (setcar rest (cons 'byte-discard 0)) + (setcdr prev (cddr prev))) + (byte-compile-log-lap " %s %s\t-->\t%s %s" + lap0 (cons (car lap1) (1+ (cdr lap1))) + (if (eq (car lap0) 'byte-varbind) + (car rest) + (car (cdr rest))) + (if (and (/= 0 (cdr lap1)) + (eq (car lap0) 'byte-varbind)) + (car (cdr rest)) + "")) + (setq keep-going t)) + ;; + ;; goto*-X ... X: goto-Y --> goto*-Y + ;; goto-X ... X: return --> return + ;; + ((and (memq (car lap0) byte-goto-ops) + (let ((tmp (nth 1 (memq (cdr lap0) (cdr lap-head))))) + (and + (memq (car tmp) '(byte-goto byte-return)) + (or (eq (car lap0) 'byte-goto) + (eq (car tmp) 'byte-goto)) + (not (eq (cdr tmp) (cdr lap0))) + (progn + (byte-compile-log-lap " %s [%s]\t-->\t%s" + (car lap0) tmp + (if (eq (car tmp) 'byte-return) + tmp + (cons (car lap0) (cdr tmp)))) + (when (eq (car tmp) 'byte-return) + (setcar lap0 'byte-return)) + (setcdr lap0 (cdr tmp)) + (setq keep-going t) + t))))) + + ;; + ;; OP goto(X) Y: OP X: -> Y: OP X: + ;; + ((and (eq (car lap1) 'byte-goto) + (eq (car lap2) 'TAG) + (let ((lap3 (nth 3 rest))) + (and (eq (car lap0) (car lap3)) + (eq (cdr lap0) (cdr lap3)) + (eq (cdr lap1) (nth 4 rest))))) + (byte-compile-log-lap " %s %s %s %s %s\t-->\t%s %s %s" + lap0 lap1 lap2 + (nth 3 rest) (nth 4 rest) + lap2 (nth 3 rest) (nth 4 rest)) + (setcdr prev (cddr rest)) + (setq keep-going t)) + + ;; + ;; NOEFFECT PRODUCER return --> PRODUCER return + ;; where NOEFFECT lacks effects beyond stack change, + ;; PRODUCER pushes a result without looking at the stack: + ;; const, varref, point etc. + ;; + ((and (eq (car (nth 2 rest)) 'byte-return) + (memq (car lap1) producer-ops) + (or (memq (car lap0) '( byte-discard byte-discardN + byte-discardN-preserve-tos + byte-stack-set)) + (memq (car lap0) side-effect-free))) + (setq keep-going t) + (setq add-depth 1) + (setcdr prev (cdr rest)) + (byte-compile-log-lap " %s %s %s\t-->\t%s %s" + lap0 lap1 (nth 2 rest) lap1 (nth 2 rest))) + + ;; + ;; (discardN-preserve-tos|dup) UNARY return --> UNARY return + ;; where UNARY takes and produces a single value on the stack + ;; + ;; FIXME: ideally we should run this backwards, so that we could do + ;; discardN-preserve-tos OP1...OPn return -> OP1..OPn return + ;; but that would require a different approach. + ;; + ((and (eq (car (nth 2 rest)) 'byte-return) + (memq (car lap1) unary-ops) + (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) + (and (eq (car lap0) 'byte-stack-set) + (eql (cdr lap0) 1)))) + (setq keep-going t) + (setcdr prev (cdr rest)) ; eat lap0 + (byte-compile-log-lap " %s %s %s\t-->\t%s %s" + lap0 lap1 (nth 2 rest) lap1 (nth 2 rest))) + + ;; + ;; goto-*-else-pop X ... X: goto-if-* --> whatever + ;; goto-*-else-pop X ... X: discard --> whatever + ;; + ((and (memq (car lap0) '(byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop)) + (let ((tmp (cdr (memq (cdr lap0) (cdr lap-head))))) + (and + (memq (caar tmp) + (eval-when-compile + (cons 'byte-discard byte-conditional-ops))) + (not (eq lap0 (car tmp))) + (let ((tmp2 (car tmp)) + (tmp3 (assq (car lap0) + '((byte-goto-if-nil-else-pop + byte-goto-if-nil) + (byte-goto-if-not-nil-else-pop + byte-goto-if-not-nil))))) + (if (memq (car tmp2) tmp3) + (progn (setcar lap0 (car tmp2)) + (setcdr lap0 (cdr tmp2)) + (byte-compile-log-lap + " %s-else-pop [%s]\t-->\t%s" + (car lap0) tmp2 lap0)) + ;; Get rid of the -else-pop's and jump one + ;; step further. + (or (eq 'TAG (car (nth 1 tmp))) + (setcdr tmp (cons (byte-compile-make-tag) + (cdr tmp)))) + (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>" + (car lap0) tmp2 (nth 1 tmp3)) + (setcar lap0 (nth 1 tmp3)) + (setcdr lap0 (nth 1 tmp))) + (setq keep-going t) + t))))) + ;; + ;; const goto-X ... X: goto-if-* --> whatever + ;; const goto-X ... X: discard --> whatever + ;; + ((and (eq (car lap0) 'byte-constant) + (eq (car lap1) 'byte-goto) + (let ((tmp (cdr (memq (cdr lap1) (cdr lap-head))))) + (and + (memq (caar tmp) + (eval-when-compile + (cons 'byte-discard byte-conditional-ops))) + (not (eq lap1 (car tmp))) + (let ((tmp2 (car tmp))) + (cond ((and (consp (cdr lap0)) + (memq (car tmp2) + (if (null (car (cdr lap0))) + '(byte-goto-if-nil + byte-goto-if-nil-else-pop) + '(byte-goto-if-not-nil + byte-goto-if-not-nil-else-pop)))) + (byte-compile-log-lap + " %s goto [%s]\t-->\t%s %s" + lap0 tmp2 lap0 tmp2) + (setcar lap1 (car tmp2)) + (setcdr lap1 (cdr tmp2)) + ;; Let next step fix the (const,goto-if*) seq. + (setq keep-going t)) + ((or (consp (cdr lap0)) + (eq (car tmp2) 'byte-discard)) + ;; Jump one step further + (byte-compile-log-lap + " %s goto [%s]\t-->\t<deleted> goto <skip>" + lap0 tmp2) + (or (eq 'TAG (car (nth 1 tmp))) + (setcdr tmp (cons (byte-compile-make-tag) + (cdr tmp)))) + (setcdr lap1 (car (cdr tmp))) + (setcdr prev (cdr rest)) + (setq keep-going t)) + (t + (setq prev (cdr prev)))) + t))))) + ;; + ;; X: varref-Y ... varset-Y goto-X --> + ;; X: varref-Y Z: ... dup varset-Y goto-Z + ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) + ;; (This is so usual for while loops that it is worth handling). + ;; + ;; Here again, we could do it for stack-ref/stack-set, but + ;; that's replacing a stack-ref-Y with a stack-ref-0, which + ;; is a very minor improvement (if any), at the cost of + ;; more stack use and more byte-code. Let's not do it. + ;; + ((and (eq (car lap1) 'byte-varset) + (eq (car lap2) 'byte-goto) + (not (memq (cdr lap2) rest)) ;Backwards jump + (let ((tmp (cdr (memq (cdr lap2) (cdr lap-head))))) + (and + (eq (car (car tmp)) 'byte-varref) + (eq (cdr (car tmp)) (cdr lap1)) + (not (memq (car (cdr lap1)) byte-boolean-vars)) + (let ((newtag (byte-compile-make-tag))) + (byte-compile-log-lap + " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" + (nth 1 (cdr lap2)) (car tmp) + lap1 lap2 + (nth 1 (cdr lap2)) (car tmp) + (nth 1 newtag) 'byte-dup lap1 + (cons 'byte-goto newtag) + ) + (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) + (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))) + (setq add-depth 1) + (setq keep-going t) + t))))) + ;; + ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: + ;; (This can pull the loop test to the end of the loop) + ;; + ((and (eq (car lap0) 'byte-goto) + (eq (car lap1) 'TAG) + (let ((tmp (cdr (memq (cdr lap0) (cdr lap-head))))) + (and + (eq lap1 (cdar tmp)) + (memq (car (car tmp)) + '( byte-goto byte-goto-if-nil byte-goto-if-not-nil + byte-goto-if-nil-else-pop)) + (let ((newtag (byte-compile-make-tag))) + (byte-compile-log-lap + " %s %s ... %s %s\t-->\t%s ... %s" + lap0 lap1 (cdr lap0) (car tmp) + (cons (cdr (assq (car (car tmp)) + '((byte-goto-if-nil + . byte-goto-if-not-nil) + (byte-goto-if-not-nil + . byte-goto-if-nil) + (byte-goto-if-nil-else-pop + . byte-goto-if-not-nil-else-pop) + (byte-goto-if-not-nil-else-pop + . byte-goto-if-nil-else-pop)))) + newtag) + newtag) + (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) + (when (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) + ;; We can handle this case but not the + ;; -if-not-nil case, because we won't know + ;; which non-nil constant to push. + (setcdr rest + (cons (cons 'byte-constant + (byte-compile-get-constant nil)) + (cdr rest)))) + (setcar lap0 (nth 1 (memq (car (car tmp)) + '(byte-goto-if-nil-else-pop + byte-goto-if-not-nil + byte-goto-if-nil + byte-goto-if-not-nil + byte-goto byte-goto)))) + (setq keep-going t) + t))))) + + ;; + ;; discardN-preserve-tos(X) discardN-preserve-tos(Y) + ;; --> discardN-preserve-tos(X+Y) + ;; where stack-set(1) is accepted as discardN-preserve-tos(1) + ;; + ((and (or (eq (car lap0) 'byte-discardN-preserve-tos) + (and (eq (car lap0) 'byte-stack-set) + (eql (cdr lap0) 1))) + (or (eq (car lap1) 'byte-discardN-preserve-tos) + (and (eq (car lap1) 'byte-stack-set) + (eql (cdr lap1) 1)))) + (setq keep-going t) + (let ((new-op (cons 'byte-discardN-preserve-tos + ;; This happens to work even when either + ;; op is stack-set(1). + (+ (cdr lap0) (cdr lap1))))) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 new-op) + (setcar rest new-op) + (setcdr rest (cddr rest)))) + + ;; + ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos + ;; stack-set-M [discard/discardN ...] --> discardN + ;; + ((and (eq (car lap0) 'byte-stack-set) + (memq (car lap1) '(byte-discard byte-discardN)) + (let ((tmp2 (1- (cdr lap0))) + (tmp3 0) + (tmp (cdr rest))) + ;; See if enough discard operations follow to expose or + ;; destroy the value stored by the stack-set. + (while (memq (car (car tmp)) '(byte-discard byte-discardN)) + (setq tmp3 + (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) + 1 + (cdr (car tmp))))) + (setq tmp (cdr tmp))) + (and + (>= tmp3 tmp2) + (progn + ;; Do the optimization. + (setcdr prev (cdr rest)) + (setcar lap1 + (if (= tmp2 tmp3) + ;; The value stored is the new TOS, so pop + ;; one more value (to get rid of the old + ;; value) using TOS-preserving discard. + 'byte-discardN-preserve-tos + ;; Otherwise, the value stored is lost, + ;; so just use a normal discard. + 'byte-discardN)) + (setcdr lap1 (1+ tmp3)) + (setcdr (cdr rest) tmp) + (byte-compile-log-lap + " %s [discard/discardN]...\t-->\t%s" lap0 lap1) + (setq keep-going t) + t + ))))) + + ;; + ;; discardN-preserve-tos return --> return + ;; dup return --> return + ;; stack-set(1) return --> return + ;; + ((and (eq (car lap1) 'byte-return) + (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) + (and (eq (car lap0) 'byte-stack-set) + (= (cdr lap0) 1)))) + (setq keep-going t) + ;; The byte-code interpreter will pop the stack for us, so + ;; we can just leave stuff on it. + (setcdr prev (cdr rest)) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) + + ;; + ;; stack-ref(X) discardN-preserve-tos(Y) + ;; --> discard(Y) stack-ref(X-Y), X≥Y + ;; discard(X) discardN-preserve-tos(Y-X-1), X<Y + ;; where: stack-ref(0) = dup (works both ways) + ;; discard(0) = no-op + ;; discardN-preserve-tos(0) = no-op + ;; + ((and (memq (car lap0) '(byte-stack-ref byte-dup)) + (or (eq (car lap1) 'byte-discardN-preserve-tos) + (and (eq (car lap1) 'byte-stack-set) + (eql (cdr lap1) 1))) + ;; Don't apply if immediately preceding a `return', + ;; since there are more effective rules for that case. + (not (eq (car lap2) 'byte-return))) + (let ((x (if (eq (car lap0) 'byte-dup) 0 (cdr lap0))) + (y (cdr lap1))) + (cl-assert (> y 0)) + (cond + ((>= x y) ; --> discard(Y) stack-ref(X-Y) + (let ((new0 (if (= y 1) + (cons 'byte-discard nil) + (cons 'byte-discardN y))) + (new1 (if (= x y) + (cons 'byte-dup nil) + (cons 'byte-stack-ref (- x y))))) + (byte-compile-log-lap " %s %s\t-->\t%s %s" + lap0 lap1 new0 new1) + (setcar rest new0) + (setcar (cdr rest) new1))) + ((= x 0) ; --> discardN-preserve-tos(Y-1) + (setcdr prev (cdr rest)) ; eat lap0 + (if (> y 1) + (let ((new (cons 'byte-discardN-preserve-tos (- y 1)))) + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 new) + (setcar (cdr prev) new)) + (byte-compile-log-lap " %s %s\t-->\t<deleted>" lap0 lap1) + (setcdr prev (cddr prev)))) ; eat lap1 + ((= y (+ x 1)) ; --> discard(X) + (setcdr prev (cdr rest)) ; eat lap0 + (let ((new (if (= x 1) + (cons 'byte-discard nil) + (cons 'byte-discardN x)))) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 new) + (setcar (cdr prev) new))) + (t ; --> discard(X) discardN-preserve-tos(Y-X-1) + (let ((new0 (if (= x 1) + (cons 'byte-discard nil) + (cons 'byte-discardN x))) + (new1 (cons 'byte-discardN-preserve-tos (- y x 1)))) + (byte-compile-log-lap " %s %s\t-->\t%s %s" + lap0 lap1 new0 new1) + (setcar rest new0) + (setcar (cdr rest) new1))))) + (setq keep-going t)) + + ;; + ;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y: + ;; + ((and (eq (car lap0) 'byte-goto) + (let ((tmp (cdr (memq (cdr lap0) (cdr lap-head))))) + (and + tmp + (or (memq (caar tmp) '(byte-discard byte-discardN)) + ;; Make sure we don't hoist a discardN-preserve-tos + ;; that really should be merged or deleted instead. + (and (or (eq (caar tmp) 'byte-discardN-preserve-tos) + (and (eq (caar tmp) 'byte-stack-set) + (eql (cdar tmp) 1))) + (let ((next (cadr tmp))) + (not (or (memq (car next) + '(byte-discardN-preserve-tos + byte-return)) + (and (eq (car next) 'byte-stack-set) + (eql (cdr next) 1))))))) + (progn + (byte-compile-log-lap + " goto-X .. X: \t-->\t%s goto-X.. X: %s Y:" + (car tmp) (car tmp)) + (setq keep-going t) + (let* ((newtag (byte-compile-make-tag)) + ;; Make a copy, since we sometimes modify + ;; insts in-place! + (newdiscard (cons (caar tmp) (cdar tmp))) + (newjmp (cons (car lap0) newtag))) + ;; Push new tag after the discard. + (push newtag (cdr tmp)) + (setcar rest newdiscard) + (push newjmp (cdr rest))) + t))))) + + ;; + ;; UNARY discardN-preserve-tos --> discardN-preserve-tos UNARY + ;; where UNARY takes and produces a single value on the stack + ;; + ((and (memq (car lap0) unary-ops) + (or (eq (car lap1) 'byte-discardN-preserve-tos) + (and (eq (car lap1) 'byte-stack-set) + (eql (cdr lap1) 1))) + ;; unless followed by return (which will eat the discard) + (not (eq (car lap2) 'byte-return))) + (setq keep-going t) + (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) + (setcar rest lap1) + (setcar (cdr rest) lap0)) + + ;; + ;; PRODUCER discardN-preserve-tos(X) --> discard(X) PRODUCER + ;; where PRODUCER pushes a result without looking at the stack: + ;; const, varref, point etc. + ;; + ((and (memq (car lap0) producer-ops) + (or (eq (car lap1) 'byte-discardN-preserve-tos) + (and (eq (car lap1) 'byte-stack-set) + (eql (cdr lap1) 1))) + ;; unless followed by return (which will eat the discard) + (not (eq (car lap2) 'byte-return))) + (setq keep-going t) + (let ((newdiscard (if (eql (cdr lap1) 1) + (cons 'byte-discard nil) + (cons 'byte-discardN (cdr lap1))))) + (byte-compile-log-lap + " %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0) + (setf (car rest) newdiscard) + (setf (cadr rest) lap0))) + + (t + ;; If no rule matched, advance and try again. + (setq prev (cdr prev)))))))) ;; Cleanup stage: ;; Rebuild byte-compile-constants / byte-compile-variables. ;; Simple optimizations that would inhibit other optimizations if they @@ -2542,90 +3028,84 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; need to do more than once. (setq byte-compile-constants nil byte-compile-variables nil) - (setq rest lap) (byte-compile-log-lap " ---- final pass") - (while rest - (setq lap0 (car rest) - lap1 (nth 1 rest)) - (if (memq (car lap0) byte-constref-ops) - (if (memq (car lap0) '(byte-constant byte-constant2)) - (unless (memq (cdr lap0) byte-compile-constants) - (setq byte-compile-constants (cons (cdr lap0) - byte-compile-constants))) - (unless (memq (cdr lap0) byte-compile-variables) - (setq byte-compile-variables (cons (cdr lap0) - byte-compile-variables))))) - (cond (;; - ;; const-C varset-X const-C --> const-C dup varset-X - ;; const-C varbind-X const-C --> const-C dup varbind-X - ;; - (and (eq (car lap0) 'byte-constant) - (eq (car (nth 2 rest)) 'byte-constant) - (eq (cdr lap0) (cdr (nth 2 rest))) - (memq (car lap1) '(byte-varbind byte-varset))) - (byte-compile-log-lap " %s %s %s\t-->\t%s dup %s" - lap0 lap1 lap0 lap0 lap1) - (setcar (cdr (cdr rest)) (cons (car lap1) (cdr lap1))) - (setcar (cdr rest) (cons 'byte-dup 0)) - (setq add-depth 1)) - ;; - ;; const-X [dup/const-X ...] --> const-X [dup ...] dup - ;; varref-X [dup/varref-X ...] --> varref-X [dup ...] dup - ;; - ((memq (car lap0) '(byte-constant byte-varref)) - (setq tmp rest - tmp2 nil) - (while (progn - (while (eq 'byte-dup (car (car (setq tmp (cdr tmp)))))) - (and (eq (cdr lap0) (cdr (car tmp))) - (eq (car lap0) (car (car tmp))))) - (setcar tmp (cons 'byte-dup 0)) - (setq tmp2 t)) - (if tmp2 - (byte-compile-log-lap - " %s [dup/%s]...\t-->\t%s dup..." lap0 lap0 lap0))) - ;; - ;; unbind-N unbind-M --> unbind-(N+M) - ;; - ((and (eq 'byte-unbind (car lap0)) - (eq 'byte-unbind (car lap1))) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 - (cons 'byte-unbind - (+ (cdr lap0) (cdr lap1)))) - (setq lap (delq lap0 lap)) - (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) - - ;; - ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> - ;; discardN-(X+Y) - ;; - ((and (memq (car lap0) - '(byte-discard byte-discardN - byte-discardN-preserve-tos)) - (memq (car lap1) '(byte-discard byte-discardN))) - (setq lap (delq lap0 lap)) - (byte-compile-log-lap - " %s %s\t-->\t(discardN %s)" - lap0 lap1 - (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) - (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) - (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) - (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) - (setcar lap1 'byte-discardN)) - - ;; - ;; discardN-preserve-tos-X discardN-preserve-tos-Y --> - ;; discardN-preserve-tos-(X+Y) - ;; - ((and (eq (car lap0) 'byte-discardN-preserve-tos) - (eq (car lap1) 'byte-discardN-preserve-tos)) - (setq lap (delq lap0 lap)) - (setcdr lap1 (+ (cdr lap0) (cdr lap1))) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) - ) - (setq rest (cdr rest))) - (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) - lap) + (let ((prev lap-head)) + (while (cdr prev) + (let* ((rest (cdr prev)) + (lap0 (car rest)) + (lap1 (nth 1 rest))) + ;; FIXME: Would there ever be a `byte-constant2' op here? + (if (memq (car lap0) byte-constref-ops) + (if (memq (car lap0) '(byte-constant byte-constant2)) + (unless (memq (cdr lap0) byte-compile-constants) + (setq byte-compile-constants (cons (cdr lap0) + byte-compile-constants))) + (unless (memq (cdr lap0) byte-compile-variables) + (setq byte-compile-variables (cons (cdr lap0) + byte-compile-variables))))) + (cond + ;; + ;; const-C varset-X const-C --> const-C dup varset-X + ;; const-C varbind-X const-C --> const-C dup varbind-X + ;; + ((and (eq (car lap0) 'byte-constant) + (eq (car (nth 2 rest)) 'byte-constant) + (eq (cdr lap0) (cdr (nth 2 rest))) + (memq (car lap1) '(byte-varbind byte-varset))) + (byte-compile-log-lap " %s %s %s\t-->\t%s dup %s" + lap0 lap1 lap0 lap0 lap1) + (setcar (cdr (cdr rest)) (cons (car lap1) (cdr lap1))) + (setcar (cdr rest) (cons 'byte-dup 0)) + (setq add-depth 1)) + ;; + ;; const-X [dup/const-X ...] --> const-X [dup ...] dup + ;; varref-X [dup/varref-X ...] --> varref-X [dup ...] dup + ;; + ((memq (car lap0) '(byte-constant byte-varref)) + (let ((tmp rest) + (tmp2 nil)) + (while (progn + (while (eq 'byte-dup (car (car (setq tmp (cdr tmp)))))) + (and (eq (cdr lap0) (cdr (car tmp))) + (eq (car lap0) (car (car tmp))))) + (setcar tmp (cons 'byte-dup 0)) + (setq tmp2 t)) + (if tmp2 + (byte-compile-log-lap + " %s [dup/%s]...\t-->\t%s dup..." lap0 lap0 lap0) + (setq prev (cdr prev))))) + ;; + ;; unbind-N unbind-M --> unbind-(N+M) + ;; + ((and (eq 'byte-unbind (car lap0)) + (eq 'byte-unbind (car lap1))) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 + (cons 'byte-unbind + (+ (cdr lap0) (cdr lap1)))) + (setcdr prev (cdr rest)) + (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) + + ;; + ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> + ;; discardN-(X+Y) + ;; + ((and (memq (car lap0) + '(byte-discard byte-discardN + byte-discardN-preserve-tos)) + (memq (car lap1) '(byte-discard byte-discardN))) + (setcdr prev (cdr rest)) + (byte-compile-log-lap + " %s %s\t-->\t(discardN %s)" + lap0 lap1 + (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcar lap1 'byte-discardN)) + (t + (setq prev (cdr prev))))))) + (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)) + (cdr lap-head))) (provide 'byte-opt) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index eb7d026b146..3e4e4d12cc8 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -145,6 +145,11 @@ So far, FUNCTION can only be a symbol, not a lambda expression." (list 'function-put (list 'quote f) ''side-effect-free (list 'quote val)))) +(defalias 'byte-run--set-important-return-value + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''important-return-value (list 'quote val)))) + (put 'compiler-macro 'edebug-declaration-spec '(&or symbolp ("lambda" &define lambda-list lambda-doc def-body))) @@ -226,6 +231,8 @@ This may shift errors from run-time to compile-time.") (list 'side-effect-free #'byte-run--set-side-effect-free "If non-nil, calls can be ignored if their value is unused. If `error-free', drop calls even if `byte-compile-delete-errors' is nil.") + (list 'important-return-value #'byte-run--set-important-return-value + "If non-nil, warn about calls not using the returned value.") (list 'compiler-macro #'byte-run--set-compiler-macro) (list 'doc-string #'byte-run--set-doc-string) (list 'indent #'byte-run--set-indent) @@ -262,7 +269,8 @@ This is used by `declare'.") (interactive-form nil) (warnings nil) (warn #'(lambda (msg form) - (push (macroexp-warn-and-return msg nil nil t form) + (push (macroexp-warn-and-return + (format-message msg) nil nil t form) warnings)))) (while (and body @@ -486,6 +494,11 @@ convention was modified." Return t if there isn't any." (gethash function advertised-signature-table t)) +(defun byte-run--constant-obsolete-warning (obsolete-name) + (if (memq obsolete-name '(nil t)) + (error "Can't make `%s' obsolete; did you forget a quote mark?" + obsolete-name))) + (defun make-obsolete (obsolete-name current-name when) "Make the byte-compiler warn that function OBSOLETE-NAME is obsolete. OBSOLETE-NAME should be a function name or macro name (a symbol). @@ -495,6 +508,7 @@ If CURRENT-NAME is a string, that is the `use instead' message \(it should end with a period, and not start with a capital). WHEN should be a string indicating when the function was first made obsolete, for example a date or a release number." + (byte-run--constant-obsolete-warning obsolete-name) (put obsolete-name 'byte-obsolete-info ;; The second entry used to hold the `byte-compile' handler, but ;; is not used any more nowadays. @@ -531,6 +545,7 @@ WHEN should be a string indicating when the variable was first made obsolete, for example a date or a release number. ACCESS-TYPE if non-nil should specify the kind of access that will trigger obsolescence warnings; it can be either `get' or `set'." + (byte-run--constant-obsolete-warning obsolete-name) (put obsolete-name 'byte-obsolete-variable (purecopy (list current-name access-type when))) obsolete-name) @@ -649,11 +664,8 @@ in `byte-compile-warning-types'; see the variable `byte-compile-warnings' for a fuller explanation of the warning types. The types that can be suppressed with this macro are `free-vars', `callargs', `redefine', `obsolete', -`interactive-only', `lexical', `mapcar', `constants' and -`suspicious'. - -For the `mapcar' case, only the `mapcar' function can be used in -the symbol list. For `suspicious', only `set-buffer' and `lsh' can be used." +`interactive-only', `lexical', `ignored-return-value', `constants', +`suspicious', `empty-body' and `mutate-constant'." ;; Note: during compilation, this definition is overridden by the one in ;; byte-compile-initial-macro-environment. (declare (debug (sexp body)) (indent 1)) @@ -679,11 +691,11 @@ Otherwise, return nil. For internal use only." ;; This is called from lread.c and therefore needs to be preloaded. (if lread--unescaped-character-literals (let ((sorted (sort lread--unescaped-character-literals #'<))) - (format-message "unescaped character literals %s detected, %s expected!" - (mapconcat (lambda (char) (format "`?%c'" char)) - sorted ", ") - (mapconcat (lambda (char) (format "`?\\%c'" char)) - sorted ", "))))) + (format "unescaped character literals %s detected, %s expected!" + (mapconcat (lambda (char) (format-message "`?%c'" char)) + sorted ", ") + (mapconcat (lambda (char) (format-message "`?\\%c'" char)) + sorted ", "))))) (defun byte-compile-info (string &optional message type) "Format STRING in a way that looks pleasing in the compilation output. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index d093d95a775..6c5051d70c4 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -292,48 +292,60 @@ The information is logged to `byte-compile-log-buffer'." ;;;###autoload(put 'byte-compile-error-on-warn 'safe-local-variable 'booleanp) (defconst byte-compile-warning-types - '(redefine callargs free-vars unresolved - obsolete noruntime interactive-only - make-local mapcar constants suspicious lexical lexical-dynamic - docstrings docstrings-non-ascii-quotes not-unused) + '( callargs constants + docstrings docstrings-non-ascii-quotes docstrings-wide + empty-body free-vars ignored-return-value interactive-only + lexical lexical-dynamic make-local + mapcar ; obsolete + mutate-constant noruntime not-unused obsolete redefine suspicious + unresolved) "The list of warning types used when `byte-compile-warnings' is t.") (defcustom byte-compile-warnings t "List of warnings that the byte-compiler should issue (t for almost all). Elements of the list may be: - free-vars references to variables not in the current lexical scope. - unresolved calls to unknown functions. callargs function calls with args that don't match the definition. - redefine function name redefined from a macro to ordinary function or vice - versa, or redefined to take a different number of arguments. - obsolete obsolete variables and functions. - noruntime functions that may not be defined at runtime (typically - defined only under `eval-when-compile'). + constants let-binding of, or assignment to, constants/nonvariables. + docstrings various docstring stylistic issues, such as incorrect use + of single quotes + docstrings-non-ascii-quotes + docstrings that have non-ASCII quotes. + Only enabled when `docstrings' also is. + docstrings-wide + docstrings that are too wide, containing lines longer than both + `byte-compile-docstring-max-column' and `fill-column' characters. + Only enabled when `docstrings' also is. + empty-body body argument to a special form or macro is empty. + free-vars references to variables not in the current lexical scope. + ignored-return-value + function called without using the return value where this + is likely to be a mistake. interactive-only commands that normally shouldn't be called from Lisp code. lexical global/dynamic variables lacking a prefix. lexical-dynamic lexically bound variable declared dynamic elsewhere make-local calls to `make-variable-buffer-local' that may be incorrect. - mapcar mapcar called for effect. + mutate-constant + code that mutates program constants such as quoted lists. + noruntime functions that may not be defined at runtime (typically + defined only under `eval-when-compile'). not-unused warning about using variables with symbol names starting with _. - constants let-binding of, or assignment to, constants/nonvariables. - docstrings docstrings that are too wide (longer than - `byte-compile-docstring-max-column' or - `fill-column' characters, whichever is bigger) or - have other stylistic issues. - docstrings-non-ascii-quotes docstrings that have non-ASCII quotes. - This depends on the `docstrings' warning type. + obsolete obsolete variables and functions. + redefine function name redefined from a macro to ordinary function or vice + versa, or redefined to take a different number of arguments. suspicious constructs that usually don't do what the coder wanted. + unresolved calls to unknown functions. If the list begins with `not', then the remaining elements specify warnings to -suppress. For example, (not mapcar) will suppress warnings about mapcar. +suppress. For example, (not free-vars) will suppress the `free-vars' warning. The t value means \"all non experimental warning types\", and excludes the types in `byte-compile--emacs-build-warning-types'. A value of `all' really means all." - :type `(choice (const :tag "All" t) + :type `(choice (const :tag "Default selection" t) + (const :tag "All" all) (set :menu-tag "Some" ,@(mapcar (lambda (x) `(const ,x)) byte-compile-warning-types)))) @@ -483,8 +495,7 @@ Return the compile-time value of FORM." ;; 3.2.3.1, "Processing of Top Level Forms". The semantics are very ;; subtle: see test/lisp/emacs-lisp/bytecomp-tests.el for interesting ;; cases. - (let ((print-symbols-bare t)) ; Possibly redundant binding. - (setf form (macroexp-macroexpand form byte-compile-macro-environment))) + (setf form (macroexp-macroexpand form byte-compile-macro-environment)) (if (eq (car-safe form) 'progn) (cons (car form) (mapcar (lambda (subform) @@ -493,6 +504,42 @@ Return the compile-time value of FORM." (cdr form))) (funcall non-toplevel-case form))) + +(defvar bytecomp--copy-tree-seen) + +(defun bytecomp--copy-tree-1 (tree) + ;; TREE must be a cons. + (or (gethash tree bytecomp--copy-tree-seen) + (let* ((next (cdr tree)) + (result (cons nil next)) + (copy result)) + (while (progn + (puthash tree copy bytecomp--copy-tree-seen) + (let ((a (car tree))) + (setcar copy (if (consp a) + (bytecomp--copy-tree-1 a) + a))) + (and (consp next) + (let ((tail (gethash next bytecomp--copy-tree-seen))) + (if tail + (progn (setcdr copy tail) + nil) + (setq tree next) + (setq next (cdr next)) + (let ((prev copy)) + (setq copy (cons nil next)) + (setcdr prev copy) + t)))))) + result))) + +(defun bytecomp--copy-tree (tree) + "Make a copy of TREE, preserving any circular structure therein. +Only conses are traversed and duplicated, not arrays or any other structure." + (if (consp tree) + (let ((bytecomp--copy-tree-seen (make-hash-table :test #'eq))) + (bytecomp--copy-tree-1 tree)) + tree)) + (defconst byte-compile-initial-macro-environment `( ;; (byte-compiler-options . (lambda (&rest forms) @@ -526,13 +573,13 @@ Return the compile-time value of FORM." ;; Don't compile here, since we don't know ;; whether to compile as byte-compile-form ;; or byte-compile-file-form. - (let* ((print-symbols-bare t) ; Possibly redundant binding. - (expanded - (byte-run-strip-symbol-positions - (macroexpand--all-toplevel - form - macroexpand-all-environment)))) - (eval expanded lexical-binding) + (let ((expanded + (macroexpand--all-toplevel + form + macroexpand-all-environment))) + (eval (byte-run-strip-symbol-positions + (bytecomp--copy-tree expanded)) + lexical-binding) expanded))))) (with-suppressed-warnings . ,(lambda (warnings &rest body) @@ -541,15 +588,19 @@ Return the compile-time value of FORM." ;; Later `internal--with-suppressed-warnings' binds it again, this ;; time in order to affect warnings emitted during the ;; compilation itself. - (let ((byte-compile--suppressed-warnings - (append warnings byte-compile--suppressed-warnings))) - ;; This function doesn't exist, but is just a placeholder - ;; symbol to hook up with the - ;; `byte-hunk-handler'/`byte-defop-compiler-1' machinery. - `(internal--with-suppressed-warnings - ',warnings - ,(macroexpand-all `(progn ,@body) - macroexpand-all-environment)))))) + (if body + (let ((byte-compile--suppressed-warnings + (append warnings byte-compile--suppressed-warnings))) + ;; This function doesn't exist, but is just a placeholder + ;; symbol to hook up with the + ;; `byte-hunk-handler'/`byte-defop-compiler-1' machinery. + `(internal--with-suppressed-warnings + ',warnings + ,(macroexpand-all `(progn ,@body) + macroexpand-all-environment))) + (macroexp-warn-and-return + (format-message "`with-suppressed-warnings' with empty body") + nil '(empty-body with-suppressed-warnings) t warnings))))) "The default macro-environment passed to macroexpand by the compiler. Placing a macro here will cause a macro to have different semantics when expanded by the compiler as when expanded by the interpreter.") @@ -1081,7 +1132,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." ;; we arguably should add it to b-c-noruntime-functions, ;; but it's not clear it's worth the trouble ;; trying to recognize that case. - (unless (get f 'function-history) + (unless (or (get f 'function-history) + (assq f byte-compile-function-environment)) (push f byte-compile-noruntime-functions))))))))))))) (defun byte-compile-eval-before-compile (form) @@ -1569,61 +1621,9 @@ extra args." "`%s' called with %d args to fill %d format field(s)" (car form) nargs nfields))))) -(dolist (elt '(format message error)) +(dolist (elt '(format message format-message error)) (put elt 'byte-compile-format-like t)) -(defun byte-compile--suspicious-defcustom-choice (type) - "Say whether defcustom TYPE looks odd." - ;; Check whether there's anything like (choice (const :tag "foo" ;; 'bar)). - ;; We don't actually follow the syntax for defcustom types, but this - ;; should be good enough. - (catch 'found - (if (and (consp type) - (proper-list-p type)) - (if (memq (car type) '(const other)) - (when (assq 'quote type) - (throw 'found t)) - (when (memq t (mapcar #'byte-compile--suspicious-defcustom-choice - type)) - (throw 'found t))) - nil))) - -;; Warn if a custom definition fails to specify :group, or :type. -(defun byte-compile-nogroup-warn (form) - (let ((keyword-args (cdr (cdr (cdr (cdr form))))) - (name (cadr form))) - (when (eq (car-safe name) 'quote) - (when (eq (car form) 'custom-declare-variable) - (let ((type (plist-get keyword-args :type))) - (cond - ((not type) - (byte-compile-warn-x (cadr name) - "defcustom for `%s' fails to specify type" - (cadr name))) - ((byte-compile--suspicious-defcustom-choice type) - (byte-compile-warn-x - (cadr name) - "defcustom for `%s' has syntactically odd type `%s'" - (cadr name) type))))) - (if (and (memq (car form) '(custom-declare-face custom-declare-variable)) - byte-compile-current-group) - ;; The group will be provided implicitly. - nil - (or (and (eq (car form) 'custom-declare-group) - (equal name ''emacs)) - (plist-get keyword-args :group) - (byte-compile-warn-x (cadr name) - "%s for `%s' fails to specify containing group" - (cdr (assq (car form) - '((custom-declare-group . defgroup) - (custom-declare-face . defface) - (custom-declare-variable . defcustom)))) - (cadr name))) - ;; Update the current group, if needed. - (if (and byte-compile-current-file ;Only when compiling a whole file. - (eq (car form) 'custom-declare-group)) - (setq byte-compile-current-group (cadr name))))))) - ;; Warn if the function or macro is being redefined with a different ;; number of arguments. (defun byte-compile-arglist-warn (name arglist macrop) @@ -1674,53 +1674,75 @@ extra args." (if (equal sig1 '(1 . 1)) "argument" "arguments") (byte-compile-arglist-signature-string sig2))))))) -(defvar byte-compile--wide-docstring-substitution-len 3 - "Substitution width used in `byte-compile--wide-docstring-p'. -This is a heuristic for guessing the width of a documentation -string: `byte-compile--wide-docstring-p' assumes that any -`substitute-command-keys' command substitutions are this long.") - -(defun byte-compile--wide-docstring-p (docstring col) - "Return t if string DOCSTRING is wider than COL. +(defun bytecomp--docstring-line-width (str) + "An approximation of the displayed width of docstring line STR." + ;; For literal key sequence substitutions (e.g. "\\`C-h'"), just + ;; remove the markup as `substitute-command-keys' would. + (when (string-search "\\`" str) + (setq str (replace-regexp-in-string + (rx "\\`" (group (* (not "'"))) "'") + "\\1" + str t))) + ;; Heuristic: We can't reliably do `substitute-command-keys' + ;; substitutions, since the value of a keymap in general can't be + ;; known at compile time. So instead, we assume that these + ;; substitutions are of some constant length. + (when (string-search "\\[" str) + (setq str (replace-regexp-in-string + (rx "\\[" (* (not "]")) "]") + ;; We assume that substitutions have this length. + ;; To preserve the non-expansive property of the transform, + ;; it shouldn't be more than 3 characters long. + "xxx" + str t t))) + (setq str + (replace-regexp-in-string + (rx (or + ;; Ignore some URLs. + (seq "http" (? "s") "://" (* nonl)) + ;; Ignore these `substitute-command-keys' substitutions. + (seq "\\" (or "=" + (seq "<" (* (not ">")) ">") + (seq "{" (* (not "}")) "}"))) + ;; Ignore the function signature that's stashed at the end of + ;; the doc string (in some circumstances). + (seq bol "(" (+ (any word "-/:[]&")) + ;; One or more arguments. + (+ " " (or + ;; Arguments. + (+ (or (syntax symbol) + (any word "-/:[]&=()<>.,?^\\#*'\""))) + ;; Argument that is a list. + (seq "(" (* (not ")")) ")"))) + ")"))) + "" str t t)) + (length str)) + +(defun byte-compile--wide-docstring-p (docstring max-width) + "Whether DOCSTRING contains a line wider than MAX-WIDTH. Ignore all `substitute-command-keys' substitutions, except for -the `\\\\=[command]' ones that are assumed to be of length -`byte-compile--wide-docstring-substitution-len'. Also ignore -URLs." - (string-match - (format "^.\\{%d,\\}$" (min (1+ col) #xffff)) ; Heed RE_DUP_MAX. - (replace-regexp-in-string - (rx (or - ;; Ignore some URLs. - (seq "http" (? "s") "://" (* nonl)) - ;; Ignore these `substitute-command-keys' substitutions. - (seq "\\" (or "=" - (seq "<" (* (not ">")) ">") - (seq "{" (* (not "}")) "}"))) - ;; Ignore the function signature that's stashed at the end of - ;; the doc string (in some circumstances). - (seq bol "(" (+ (any word "-/:[]&")) - ;; One or more arguments. - (+ " " (or - ;; Arguments. - (+ (or (syntax symbol) - (any word "-/:[]&=()<>.,?^\\#*'\""))) - ;; Argument that is a list. - (seq "(" (* (not ")")) ")"))) - ")"))) - "" - ;; Heuristic: We can't reliably do `substitute-command-keys' - ;; substitutions, since the value of a keymap in general can't be - ;; known at compile time. So instead, we assume that these - ;; substitutions are of some length N. - (replace-regexp-in-string - (rx "\\[" (* (not "]")) "]") - (make-string byte-compile--wide-docstring-substitution-len ?x) - ;; For literal key sequence substitutions (e.g. "\\`C-h'"), just - ;; remove the markup as `substitute-command-keys' would. - (replace-regexp-in-string - (rx "\\`" (group (* (not "'"))) "'") - "\\1" - docstring))))) +the `\\\\=[command]' ones that are assumed to be of a fixed length. +Also ignore URLs." + (let ((string-len (length docstring)) + (start 0) + (too-wide nil)) + (while (< start string-len) + (let ((eol (or (string-search "\n" docstring start) + string-len))) + ;; Since `bytecomp--docstring-line-width' is non-expansive, + ;; we can safely assume that if the raw length is + ;; within the allowed width, then so is the transformed width. + ;; This allows us to avoid the very expensive transformation in + ;; most cases. + (if (and (> (- eol start) max-width) + (> (bytecomp--docstring-line-width + (substring docstring start eol)) + max-width)) + (progn + (setq too-wide t) + (setq start string-len)) + (setq start (1+ eol))))) + too-wide)) (defcustom byte-compile-docstring-max-column 80 "Recommended maximum width of doc string lines. @@ -1741,8 +1763,11 @@ Warn if documentation string of FORM is too wide. It is too wide if it has any lines longer than the largest of `fill-column' and `byte-compile-docstring-max-column'." (when (byte-compile-warning-enabled-p 'docstrings) - (let ((col (max byte-compile-docstring-max-column fill-column)) - kind name docs) + (let* ((kind nil) (name nil) (docs nil) + (prefix (lambda () + (format "%s%s" + kind + (if name (format-message " `%s' " name) ""))))) (pcase (car form) ((or 'autoload 'custom-declare-variable 'defalias 'defconst 'define-abbrev-table @@ -1750,33 +1775,41 @@ It is too wide if it has any lines longer than the largest of 'custom-declare-face) (setq kind (nth 0 form)) (setq name (nth 1 form)) + (when (and (consp name) (eq (car name) 'quote)) + (setq name (cadr name))) (setq docs (nth 3 form))) ('lambda (setq kind "") ; can't be "function", unfortunately - (setq docs (and (stringp (nth 2 form)) - (nth 2 form))))) - (when (and (consp name) (eq (car name) 'quote)) - (setq name (cadr name))) - (setq name (if name (format " `%s' " name) "")) + (setq docs (nth 2 form)))) (when (and kind docs (stringp docs)) - (when (byte-compile--wide-docstring-p docs col) - (byte-compile-warn-x - name - "%s%sdocstring wider than %s characters" - kind name col)) + (let ((col (max byte-compile-docstring-max-column fill-column))) + (when (and (byte-compile-warning-enabled-p 'docstrings-wide) + (byte-compile--wide-docstring-p docs col)) + (byte-compile-warn-x + name + "%sdocstring wider than %s characters" (funcall prefix) col))) ;; There's a "naked" ' character before a symbol/list, so it ;; should probably be quoted with \=. - (when (string-match-p "\\( [\"#]\\|[ \t]\\|^\\)'[a-z(]" docs) + (when (string-match-p (rx (| (in " \t") bol) + (? (in "\"#")) + "'" + (in "A-Za-z" "(")) + docs) (byte-compile-warn-x - name "%s%sdocstring has wrong usage of unescaped single quotes (use \\= or different quoting)" - kind name)) + name + (concat "%sdocstring has wrong usage of unescaped single quotes" + " (use \\=%c or different quoting such as %c...%c)") + (funcall prefix) ?' ?` ?')) ;; There's a "Unicode quote" in the string -- it should probably ;; be an ASCII one instead. (when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes) - (when (string-match-p "\\( \"\\|[ \t]\\|^\\)[‘’]" docs) + (when (string-match-p (rx (| " \"" (in " \t") bol) + (in "‘’")) + docs) (byte-compile-warn-x - name "%s%sdocstring has wrong usage of \"fancy\" single quotation marks" - kind name)))))) + name + "%sdocstring uses curved single quotes; use %s instead of ‘...’" + (funcall prefix) "`...'")))))) form) ;; If we have compiled any calls to functions which are not known to be @@ -1828,8 +1861,6 @@ It is too wide if it has any lines longer than the largest of (byte-compile-dynamic byte-compile-dynamic) (byte-compile-dynamic-docstrings byte-compile-dynamic-docstrings) - ;; (byte-compile-generate-emacs19-bytecodes - ;; byte-compile-generate-emacs19-bytecodes) (byte-compile-warnings byte-compile-warnings) ;; Indicate that we're not currently loading some file. ;; This is used in `macroexp-file-name' to make sure that @@ -1845,35 +1876,37 @@ It is too wide if it has any lines longer than the largest of (defmacro displaying-byte-compile-warnings (&rest body) (declare (debug (def-body))) - `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body)) - (warning-series-started - (and (markerp warning-series) - (eq (marker-buffer warning-series) - (get-buffer byte-compile-log-buffer)))) - (byte-compile-form-stack byte-compile-form-stack)) - (if (or (eq warning-series 'byte-compile-warning-series) - warning-series-started) - ;; warning-series does come from compilation, - ;; so don't bind it, but maybe do set it. - (let (tem) - ;; Log the file name. Record position of that text. - (setq tem (byte-compile-log-file)) - (unless warning-series-started - (setq warning-series (or tem 'byte-compile-warning-series))) - (if byte-compile-debug - (funcall --displaying-byte-compile-warnings-fn) - (condition-case error-info - (funcall --displaying-byte-compile-warnings-fn) - (error (byte-compile-report-error error-info))))) - ;; warning-series does not come from compilation, so bind it. - (let ((warning-series - ;; Log the file name. Record position of that text. - (or (byte-compile-log-file) 'byte-compile-warning-series))) - (if byte-compile-debug - (funcall --displaying-byte-compile-warnings-fn) - (condition-case error-info - (funcall --displaying-byte-compile-warnings-fn) - (error (byte-compile-report-error error-info)))))))) + `(bytecomp--displaying-warnings (lambda () ,@body))) + +(defun bytecomp--displaying-warnings (body-fn) + (let* ((warning-series-started + (and (markerp warning-series) + (eq (marker-buffer warning-series) + (get-buffer byte-compile-log-buffer)))) + (byte-compile-form-stack byte-compile-form-stack)) + (if (or (eq warning-series 'byte-compile-warning-series) + warning-series-started) + ;; warning-series does come from compilation, + ;; so don't bind it, but maybe do set it. + (let (tem) + ;; Log the file name. Record position of that text. + (setq tem (byte-compile-log-file)) + (unless warning-series-started + (setq warning-series (or tem 'byte-compile-warning-series))) + (if byte-compile-debug + (funcall body-fn) + (condition-case error-info + (funcall body-fn) + (error (byte-compile-report-error error-info))))) + ;; warning-series does not come from compilation, so bind it. + (let ((warning-series + ;; Log the file name. Record position of that text. + (or (byte-compile-log-file) 'byte-compile-warning-series))) + (if byte-compile-debug + (funcall body-fn) + (condition-case error-info + (funcall body-fn) + (error (byte-compile-report-error error-info)))))))) ;;;###autoload (defun byte-force-recompile (directory) @@ -2170,6 +2203,11 @@ See also `emacs-lisp-byte-compile-and-load'." filename buffer-file-name)) ;; Don't inherit lexical-binding from caller (bug#12938). (unless (local-variable-p 'lexical-binding) + (let ((byte-compile-current-buffer (current-buffer))) + (displaying-byte-compile-warnings + (byte-compile-warn-x + (position-symbol 'a (point-min)) + "file has no `lexical-binding' directive on its first line"))) (setq-local lexical-binding nil)) ;; Set the default directory, in case an eval-when-compile uses it. (setq default-directory (file-name-directory filename))) @@ -2436,17 +2474,15 @@ Call from the source buffer." ;; 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-symbols-bare t) ; Possibly redundant binding. - (print-escape-newlines t) + (let ((print-escape-newlines t) (print-length nil) (print-level nil) (print-quoted t) (print-gensym t) (print-circle t)) ; Handle circular data structures. - (if (and (memq (car-safe form) '(defvar defvaralias defconst - autoload custom-declare-variable)) - (stringp (nth 3 form))) - (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil + (if (memq (car-safe form) '(defvar defvaralias defconst + autoload custom-declare-variable)) + (byte-compile-output-docform nil nil nil '("\n(" ")") form nil 3 nil (memq (car form) '(defvaralias autoload custom-declare-variable))) @@ -2456,10 +2492,105 @@ Call from the source buffer." (defvar byte-compile--for-effect) -(defun byte-compile-output-docform (preface name info form specindex quoted) - "Print a form with a doc string. INFO is (prefix doc-index postfix). -If PREFACE and NAME are non-nil, print them too, -before INFO and the FORM but after the doc string itself. +(defun byte-compile--output-docform-recurse + (info position form cvecindex docindex specindex quoted) + "Print a form with a doc string. INFO is (prefix postfix). +POSITION is where the next doc string is to be inserted. +CVECINDEX is the index in the FORM of the constant vector, or nil. +DOCINDEX is the index of the doc string (or nil) in the FORM. +If SPECINDEX is non-nil, it is the index in FORM +of the function bytecode string. In that case, +we output that argument and the following argument +\(the constants vector) together, for lazy loading. +QUOTED says that we have to put a quote before the +list that represents a doc string reference. +`defvaralias', `autoload' and `custom-declare-variable' need that. + +Return the position after any inserted docstrings as comments." + (let ((index 0) + doc-string-position) + ;; Insert the doc string, and make it a comment with #@LENGTH. + (when (and byte-compile-dynamic-docstrings + (stringp (nth docindex form))) + (goto-char position) + (setq doc-string-position + (byte-compile-output-as-comment + (nth docindex form) nil) + position (point)) + (goto-char (point-max))) + + (insert (car info)) + (prin1 (car form) byte-compile--outbuffer) + (while (setq form (cdr form)) + (setq index (1+ index)) + (insert " ") + (cond ((and (numberp specindex) (= index specindex) + ;; Don't handle the definition dynamically + ;; if it refers (or might refer) + ;; to objects already output + ;; (for instance, gensyms in the arg list). + (let (non-nil) + (when (hash-table-p print-number-table) + (maphash (lambda (_k v) (if v (setq non-nil t))) + print-number-table)) + (not non-nil))) + ;; Output the byte code and constants specially + ;; for lazy dynamic loading. + (goto-char position) + (let ((lazy-position (byte-compile-output-as-comment + (cons (car form) (nth 1 form)) + t))) + (setq position (point)) + (goto-char (point-max)) + (princ (format "(#$ . %d) nil" lazy-position) + byte-compile--outbuffer) + (setq form (cdr form)) + (setq index (1+ index)))) + ((eq index cvecindex) + (let* ((cvec (car form)) + (len (length cvec)) + (index2 0) + elt) + (insert "[") + (while (< index2 len) + (setq elt (aref cvec index2)) + (if (byte-code-function-p elt) + (setq position + (byte-compile--output-docform-recurse + '("#[" "]") position + (append elt nil) ; Convert the vector to a list. + 2 4 specindex nil)) + (prin1 elt byte-compile--outbuffer)) + (setq index2 (1+ index2)) + (unless (eq index2 len) + (insert " "))) + (insert "]"))) + ((= index docindex) + (cond + (doc-string-position + (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") + doc-string-position) + byte-compile--outbuffer)) + ((stringp (car form)) + (let ((print-escape-newlines nil)) + (goto-char (prog1 (1+ (point)) + (prin1 (car form) + byte-compile--outbuffer))) + (insert "\\\n") + (goto-char (point-max)))) + (t (prin1 (car form) byte-compile--outbuffer)))) + (t (prin1 (car form) byte-compile--outbuffer)))) + (insert (cadr info)) + position)) + +(defun byte-compile-output-docform (preface tailpiece name info form + cvecindex docindex + specindex quoted) + "Print a form with a doc string. INFO is (prefix postfix). +If PREFACE, NAME, and TAILPIECE are non-nil, print them too, +before/after INFO and the FORM but after the doc string itself. +CVECINDEX is the index in the FORM of the constant vector, or nil. +DOCINDEX is the index of the doc string (or nil) in the FORM. If SPECINDEX is non-nil, it is the index in FORM of the function bytecode string. In that case, we output that argument and the following argument @@ -2469,74 +2600,30 @@ list that represents a doc string reference. `defvaralias', `autoload' and `custom-declare-variable' need that." ;; We need to examine byte-compile-dynamic-docstrings ;; in the input buffer (now current), not in the output buffer. - (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) + (let ((byte-compile-dynamic-docstrings byte-compile-dynamic-docstrings)) (with-current-buffer byte-compile--outbuffer - (let (position - (print-symbols-bare t)) ; Possibly redundant binding. - ;; Insert the doc string, and make it a comment with #@LENGTH. - (when (and (>= (nth 1 info) 0) dynamic-docstrings) - (setq position (byte-compile-output-as-comment - (nth (nth 1 info) form) nil))) - - (let ((print-continuous-numbering t) - print-number-table - (index 0) - ;; FIXME: The bindings below are only needed for when we're - ;; called from ...-defmumble. - (print-escape-newlines t) - (print-length nil) - (print-level nil) - (print-quoted t) - (print-gensym t) - (print-circle t)) ; Handle circular data structures. - (if preface - (progn - ;; FIXME: We don't handle uninterned names correctly. - ;; E.g. if cl-define-compiler-macro uses uninterned name we get: - ;; (defalias '#1=#:foo--cmacro #[514 ...]) - ;; (put 'foo 'compiler-macro '#:foo--cmacro) - (insert preface) - (prin1 name byte-compile--outbuffer))) - (insert (car info)) - (prin1 (car form) byte-compile--outbuffer) - (while (setq form (cdr form)) - (setq index (1+ index)) - (insert " ") - (cond ((and (numberp specindex) (= index specindex) - ;; Don't handle the definition dynamically - ;; if it refers (or might refer) - ;; to objects already output - ;; (for instance, gensyms in the arg list). - (let (non-nil) - (when (hash-table-p print-number-table) - (maphash (lambda (_k v) (if v (setq non-nil t))) - print-number-table)) - (not non-nil))) - ;; Output the byte code and constants specially - ;; for lazy dynamic loading. - (let ((position - (byte-compile-output-as-comment - (cons (car form) (nth 1 form)) - t))) - (princ (format "(#$ . %d) nil" position) - byte-compile--outbuffer) - (setq form (cdr form)) - (setq index (1+ index)))) - ((= index (nth 1 info)) - (if position - (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") - position) - byte-compile--outbuffer) - (let ((print-escape-newlines nil)) - (goto-char (prog1 (1+ (point)) - (prin1 (car form) - byte-compile--outbuffer))) - (insert "\\\n") - (goto-char (point-max))))) - (t - (prin1 (car form) byte-compile--outbuffer))))) - (insert (nth 2 info))))) - nil) + (let ((position (point)) + (print-continuous-numbering t) + print-number-table + ;; FIXME: The bindings below are only needed for when we're + ;; called from ...-defmumble. + (print-escape-newlines t) + (print-length nil) + (print-level nil) + (print-quoted t) + (print-gensym t) + (print-circle t)) ; Handle circular data structures. + (when preface + ;; FIXME: We don't handle uninterned names correctly. + ;; E.g. if cl-define-compiler-macro uses uninterned name we get: + ;; (defalias '#1=#:foo--cmacro #[514 ...]) + ;; (put 'foo 'compiler-macro '#:foo--cmacro) + (insert preface) + (prin1 name byte-compile--outbuffer)) + (byte-compile--output-docform-recurse + info position form cvecindex docindex specindex quoted) + (when tailpiece + (insert tailpiece)))))) (defun byte-compile-keep-pending (form &optional handler) (if (memq byte-optimize '(t source)) @@ -2568,8 +2655,7 @@ list that represents a doc string reference. byte-compile-jump-tables nil)))) (defun byte-compile-preprocess (form &optional _for-effect) - (let ((print-symbols-bare t)) ; Possibly redundant binding. - (setq form (macroexpand-all form byte-compile-macro-environment))) + (setq form (macroexpand-all form byte-compile-macro-environment)) ;; FIXME: We should run byte-optimize-form here, but it currently does not ;; recurse through all the code, so we'd have to fix this first. ;; Maybe a good fix would be to merge byte-optimize-form into @@ -2580,16 +2666,12 @@ list that represents a doc string reference. ;; byte-hunk-handlers cannot call this! (defun byte-compile-toplevel-file-form (top-level-form) - ;; (let ((byte-compile-form-stack - ;; (cons top-level-form byte-compile-form-stack))) - (push top-level-form byte-compile-form-stack) - (prog1 - (byte-compile-recurse-toplevel - top-level-form - (lambda (form) - (let ((byte-compile-current-form nil)) ; close over this for warnings. - (byte-compile-file-form (byte-compile-preprocess form t))))) - (pop byte-compile-form-stack))) + (macroexp--with-extended-form-stack top-level-form + (byte-compile-recurse-toplevel + top-level-form + (lambda (form) + (let ((byte-compile-current-form nil)) ; close over this for warnings. + (byte-compile-file-form (byte-compile-preprocess form t))))))) ;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) @@ -2865,60 +2947,58 @@ not to take responsibility for the actual compilation of the code." ;; Otherwise, we have a bona-fide defun/defmacro definition, and use ;; special code to allow dynamic docstrings and byte-code. (byte-compile-flush-pending) - (let ((index - ;; If there's no doc string, provide -1 as the "doc string - ;; index" so that no element will be treated as a doc string. - (if (not (stringp (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 - "\n(defalias '" - bare-name - (if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]")) - (append code nil) ; Turn byte-code-function-p into list. - (and (atom code) byte-compile-dynamic - 1) - nil)) - (princ ")" byte-compile--outbuffer) + (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 + "\n(defalias '" ")" + bare-name + (if macro '(" '(macro . #[" "])") '(" #[" "]")) + (append code nil) ; Turn byte-code-function-p into list. + 2 4 + (and (atom code) byte-compile-dynamic 1) + nil) t))))) (defun byte-compile-output-as-comment (exp quoted) - "Print Lisp object EXP in the output file, inside a comment. -Return the file (byte) position it will have. -If QUOTED is non-nil, print with quoting; otherwise, print without quoting." + "Print Lisp object EXP in the output file at point, inside a comment. +Return the file (byte) position it will have. Leave point after +the inserted text. If QUOTED is non-nil, print with quoting; +otherwise, print without quoting." (with-current-buffer byte-compile--outbuffer - (let ((position (point))) - + (let ((position (point)) end) ;; Insert EXP, and make it a comment with #@LENGTH. (insert " ") (if quoted (prin1 exp byte-compile--outbuffer) (princ exp byte-compile--outbuffer)) + (setq end (point-marker)) + (set-marker-insertion-type end t) + (goto-char position) ;; Quote certain special characters as needed. ;; get_doc_string in doc.c does the unquoting. - (while (search-forward "\^A" nil t) + (while (search-forward "\^A" end t) (replace-match "\^A\^A" t t)) (goto-char position) - (while (search-forward "\000" nil t) + (while (search-forward "\000" end t) (replace-match "\^A0" t t)) (goto-char position) - (while (search-forward "\037" nil t) + (while (search-forward "\037" end t) (replace-match "\^A_" t t)) - (goto-char (point-max)) + (goto-char end) (insert "\037") (goto-char position) - (insert "#@" (format "%d" (- (position-bytes (point-max)) + (insert "#@" (format "%d" (- (position-bytes end) (position-bytes position)))) ;; Save the file position of the object. @@ -2927,7 +3007,8 @@ If QUOTED is non-nil, print with quoting; otherwise, print without quoting." ;; position to a file position. (prog1 (- (position-bytes (point)) (point-min) -1) - (goto-char (point-max)))))) + (goto-char end) + (set-marker end nil))))) (defun byte-compile--reify-function (fun) "Return an expression which will evaluate to a function value FUN. @@ -3030,6 +3111,14 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-warn-x arg "repeated variable %s in lambda-list" arg)) (t + (when (and lexical-binding + (cconv--not-lexical-var-p + arg byte-compile-bound-variables) + (byte-compile-warning-enabled-p 'lexical arg)) + (byte-compile-warn-x + arg + "Lexical argument shadows the dynamic variable %S" + arg)) (push arg vars)))) (setq list (cdr list))))) @@ -3393,92 +3482,257 @@ lambda-expression." ;; (defun byte-compile-form (form &optional for-effect) (let ((byte-compile--for-effect for-effect)) - (push form byte-compile-form-stack) - (cond - ((not (consp form)) - (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) - (byte-compile-constant form)) - ((and byte-compile--for-effect byte-compile-delete-errors) - (setq byte-compile--for-effect nil)) - (t (byte-compile-variable-ref form)))) - ((symbolp (car form)) - (let* ((fn (car form)) - (handler (get fn 'byte-compile)) - (interactive-only - (or (get fn 'interactive-only) - (memq fn byte-compile-interactive-only-functions)))) - (when (memq fn '(set symbol-value run-hooks ;; add-to-list - add-hook remove-hook run-hook-with-args - run-hook-with-args-until-success - run-hook-with-args-until-failure)) - (pcase (cdr form) - (`(',var . ,_) - (when (memq var byte-compile-lexical-variables) - (byte-compile-report-error - (format-message "%s cannot use lexical var `%s'" fn var)))))) - ;; Warn about using obsolete hooks. - (if (memq fn '(add-hook remove-hook)) - (let ((hook (car-safe (cdr form)))) - (if (eq (car-safe hook) 'quote) - (byte-compile-check-variable (cadr hook) nil)))) - (when (and (byte-compile-warning-enabled-p 'suspicious) - (macroexp--const-symbol-p fn)) - (byte-compile-warn-x fn "`%s' called as a function" fn)) - (when (and (byte-compile-warning-enabled-p 'interactive-only fn) - interactive-only) - (byte-compile-warn-x fn "`%s' is for interactive use only%s" - fn - (cond ((stringp interactive-only) - (format "; %s" - (substitute-command-keys - interactive-only))) - ((and (symbolp 'interactive-only) - (not (eq interactive-only t))) - (format-message "; use `%s' instead." - interactive-only)) - (t ".")))) - (if (eq (car-safe (symbol-function (car form))) 'macro) - (byte-compile-report-error - (format "`%s' defined after use in %S (missing `require' of a library file?)" - (car form) form))) - (if (and handler - ;; Make sure that function exists. - (and (functionp handler) - ;; Ignore obsolete byte-compile function used by former - ;; CL code to handle compiler macros (we do it - ;; differently now). - (not (eq handler 'cl-byte-compile-compiler-macro)))) - (funcall handler form) - (byte-compile-normal-call form)))) - ((and (byte-code-function-p (car form)) - (memq byte-optimize '(t lap))) - (byte-compile-unfold-bcf form)) - ((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 (macroexp--unfold-lambda form))))) - (byte-compile-form form byte-compile--for-effect) - (setq byte-compile--for-effect nil)) - ((byte-compile-normal-call form))) - (if byte-compile--for-effect - (byte-compile-discard)) - (pop byte-compile-form-stack))) + (macroexp--with-extended-form-stack form + (cond + ((not (consp form)) + (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) + (byte-compile-constant form)) + ((and byte-compile--for-effect byte-compile-delete-errors) + (setq byte-compile--for-effect nil)) + (t (byte-compile-variable-ref form)))) + ((symbolp (car form)) + (let* ((fn (car form)) + (handler (get fn 'byte-compile)) + (interactive-only + (or (function-get fn 'interactive-only) + (memq fn byte-compile-interactive-only-functions)))) + (when (memq fn '(set symbol-value run-hooks ;; add-to-list + add-hook remove-hook run-hook-with-args + run-hook-with-args-until-success + run-hook-with-args-until-failure)) + (pcase (cdr form) + (`(',var . ,_) + (when (and (memq var byte-compile-lexical-variables) + (byte-compile-warning-enabled-p 'lexical var)) + (byte-compile-warn + (format-message "%s cannot use lexical var `%s'" fn var)))))) + ;; Warn about using obsolete hooks. + (if (memq fn '(add-hook remove-hook)) + (let ((hook (car-safe (cdr form)))) + (if (eq (car-safe hook) 'quote) + (byte-compile-check-variable (cadr hook) nil)))) + (when (and (byte-compile-warning-enabled-p 'suspicious) + (macroexp--const-symbol-p fn)) + (byte-compile-warn-x fn "`%s' called as a function" fn)) + (when (and (byte-compile-warning-enabled-p 'interactive-only fn) + interactive-only) + (byte-compile-warn-x fn "`%s' is for interactive use only%s" + fn + (cond ((stringp interactive-only) + (format "; %s" + (substitute-command-keys + interactive-only))) + ((and (symbolp interactive-only) + (not (eq interactive-only t))) + (format-message "; use `%s' instead." + interactive-only)) + (t ".")))) + (let ((mutargs (function-get (car form) 'mutates-arguments))) + (when mutargs + (dolist (idx (if (eq mutargs 'all-but-last) + (number-sequence 1 (- (length form) 2)) + mutargs)) + (let ((arg (nth idx form))) + (when (and (or (and (eq (car-safe arg) 'quote) + (consp (nth 1 arg))) + (arrayp arg)) + (byte-compile-warning-enabled-p + 'mutate-constant (car form))) + (byte-compile-warn-x form "`%s' on constant %s (arg %d)" + (car form) + (if (consp arg) "list" (type-of arg)) + idx)))))) + + (let ((funargs (function-get (car form) 'funarg-positions))) + (dolist (funarg funargs) + (let ((arg (if (numberp funarg) + (nth funarg form) + (cadr (memq funarg form))))) + (when (and (eq 'quote (car-safe arg)) + (eq 'lambda (car-safe (cadr arg)))) + (byte-compile-warn-x + arg "(lambda %s ...) quoted with %s rather than with #%s" + (or (nth 1 (cadr arg)) "()") + "'" "'"))))) ; avoid styled quotes + + (if (eq (car-safe (symbol-function (car form))) 'macro) + (byte-compile-report-error + (format-message "`%s' defined after use in %S (missing `require' of a library file?)" + (car form) form))) + + (when byte-compile--for-effect + (let ((sef (function-get (car form) 'side-effect-free))) + (cond + ((and sef (or (eq sef 'error-free) + byte-compile-delete-errors)) + ;; This transform is normally done in the Lisp optimizer, + ;; so maybe we don't need to bother about it here? + (setq form (cons 'progn (cdr form))) + (setq handler #'byte-compile-progn)) + ((and (or sef (function-get (car form) 'important-return-value)) + ;; Don't warn for arguments to `ignore'. + (not (eq byte-compile--for-effect 'for-effect-no-warn)) + (byte-compile-warning-enabled-p + 'ignored-return-value (car form))) + (byte-compile-warn-x + (car form) + "value from call to `%s' is unused%s" + (car form) + (cond ((eq (car form) 'mapcar) + "; use `mapc' or `dolist' instead") + (t ""))))))) + + (if (and handler + ;; Make sure that function exists. + (and (functionp handler) + ;; Ignore obsolete byte-compile function used by former + ;; CL code to handle compiler macros (we do it + ;; differently now). + (not (eq handler 'cl-byte-compile-compiler-macro)))) + (funcall handler form) + (byte-compile-normal-call form)))) + ((and (byte-code-function-p (car form)) + (memq byte-optimize '(t lap))) + (byte-compile-unfold-bcf form)) + ((byte-compile-normal-call form))) + (if byte-compile--for-effect + (byte-compile-discard))))) + +(let ((important-return-value-fns + '( + ;; These functions are side-effect-free except for the + ;; behavior of functions passed as argument. + mapcar mapcan mapconcat + assoc plist-get plist-member + + ;; It's safe to ignore the value of `sort' and `nreverse' + ;; when used on arrays, but most calls pass lists. + nreverse sort + + match-data + + ;; Warning about these functions causes some false positives that are + ;; laborious to eliminate; see bug#61730. + ;;delq delete + ;;nconc plist-put + ))) + (dolist (fn important-return-value-fns) + (put fn 'important-return-value t))) + +(let ((mutating-fns + ;; FIXME: Should there be a function declaration for this? + ;; + ;; (FUNC . ARGS) means that FUNC mutates arguments whose indices are + ;; in the list ARGS, starting at 1, or all but the last argument if + ;; ARGS is `all-but-last'. + '( + (setcar 1) (setcdr 1) (aset 1) + (nreverse 1) + (nconc . all-but-last) + (nbutlast 1) (ntake 2) + (sort 1) + (delq 2) (delete 2) + (delete-dups 1) (delete-consecutive-dups 1) + (plist-put 1) + (assoc-delete-all 2) (assq-delete-all 2) (rassq-delete-all 2) + (fillarray 1) + (store-substring 1) + (clear-string 1) + + (add-text-properties 4) (put-text-property 5) (set-text-properties 4) + (remove-text-properties 4) (remove-list-of-text-properties 4) + (alter-text-property 5) + (add-face-text-property 5) (add-display-text-property 5) + + (cl-delete 2) (cl-delete-if 2) (cl-delete-if-not 2) + (cl-delete-duplicates 1) + (cl-nsubst 3) (cl-nsubst-if 3) (cl-nsubst-if-not 3) + (cl-nsubstitute 3) (cl-nsubstitute-if 3) (cl-nsubstitute-if-not 3) + (cl-nsublis 2) + (cl-nunion 1 2) (cl-nintersection 1 2) (cl-nset-difference 1 2) + (cl-nset-exclusive-or 1 2) + (cl-nreconc 1) + (cl-sort 1) (cl-stable-sort 1) (cl-merge 2 3) + ))) + (dolist (entry mutating-fns) + (put (car entry) 'mutates-arguments (cdr entry)))) + +;; Record which arguments expect functions, so we can warn when those +;; are accidentally quoted with ' rather than with #' +;; The value of the `funarg-positions' property is a list of function +;; argument positions, starting with 1, and keywords. +(dolist (f '( funcall apply mapcar mapatoms mapconcat mapc maphash + mapcan map-char-table map-keymap map-keymap-internal + functionp + seq-do seq-do-indexed seq-sort seq-sort-by seq-group-by + seq-find seq-count + seq-filter seq-reduce seq-remove seq-keep + seq-map seq-map-indexed seq-mapn seq-mapcat + seq-drop-while seq-take-while + seq-some seq-every-p + cl-every cl-some + cl-mapcar cl-mapcan cl-mapcon cl-mapc cl-mapl cl-maplist + )) + (put f 'funarg-positions '(1))) +(dolist (f '( defalias fset sort + replace-regexp-in-string + add-hook remove-hook advice-remove advice--remove-function + global-set-key local-set-key keymap-global-set keymap-local-set + set-process-filter set-process-sentinel + )) + (put f 'funarg-positions '(2))) +(dolist (f '( assoc assoc-default assoc-delete-all + plist-get plist-member + advice-add define-key keymap-set + run-at-time run-with-idle-timer run-with-timer + seq-contains seq-contains-p seq-set-equal-p + seq-position seq-positions seq-uniq + seq-union seq-intersection seq-difference)) + (put f 'funarg-positions '(3))) +(dolist (f '( cl-find cl-member cl-assoc cl-rassoc cl-position cl-count + cl-remove cl-delete + cl-subst cl-nsubst + cl-substitute cl-nsubstitute + cl-remove-duplicates cl-delete-duplicates + cl-union cl-nunion cl-intersection cl-nintersection + cl-set-difference cl-nset-difference + cl-set-exclusive-or cl-nset-exclusive-or + cl-nsublis + cl-search + )) + (put f 'funarg-positions '(:test :test-not :key))) +(dolist (f '( cl-find-if cl-find-if-not cl-member-if cl-member-if-not + cl-assoc-if cl-assoc-if-not cl-rassoc-if cl-rassoc-if-not + cl-position-if cl-position-if-not cl-count-if cl-count-if-not + cl-remove-if cl-remove-if-not cl-delete-if cl-delete-if-not + cl-reduce cl-adjoin + cl-subsetp + )) + (put f 'funarg-positions '(1 :key))) +(dolist (f '( cl-subst-if cl-subst-if-not cl-nsubst-if cl-nsubst-if-not + cl-substitute-if cl-substitute-if-not + cl-nsubstitute-if cl-nsubstitute-if-not + cl-sort cl-stable-sort + )) + (put f 'funarg-positions '(2 :key))) +(dolist (fa '((plist-put 4) (alist-get 5) (add-to-list 5) + (cl-merge 4 :key) + (custom-declare-variable :set :get :initialize :safe) + (make-process :filter :sentinel) + (make-network-process :filter :sentinel) + (all-completions 2 3) (try-completion 2 3) (test-completion 2 3) + (completing-read 2 3) + )) + (put (car fa) 'funarg-positions (cdr fa))) + (defun byte-compile-normal-call (form) (when (and (symbolp (car form)) (byte-compile-warning-enabled-p 'callargs (car form))) - (if (memq (car form) - '(custom-declare-group custom-declare-variable - custom-declare-face)) - (byte-compile-nogroup-warn form)) (byte-compile-callargs-warn form)) (if byte-compile-generate-call-tree (byte-compile-annotate-call-tree form)) - (when (and byte-compile--for-effect (eq (car form) 'mapcar) - (byte-compile-warning-enabled-p 'mapcar 'mapcar)) - (byte-compile-warn-x - (car form) - "`mapcar' called for effect; use `mapc' or `dolist' instead")) + (byte-compile-push-constant (car form)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. (byte-compile-out 'byte-call (length (cdr form)))) @@ -3736,7 +3990,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" '((0 . byte-compile-no-args) (1 . byte-compile-one-arg) (2 . byte-compile-two-args) - (2-and . byte-compile-and-folded) + (2-cmp . byte-compile-cmp) (3 . byte-compile-three-args) (0-1 . byte-compile-zero-or-one-arg) (1-2 . byte-compile-one-or-two-args) @@ -3815,11 +4069,12 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler cons 2) (byte-defop-compiler aref 2) (byte-defop-compiler set 2) -(byte-defop-compiler (= byte-eqlsign) 2-and) -(byte-defop-compiler (< byte-lss) 2-and) -(byte-defop-compiler (> byte-gtr) 2-and) -(byte-defop-compiler (<= byte-leq) 2-and) -(byte-defop-compiler (>= byte-geq) 2-and) +(byte-defop-compiler fset 2) +(byte-defop-compiler (= byte-eqlsign) 2-cmp) +(byte-defop-compiler (< byte-lss) 2-cmp) +(byte-defop-compiler (> byte-gtr) 2-cmp) +(byte-defop-compiler (<= byte-leq) 2-cmp) +(byte-defop-compiler (>= byte-geq) 2-cmp) (byte-defop-compiler get 2) (byte-defop-compiler nth 2) (byte-defop-compiler substring 1-3) @@ -3883,18 +4138,20 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-compile-form (nth 2 form)) (byte-compile-out (get (car form) 'byte-opcode) 0))) -(defun byte-compile-and-folded (form) - "Compile calls to functions like `<='. -These implicitly `and' together a bunch of two-arg bytecodes." - (let ((l (length form))) - (cond - ((< l 3) (byte-compile-form `(progn ,(nth 1 form) t))) - ((= l 3) (byte-compile-two-args form)) - ;; Don't use `cl-every' here (see comment where we require cl-lib). - ((not (memq nil (mapcar #'macroexp-copyable-p (nthcdr 2 form)))) - (byte-compile-form `(and (,(car form) ,(nth 1 form) ,(nth 2 form)) - (,(car form) ,@(nthcdr 2 form))))) - (t (byte-compile-normal-call form))))) +(defun byte-compile-cmp (form) + "Compile calls to numeric comparisons such as `<', `=' etc." + ;; Lisp-level transforms should already have reduced valid calls to 2 args. + (if (not (= (length form) 3)) + (byte-compile-subr-wrong-args form "1 or more") + (byte-compile-two-args + (if (macroexp-const-p (nth 1 form)) + ;; First argument is constant: flip it so that the constant + ;; is last, which may allow more lapcode optimizations. + (let* ((op (car form)) + (flipped-op (cdr (assq op '((< . >) (<= . >=) + (> . <) (>= . <=) (= . =)))))) + (list flipped-op (nth 2 form) (nth 1 form))) + form)))) (defun byte-compile-three-args (form) (if (not (= (length form) 4)) @@ -4049,9 +4306,15 @@ This function is never called when `lexical-binding' is nil." (byte-compile-constant 1) (byte-compile-out (get '* 'byte-opcode) 0)) (3 - (byte-compile-form (nth 1 form)) - (byte-compile-form (nth 2 form)) - (byte-compile-out (get (car form) 'byte-opcode) 0)) + (let ((arg1 (nth 1 form)) + (arg2 (nth 2 form))) + (when (and (memq (car form) '(+ *)) + (macroexp-const-p arg1)) + ;; Put constant argument last for better LAP optimization. + (cl-rotatef arg1 arg2)) + (byte-compile-form arg1) + (byte-compile-form arg2) + (byte-compile-out (get (car form) 'byte-opcode) 0))) (_ ;; >2 args: compile as a single function call. (byte-compile-normal-call form)))) @@ -4066,12 +4329,8 @@ This function is never called when `lexical-binding' is nil." ;; more complicated compiler macros -(byte-defop-compiler char-before) -(byte-defop-compiler backward-char) -(byte-defop-compiler backward-word) (byte-defop-compiler list) (byte-defop-compiler concat) -(byte-defop-compiler fset) (byte-defop-compiler (indent-to-column byte-indent-to) byte-compile-indent-to) (byte-defop-compiler indent-to) (byte-defop-compiler insert) @@ -4080,40 +4339,6 @@ This function is never called when `lexical-binding' is nil." (byte-defop-compiler (/ byte-quo) byte-compile-quo) (byte-defop-compiler nconc) -;; Is this worth it? Both -before and -after are written in C. -(defun byte-compile-char-before (form) - (cond ((or (= 1 (length form)) - (and (= 2 (length form)) (not (nth 1 form)))) - (byte-compile-form '(char-after (1- (point))))) - ((= 2 (length form)) - (byte-compile-form (list 'char-after (if (numberp (nth 1 form)) - (1- (nth 1 form)) - `(1- (or ,(nth 1 form) - (point))))))) - (t (byte-compile-subr-wrong-args form "0-1")))) - -;; backward-... ==> forward-... with negated argument. -;; Is this worth it? Both -backward and -forward are written in C. -(defun byte-compile-backward-char (form) - (cond ((or (= 1 (length form)) - (and (= 2 (length form)) (not (nth 1 form)))) - (byte-compile-form '(forward-char -1))) - ((= 2 (length form)) - (byte-compile-form (list 'forward-char (if (numberp (nth 1 form)) - (- (nth 1 form)) - `(- (or ,(nth 1 form) 1)))))) - (t (byte-compile-subr-wrong-args form "0-1")))) - -(defun byte-compile-backward-word (form) - (cond ((or (= 1 (length form)) - (and (= 2 (length form)) (not (nth 1 form)))) - (byte-compile-form '(forward-word -1))) - ((= 2 (length form)) - (byte-compile-form (list 'forward-word (if (numberp (nth 1 form)) - (- (nth 1 form)) - `(- (or ,(nth 1 form) 1)))))) - (t (byte-compile-subr-wrong-args form "0-1")))) - (defun byte-compile-list (form) (let ((count (length (cdr form)))) (cond ((= count 0) @@ -4168,26 +4393,6 @@ This function is never called when `lexical-binding' is nil." (byte-compile-form (car form)) (byte-compile-out 'byte-nconc 0)))))) -(defun byte-compile-fset (form) - ;; warn about forms like (fset 'foo '(lambda () ...)) - ;; (where the lambda expression is non-trivial...) - (let ((fn (nth 2 form)) - body) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (setq fn (nth 1 fn))) 'lambda)) - (progn - (setq body (cdr (cdr fn))) - (if (stringp (car body)) (setq body (cdr body))) - (if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) - (if (and (consp (car body)) - (not (eq 'byte-code (car (car body))))) - (byte-compile-warn-x - (nth 2 form) - "A quoted lambda form is the second argument of `fset'. This is probably - not what you want, as that lambda cannot be compiled. Consider using - the syntax #'(lambda (...) ...) instead."))))) - (byte-compile-two-args form)) - ;; (function foo) must compile like 'foo, not like (symbol-function 'foo). ;; Otherwise it will be incompatible with the interpreter, ;; and (funcall (function foo)) will lose with autoloads. @@ -4310,7 +4515,8 @@ This function is never called when `lexical-binding' is nil." (defun byte-compile-ignore (form) (dolist (arg (cdr form)) - (byte-compile-form arg t)) + ;; Compile each argument for-effect but suppress unused-value warnings. + (byte-compile-form arg 'for-effect-no-warn)) (byte-compile-form nil)) ;; Return the list of items in CONDITION-PARAM that match PRED-LIST. @@ -4571,6 +4777,7 @@ Return (TAIL VAR TEST CASES), where: (if switch-prefix (progn (byte-compile-cond-jump-table (cdr switch-prefix) donetag) + (setq clause nil) (setq clauses (car switch-prefix))) (setq clause (car clauses)) (cond ((or (eq (car clause) t) @@ -4835,6 +5042,15 @@ binding slots have been popped." (dolist (clause (reverse clauses)) (let ((condition (nth 1 clause))) + (when (and (eq (car-safe condition) 'quote) + (cdr condition) (null (cddr condition))) + (byte-compile-warn-x + condition "`condition-case' condition should not be quoted: %S" + condition)) + (when (and (consp condition) (memq :success condition)) + (byte-compile-warn-x + condition + "`:success' must be the first element of a `condition-case' handler")) (unless (consp condition) (setq condition (list condition))) (dolist (c condition) (unless (and c (symbolp c)) @@ -5055,7 +5271,10 @@ binding slots have been popped." (defun byte-compile-suppressed-warnings (form) (let ((byte-compile--suppressed-warnings (append (cadadr form) byte-compile--suppressed-warnings))) - (byte-compile-form (macroexp-progn (cddr form))))) + ;; Propagate the for-effect mode explicitly so that warnings about + ;; ignored return values can be detected and suppressed correctly. + (byte-compile-form (macroexp-progn (cddr form)) byte-compile--for-effect) + (setq byte-compile--for-effect nil))) ;; Warn about misuses of make-variable-buffer-local. (byte-defop-compiler-1 make-variable-buffer-local @@ -5080,6 +5299,194 @@ binding slots have been popped." (pcase form (`(,_ ',var) (byte-compile--declare-var var))) (byte-compile-normal-call form)) +;; Warn about mistakes in `defcustom', `defface', `defgroup', `define-widget' + +(defvar bytecomp--cus-function) +(defvar bytecomp--cus-name) + +(defun bytecomp--cus-warn (form format &rest args) + "Emit a warning about a `defcustom' type. +FORM is used to provide location, `bytecomp--cus-function' and +`bytecomp--cus-name' for context." + (let* ((actual-fun (or (cdr (assq bytecomp--cus-function + '((custom-declare-group . defgroup) + (custom-declare-face . defface) + (custom-declare-variable . defcustom)))) + bytecomp--cus-function)) + (prefix (format "in %s%s: " + actual-fun + (if bytecomp--cus-name + (format " for `%s'" bytecomp--cus-name) + "")))) + (apply #'byte-compile-warn-x form (concat prefix format) args))) + +(defun bytecomp--check-cus-type (type) + "Warn about common mistakes in the `defcustom' type TYPE." + (let ((invalid-types + '( + ;; Lisp type predicates, often confused with customization types: + functionp numberp integerp fixnump natnump floatp booleanp + characterp listp stringp consp vectorp symbolp keywordp + hash-table-p facep + ;; other mistakes occasionally seen (oh yes): + or and nil t + interger intger lits bool boolen constant filename + kbd any list-of auto + ;; from botched backquoting + \, \,@ \` + ))) + (cond + ((consp type) + (let* ((head (car type)) + (tail (cdr type))) + (while (and (keywordp (car tail)) (cdr tail)) + (setq tail (cddr tail))) + (cond + ((plist-member (cdr type) :convert-widget) nil) + ((let ((tl tail)) + (and (not (keywordp (car tail))) + (progn + (while (and tl (not (keywordp (car tl)))) + (setq tl (cdr tl))) + (and tl + (progn + (bytecomp--cus-warn + tl "misplaced %s keyword in `%s' type" (car tl) head) + t)))))) + ((memq head '(choice radio)) + (unless tail + (bytecomp--cus-warn type "`%s' without any types inside" head)) + (let ((clauses tail) + (constants nil) + (tags nil)) + (while clauses + (let* ((ty (car clauses)) + (ty-head (car-safe ty))) + (when (and (eq ty-head 'other) (cdr clauses)) + (bytecomp--cus-warn ty "`other' not last in `%s'" head)) + (when (memq ty-head '(const other)) + (let ((ty-tail (cdr ty)) + (val nil)) + (while (and (keywordp (car ty-tail)) (cdr ty-tail)) + (when (eq (car ty-tail) :value) + (setq val (cadr ty-tail))) + (setq ty-tail (cddr ty-tail))) + (when ty-tail + (setq val (car ty-tail))) + (when (member val constants) + (bytecomp--cus-warn + ty "duplicated value in `%s': `%S'" head val)) + (push val constants))) + (let ((tag (and (consp ty) (plist-get (cdr ty) :tag)))) + (when (stringp tag) + (when (member tag tags) + (bytecomp--cus-warn + ty "duplicated :tag string in `%s': %S" head tag)) + (push tag tags))) + (bytecomp--check-cus-type ty)) + (setq clauses (cdr clauses))))) + ((eq head 'cons) + (unless (= (length tail) 2) + (bytecomp--cus-warn + type "`cons' requires 2 type specs, found %d" (length tail))) + (dolist (ty tail) + (bytecomp--check-cus-type ty))) + ((memq head '(list group vector set repeat)) + (unless tail + (bytecomp--cus-warn type "`%s' without type specs" head)) + (dolist (ty tail) + (bytecomp--check-cus-type ty))) + ((memq head '(alist plist)) + (let ((key-tag (memq :key-type (cdr type))) + (value-tag (memq :value-type (cdr type)))) + (when key-tag + (bytecomp--check-cus-type (cadr key-tag))) + (when value-tag + (bytecomp--check-cus-type (cadr value-tag))))) + ((memq head '(const other)) + (let* ((value-tag (memq :value (cdr type))) + (n (length tail)) + (val (car tail))) + (cond + ((or (> n 1) (and value-tag tail)) + (bytecomp--cus-warn type "`%s' with too many values" head)) + (value-tag + (setq val (cadr value-tag))) + ;; ;; This is a useful check but it results in perhaps + ;; ;; a bit too many complaints. + ;; ((null tail) + ;; (bytecomp--cus-warn + ;; type "`%s' without value is implicitly nil" head)) + ) + (when (memq (car-safe val) '(quote function)) + (bytecomp--cus-warn type "`%s' with quoted value: %S" head val)))) + ((eq head 'quote) + (bytecomp--cus-warn type "type should not be quoted: %s" (cadr type))) + ((memq head invalid-types) + (bytecomp--cus-warn type "`%s' is not a valid type" head)) + ((or (not (symbolp head)) (keywordp head)) + (bytecomp--cus-warn type "irregular type `%S'" head)) + ))) + ((or (not (symbolp type)) (keywordp type)) + (bytecomp--cus-warn type "irregular type `%S'" type)) + ((memq type '( list cons group vector choice radio const other + function-item variable-item set repeat restricted-sexp)) + (bytecomp--cus-warn type "`%s' without arguments" type)) + ((memq type invalid-types) + (bytecomp--cus-warn type "`%s' is not a valid type" type)) + ))) + +;; Unified handler for multiple functions with similar arguments: +;; (NAME SOMETHING DOC KEYWORD-ARGS...) +(byte-defop-compiler-1 define-widget bytecomp--custom-declare) +(byte-defop-compiler-1 custom-declare-group bytecomp--custom-declare) +(byte-defop-compiler-1 custom-declare-face bytecomp--custom-declare) +(byte-defop-compiler-1 custom-declare-variable bytecomp--custom-declare) +(defun bytecomp--custom-declare (form) + (when (>= (length form) 4) + (let* ((name-arg (nth 1 form)) + (name (and (eq (car-safe name-arg) 'quote) + (symbolp (nth 1 name-arg)) + (nth 1 name-arg))) + (keyword-args (nthcdr 4 form)) + (fun (car form)) + (bytecomp--cus-function fun) + (bytecomp--cus-name name)) + + ;; Check :type + (when (memq fun '(custom-declare-variable define-widget)) + (let ((type-tag (memq :type keyword-args))) + (if (null type-tag) + ;; :type only mandatory for `defcustom' + (when (eq fun 'custom-declare-variable) + (bytecomp--cus-warn form "missing :type keyword parameter")) + (let ((dup-type (memq :type (cdr type-tag)))) + (when dup-type + (bytecomp--cus-warn + dup-type "duplicated :type keyword argument"))) + (let ((type-arg (cadr type-tag))) + (when (or (null type-arg) + (eq (car-safe type-arg) 'quote)) + (bytecomp--check-cus-type (cadr type-arg))))))) + + ;; Check :group + (when (cond + ((memq fun '(custom-declare-variable custom-declare-face)) + (not byte-compile-current-group)) + ((eq fun 'custom-declare-group) + (not (eq name 'emacs)))) + (unless (plist-get keyword-args :group) + (bytecomp--cus-warn form "fails to specify containing group"))) + + ;; Update current group + (when (and name + byte-compile-current-file ; only when compiling a whole file + (eq fun 'custom-declare-group)) + (setq byte-compile-current-group name)))) + + (byte-compile-normal-call form)) + + (put 'function-put 'byte-hunk-handler 'byte-compile-define-symbol-prop) (put 'define-symbol-prop 'byte-hunk-handler 'byte-compile-define-symbol-prop) (defun byte-compile-define-symbol-prop (form) @@ -5487,6 +5894,173 @@ and corresponding effects." (eval form) form))) +;; Check for (in)comparable constant values in calls to `eq', `memq' etc. + +(defun bytecomp--dodgy-eq-arg-p (x number-ok) + "Whether X is a bad argument to `eq' (or `eql' if NUMBER-OK is non-nil)." + (pcase x + ((or `(quote ,(pred consp)) `(function (lambda . ,_))) t) + ((or (pred consp) (pred symbolp)) nil) + ((pred integerp) + (not (or (<= -536870912 x 536870911) number-ok))) + ((pred floatp) (not number-ok)) + (_ t))) + +(defun bytecomp--value-type-description (x) + (cond + ((proper-list-p x) "list") + ((recordp x) "record") + (t (symbol-name (type-of x))))) + +(defun bytecomp--arg-type-description (x) + (pcase x + (`(function (lambda . ,_)) "function") + (`(quote . ,val) (bytecomp--value-type-description val)) + (_ (bytecomp--value-type-description x)))) + +(defun bytecomp--warn-dodgy-eq-arg (form type parenthesis) + (macroexp-warn-and-return + (format-message "`%s' called with literal %s that may never match (%s)" + (car form) type parenthesis) + form (list 'suspicious (car form)) t)) + +(defun bytecomp--check-eq-args (form &optional a b &rest _ignore) + (let* ((number-ok (eq (car form) 'eql)) + (bad-arg (cond ((bytecomp--dodgy-eq-arg-p a number-ok) 1) + ((bytecomp--dodgy-eq-arg-p b number-ok) 2)))) + (if bad-arg + (bytecomp--warn-dodgy-eq-arg + form + (bytecomp--arg-type-description (nth bad-arg form)) + (format "arg %d" bad-arg)) + form))) + +(put 'eq 'compiler-macro #'bytecomp--check-eq-args) +(put 'eql 'compiler-macro #'bytecomp--check-eq-args) + +(defun bytecomp--check-memq-args (form &optional elem list &rest _ignore) + (let* ((fn (car form)) + (number-ok (eq fn 'memql))) + (cond + ((bytecomp--dodgy-eq-arg-p elem number-ok) + (bytecomp--warn-dodgy-eq-arg + form (bytecomp--arg-type-description elem) "arg 1")) + ((and (consp list) (eq (car list) 'quote) + (proper-list-p (cadr list))) + (named-let loop ((elts (cadr list)) (i 1)) + (if elts + (let* ((elt (car elts)) + (x (cond ((eq fn 'assq) (car-safe elt)) + ((eq fn 'rassq) (cdr-safe elt)) + (t elt)))) + (if (or (symbolp x) + (and (integerp x) + (or (<= -536870912 x 536870911) number-ok)) + (and (floatp x) number-ok)) + (loop (cdr elts) (1+ i)) + (bytecomp--warn-dodgy-eq-arg + form (bytecomp--value-type-description x) + (format "element %d of arg 2" i)))) + form))) + (t form)))) + +(put 'memq 'compiler-macro #'bytecomp--check-memq-args) +(put 'memql 'compiler-macro #'bytecomp--check-memq-args) +(put 'assq 'compiler-macro #'bytecomp--check-memq-args) +(put 'rassq 'compiler-macro #'bytecomp--check-memq-args) +(put 'remq 'compiler-macro #'bytecomp--check-memq-args) +(put 'delq 'compiler-macro #'bytecomp--check-memq-args) + +;; Implement `char-before', `backward-char' and `backward-word' in +;; terms of `char-after', `forward-char' and `forward-word' which have +;; their own byte-ops. + +(put 'char-before 'compiler-macro #'bytecomp--char-before) +(defun bytecomp--char-before (form &optional arg &rest junk-args) + (if junk-args + form ; arity error + `(char-after (1- (or ,arg (point)))))) + +(put 'backward-char 'compiler-macro #'bytecomp--backward-char) +(defun bytecomp--backward-char (form &optional arg &rest junk-args) + (if junk-args + form ; arity error + `(forward-char (- (or ,arg 1))))) + +(put 'backward-word 'compiler-macro #'bytecomp--backward-word) +(defun bytecomp--backward-word (form &optional arg &rest junk-args) + (if junk-args + form ; arity error + `(forward-word (- (or ,arg 1))))) + +(defun bytecomp--check-keyword-args (form arglist allowed-keys required-keys) + (let ((fun (car form))) + (cl-flet ((missing (form keyword) + (byte-compile-warn-x + form + "`%S´ called without required keyword argument %S" + fun keyword)) + (unrecognized (form keyword) + (byte-compile-warn-x + form + "`%S´ called with unknown keyword argument %S" + fun keyword)) + (duplicate (form keyword) + (byte-compile-warn-x + form + "`%S´ called with repeated keyword argument %S" + fun keyword)) + (missing-val (form keyword) + (byte-compile-warn-x + form + "missing value for keyword argument %S" + keyword))) + (let* ((seen '()) + (l arglist)) + (while (consp l) + (let ((key (car l))) + (cond ((and (keywordp key) (memq key allowed-keys)) + (cond ((memq key seen) + (duplicate l key)) + (t + (push key seen)))) + (t (unrecognized l key))) + (when (null (cdr l)) + (missing-val l key))) + (setq l (cddr l))) + (dolist (key required-keys) + (unless (memq key seen) + (missing form key)))))) + form) + +(put 'make-process 'compiler-macro + #'(lambda (form &rest args) + (bytecomp--check-keyword-args + form args + '(:name + :buffer :command :coding :noquery :stop :connection-type + :filter :sentinel :stderr :file-handler) + '(:name :command)))) + +(put 'make-pipe-process 'compiler-macro + #'(lambda (form &rest args) + (bytecomp--check-keyword-args + form args + '(:name :buffer :coding :noquery :stop :filter :sentinel) + '(:name)))) + +(put 'make-network-process 'compiler-macro + #'(lambda (form &rest args) + (bytecomp--check-keyword-args + form args + '(:name + :buffer :host :service :type :family :local :remote :coding + :nowait :noquery :stop :filter :filter-multibyte :sentinel + :log :plist :tls-parameters :server :broadcast :dontroute + :keepalive :linger :oobinline :priority :reuseaddr :bindtodevice + :use-external-socket) + '(:name :service)))) + (provide 'byte-compile) (provide 'bytecomp) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 5f37db3fe9b..42bddbb8352 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -236,9 +236,9 @@ Returns a form where all lambdas don't have any free variables." (not (intern-soft var)) (eq ?_ (aref (symbol-name var) 0))) (let ((suggestions (help-uni-confusable-suggestions (symbol-name var)))) - (format "Unused lexical %s `%S'%s" - varkind (bare-symbol var) - (if suggestions (concat "\n " suggestions) ""))))) + (format-message "Unused lexical %s `%S'%s" + varkind (bare-symbol var) + (if suggestions (concat "\n " suggestions) ""))))) (define-inline cconv--var-classification (binder form) (inline-quote @@ -328,279 +328,309 @@ places where they originally did not directly appear." ;; to find the number of a specific variable in the environment vector, ;; so we never touch it(unless we enter to the other closure). ;;(if (listp form) (print (car form)) form) - (pcase form - (`(,(and letsym (or 'let* 'let)) ,binders . ,body) + (macroexp--with-extended-form-stack form + (pcase form + (`(,(and letsym (or 'let* 'let)) ,binders . ,body) ; let and let* special forms - (let ((binders-new '()) - (new-env env) - (new-extend extend)) - - (dolist (binder binders) - (let* ((value nil) - (var (if (not (consp binder)) - (prog1 binder (setq binder (list binder))) - (when (cddr binder) - (byte-compile-warn-x - binder - "Malformed `%S' binding: %S" - letsym binder)) - (setq value (cadr binder)) - (car binder)))) - (cond - ;; Ignore bindings without a valid name. - ((not (symbolp var)) - (byte-compile-warn-x var "attempt to let-bind nonvariable `%S'" var)) - ((or (booleanp var) (keywordp var)) - (byte-compile-warn-x var "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))) + (let ((binders-new '()) + (new-env env) + (new-extend extend)) + + (dolist (binder binders) + (let* ((value nil) + (var (if (not (consp binder)) + (prog1 binder (setq binder (list binder))) + (when (cddr binder) + (byte-compile-warn-x + binder + "Malformed `%S' binding: %S" + letsym binder)) + (setq value (cadr binder)) + (car binder)))) + (cond + ;; Ignore bindings without a valid name. + ((not (symbolp var)) + (byte-compile-warn-x + var "attempt to let-bind nonvariable `%S'" var)) + ((or (booleanp var) (keywordp var)) + (byte-compile-warn-x + var "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". - (: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* ((Ignore (if (symbol-with-pos-p var) - (position-symbol 'ignore var) - 'ignore)) - (newval `(,Ignore - ,(cconv-convert value env extend))) - (msg (cconv--warn-unused-msg var "variable"))) - (if (null msg) newval - (macroexp--warn-wrap var 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 ((var-def (cconv--lifted-arg var env)) - (closedsym (make-symbol (format "closed-%s" var)))) - (setq new-env (cconv--remap-llv new-env var closedsym)) - ;; FIXME: `closedsym' doesn't need to be added to `extend' - ;; but adding it makes it easier to write the assertion at - ;; the beginning of this function. - (setq new-extend (cons closedsym (remq var new-extend))) - (push `(,closedsym ,var-def) 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 - ;; let* because in the case of `let', the shadowing may occur - ;; before we know that the var will be in `new-extend' (bug#24171). - (dolist (binder binders-new) - (when (memq (car-safe binder) new-extend) - ;; One of the lambda-lifted vars is shadowed. - (let* ((var (car-safe binder)) - (var-def (cconv--lifted-arg var env)) - (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-def) binders-new))))) - - `(,letsym ,(nreverse binders-new) - . ,(mapcar (lambda (form) - (cconv-convert - form new-env new-extend)) - body)))) + (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* ((Ignore (if (symbol-with-pos-p var) + (position-symbol 'ignore var) + 'ignore)) + (newval `(,Ignore + ,(cconv-convert value env extend))) + (msg (cconv--warn-unused-msg var "variable"))) + (if (null msg) newval + (macroexp--warn-wrap var 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 ((var-def (cconv--lifted-arg var env)) + (closedsym (make-symbol (format "closed-%s" var)))) + (setq new-env (cconv--remap-llv new-env var closedsym)) + ;; FIXME: `closedsym' doesn't need to be added to `extend' + ;; but adding it makes it easier to write the assertion at + ;; the beginning of this function. + (setq new-extend (cons closedsym (remq var new-extend))) + (push `(,closedsym ,var-def) 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 + ;; let* because in the case of `let', the shadowing may occur + ;; before we know that the var will be in `new-extend' (bug#24171). + (dolist (binder binders-new) + (when (memq (car-safe binder) new-extend) + ;; One of the lambda-lifted vars is shadowed. + (let* ((var (car-safe binder)) + (var-def (cconv--lifted-arg var env)) + (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-def) binders-new))))) + + `(,letsym ,(nreverse binders-new) + . ,(mapcar (lambda (form) + (cconv-convert + form new-env new-extend)) + body)))) ;end of let let* forms - ; first element is lambda expression - (`(,(and `(lambda . ,_) fun) . ,args) - ;; FIXME: it's silly to create a closure just to call it. - ;; Running byte-optimize-form earlier will resolve this. - `(funcall - ,(cconv-convert `(function ,fun) env extend) - ,@(mapcar (lambda (form) - (cconv-convert form env extend)) - args))) - - (`(cond . ,cond-forms) ; cond special form - `(,(car form) . ,(mapcar (lambda (branch) - (mapcar (lambda (form) - (cconv-convert form env extend)) - branch)) - cond-forms))) - - (`(function (lambda ,args . ,body) . ,_) - (let* ((docstring (if (eq :documentation (car-safe (car body))) - (cconv-convert (cadr (pop body)) env extend))) - (bf (if (stringp (car body)) (cdr body) body)) - (if (when (eq 'interactive (car-safe (car bf))) - (gethash form cconv--interactive-form-funs))) - (cif (when if (cconv-convert if env extend))) - (_ (pcase cif - (`#'(lambda () ,form) (setf (cadr (car bf)) form) (setq cif nil)) - ('nil nil) - ;; The interactive form needs special treatment, so the form - ;; inside the `interactive' won't be used any further. - (_ (setf (cadr (car bf)) nil)))) - (cf (cconv--convert-function args body env form docstring))) - (if (not cif) - ;; Normal case, the interactive form needs no special treatment. - cf - `(cconv--interactive-helper ,cf ,cif)))) - - (`(internal-make-closure . ,_) - (byte-compile-report-error - "Internal error in compiler: cconv called twice?")) - - (`(quote . ,_) form) - (`(function . ,_) form) + ; first element is lambda expression + (`(,(and `(lambda . ,_) fun) . ,args) + ;; FIXME: it's silly to create a closure just to call it. + ;; Running byte-optimize-form earlier would resolve this. + `(funcall + ,(cconv-convert `(function ,fun) env extend) + ,@(mapcar (lambda (form) + (cconv-convert form env extend)) + args))) + + (`(cond . ,cond-forms) ; cond special form + `(,(car form) . ,(mapcar (lambda (branch) + (mapcar (lambda (form) + (cconv-convert form env extend)) + branch)) + cond-forms))) + + (`(function (lambda ,args . ,body) . ,rest) + (let* ((docstring (if (eq :documentation (car-safe (car body))) + (cconv-convert (cadr (pop body)) env extend))) + (bf (if (stringp (car body)) (cdr body) body)) + (if (when (eq 'interactive (car-safe (car bf))) + (gethash form cconv--interactive-form-funs))) + (wrapped (pcase if (`#'(lambda (&rest _cconv--dummy) .,_) t))) + (cif (when if (cconv-convert if env extend))) + (cf nil)) + ;; TODO: Because we need to non-destructively modify body, this code + ;; is particularly ugly. This should ideally be moved to + ;; cconv--convert-function. + (pcase cif + ('nil (setq bf nil)) + (`#',f + (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf)) + (setq bf `((,f1 . (,(if wrapped (nth 2 f) cif) . ,f2)) . ,f3))) + (setq cif nil)) + ;; The interactive form needs special treatment, so the form + ;; inside the `interactive' won't be used any further. + (_ (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf)) + (setq bf `((,f1 . (nil . ,f2)) . ,f3))))) + (when bf + ;; If we modified bf, re-build body and form as + ;; copies with the modified bits. + (setq body (if (stringp (car body)) + (cons (car body) bf) + bf) + form `(function (lambda ,args . ,body) . ,rest)) + ;; Also, remove the current old entry on the alist, replacing + ;; it with the new one. + (let ((entry (pop cconv-freevars-alist))) + (push (cons body (cdr entry)) cconv-freevars-alist))) + (setq cf (cconv--convert-function args body env form docstring)) + (if (not cif) + ;; Normal case, the interactive form needs no special treatment. + cf + `(cconv--interactive-helper + ,cf ,(if wrapped cif `(list 'quote ,cif)))))) + + (`(internal-make-closure . ,_) + (byte-compile-report-error + "Internal error in compiler: cconv called twice?")) + + (`(quote . ,_) form) + (`(function . ,_) form) ;defconst, defvar - (`(,(and sym (or 'defconst 'defvar)) ,definedsymbol . ,forms) - `(,sym ,definedsymbol - . ,(when (consp forms) - (cons (cconv-convert (car forms) env extend) - ;; The rest (i.e. docstring, of any) is not evaluated, - ;; and may be an invalid expression (e.g. ($# . 678)). - (cdr forms))))) + (`(,(and sym (or 'defconst 'defvar)) ,definedsymbol . ,forms) + `(,sym ,definedsymbol + . ,(when (consp forms) + (cons (cconv-convert (car forms) env extend) + ;; The rest (i.e. docstring, of any) is not evaluated, + ;; and may be an invalid expression (e.g. ($# . 678)). + (cdr forms))))) ; condition-case - (`(condition-case ,var ,protected-form . ,handlers) - (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))) - `(,(car form) ,var - ,(if msg - (macroexp--warn-wrap var msg newprotform 'lexical) - newprotform) - ,@(mapcar - (lambda (handler) - `(,(car handler) - ,@(let ((body - (mapcar (lambda (form) - (cconv-convert form newenv extend)) - (cdr handler)))) - (if (not (eq class :captured+mutated)) - body - `((let ((,var (list ,var))) ,@body)))))) - handlers)))) - - (`(unwind-protect ,form1 . ,body) - `(,(car form) ,(cconv-convert form1 env extend) - :fun-body ,(cconv--convert-function () body env form1))) - - (`(setq ,var ,expr) - (let ((var-new (or (cdr (assq var env)) var)) - (value (cconv-convert expr env extend))) - (pcase var-new - ((pred symbolp) `(,(car form) ,var-new ,value)) - (`(car-safe ,iexp) `(setcar ,iexp ,value)) - ;; This "should never happen", but for variables which are - ;; mutated+captured+unused, we may end up trying to `setq' - ;; on a closed-over variable, so just drop the setq. - (_ ;; (byte-compile-report-error - ;; (format "Internal error in cconv of (setq %s ..)" - ;; sym-new)) - value)))) - - (`(,(and (or 'funcall 'apply) callsym) ,fun . ,args) - ;; These are not special forms but we treat them separately for the needs - ;; of lambda lifting. - (let ((mapping (cdr (assq fun env)))) - (pcase mapping - (`(apply-partially ,_ . ,(and fvs `(,_ . ,_))) - (cl-assert (eq (cadr mapping) fun)) - `(,callsym ,fun - ,@(mapcar (lambda (fv) - (let ((exp (or (cdr (assq fv env)) fv))) - (pcase exp - (`(car-safe ,iexp . ,_) iexp) - (_ exp)))) - fvs) - ,@(mapcar (lambda (arg) - (cconv-convert arg env extend)) - args))) - (_ `(,callsym ,@(mapcar (lambda (arg) + (`(condition-case ,var ,protected-form . ,handlers) + (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))) + `(,(car form) ,var + ,(if msg + (macroexp--warn-wrap var msg newprotform 'lexical) + newprotform) + ,@(mapcar + (lambda (handler) + `(,(car handler) + ,@(let ((body + (mapcar (lambda (form) + (cconv-convert form newenv extend)) + (cdr handler)))) + (if (not (eq class :captured+mutated)) + body + `((let ((,var (list ,var))) ,@body)))))) + handlers)))) + + (`(unwind-protect ,form1 . ,body) + `(,(car form) ,(cconv-convert form1 env extend) + :fun-body ,(cconv--convert-function () body env form1))) + + (`(setq ,var ,expr) + (let ((var-new (or (cdr (assq var env)) var)) + (value (cconv-convert expr env extend))) + (pcase var-new + ((pred symbolp) `(,(car form) ,var-new ,value)) + (`(car-safe ,iexp) `(setcar ,iexp ,value)) + ;; This "should never happen", but for variables which are + ;; mutated+captured+unused, we may end up trying to `setq' + ;; on a closed-over variable, so just drop the setq. + (_ ;; (byte-compile-report-error + ;; (format "Internal error in cconv of (setq %s ..)" + ;; sym-new)) + value)))) + + (`(,(and (or 'funcall 'apply) callsym) ,fun . ,args) + ;; These are not special forms but we treat them separately for the needs + ;; of lambda lifting. + (let ((mapping (cdr (assq fun env)))) + (pcase mapping + (`(apply-partially ,_ . ,(and fvs `(,_ . ,_))) + (cl-assert (eq (cadr mapping) fun)) + `(,callsym ,fun + ,@(mapcar (lambda (fv) + (let ((exp (or (cdr (assq fv env)) fv))) + (pcase exp + (`(car-safe ,iexp . ,_) iexp) + (_ exp)))) + fvs) + ,@(mapcar (lambda (arg) (cconv-convert arg env extend)) - (cons fun args))))))) - - ;; The form (if any) is converted beforehand as part of the `lambda' case. - (`(interactive . ,_) form) - - ;; `declare' should now be macro-expanded away (and if they're not, we're - ;; in trouble because they *can* contain code nowadays). - ;; (`(declare . ,_) form) ;The args don't contain code. - - (`(oclosure--fix-type (ignore . ,vars) ,exp) - (dolist (var vars) - (let ((x (assq var env))) - (pcase (cdr x) - (`(car-safe . ,_) (error "Slot %S should not be mutated" var)) - (_ (cl-assert (null (cdr x))))))) - (cconv-convert exp env extend)) - - (`(,func . ,forms) - ;; First element is function or whatever function-like forms are: or, and, - ;; if, catch, progn, prog1, while, until - `(,func . ,(mapcar (lambda (form) - (cconv-convert form env extend)) - forms))) - - (_ (or (cdr (assq form env)) form)))) + args))) + (_ `(,callsym ,@(mapcar (lambda (arg) + (cconv-convert arg env extend)) + (cons fun args))))))) + + ;; The form (if any) is converted beforehand as part of the `lambda' case. + (`(interactive . ,_) form) + + ;; `declare' should now be macro-expanded away (and if they're not, we're + ;; in trouble because they *can* contain code nowadays). + ;; (`(declare . ,_) form) ;The args don't contain code. + + (`(oclosure--fix-type (ignore . ,vars) ,exp) + (dolist (var vars) + (let ((x (assq var env))) + (pcase (cdr x) + (`(car-safe . ,_) (error "Slot %S should not be mutated" var)) + (_ (cl-assert (null (cdr x))))))) + (cconv-convert exp env extend)) + + (`(,func . ,forms) + (if (symbolp func) + ;; First element is function or whatever function-like forms are: + ;; or, and, if, catch, progn, prog1, while, until + `(,func . ,(mapcar (lambda (form) + (cconv-convert form env extend)) + forms)) + (byte-compile-warn-x form "Malformed function `%S'" func) + nil)) + + (_ (or (cdr (assq form env)) form))))) (defvar byte-compile-lexical-variables) @@ -661,11 +691,6 @@ FORM is the parent form that binds this var." (when lexical-binding (dolist (arg args) (cond - ((cconv--not-lexical-var-p arg cconv--dynbound-variables) - (byte-compile-warn-x - arg - "Lexical argument shadows the dynamic variable %S" - arg)) ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... (t (let ((varstruct (list arg nil nil nil nil))) (cl-pushnew arg byte-compile-lexical-variables) @@ -742,7 +767,8 @@ This function does not return anything but instead fills the (when (eq 'interactive (car-safe (car bf))) (let ((if (cadr (car bf)))) (unless (macroexp-const-p if) ;Optimize this common case. - (let ((f `#'(lambda () ,if))) + (let ((f (if (eq 'function (car-safe if)) if + `#'(lambda (&rest _cconv--dummy) ,if)))) (setf (gethash form cconv--interactive-form-funs) f) (cconv-analyze-form f env)))))) (cconv--analyze-function vrs body-forms env form)) @@ -829,10 +855,13 @@ This function does not return anything but instead fills the (define-obsolete-function-alias 'cconv-analyse-form #'cconv-analyze-form "25.1") (defun cconv-fv (form lexvars dynvars) - "Return the list of free variables in FORM. -LEXVARS is the list of statically scoped vars in the context -and DYNVARS is the list of dynamically scoped vars in the context. -Returns a pair (LEXV . DYNV) of those vars actually used by FORM." + "Return the free variables used in FORM. +FORM is usually a function #\\='(lambda ...), but may be any valid +form. LEXVARS is a list of symbols, each of which is lexically +bound in FORM's context. DYNVARS is a list of symbols, each of +which is dynamically bound in FORM's context. +Returns a cons (LEXV . DYNV), the car and cdr being lists of the +lexically and dynamically bound symbols actually used by FORM." (let* ((fun ;; Wrap FORM into a function because the analysis code we ;; have only computes freevars for functions. @@ -870,11 +899,26 @@ Returns a pair (LEXV . DYNV) of those vars actually used by FORM." (cons fvs dyns))))) (defun cconv-make-interpreted-closure (fun env) + "Make a closure for the interpreter. +This is intended to be called at runtime by the ELisp interpreter (when +the code has not been compiled). +FUN is the closure's source code, must be a lambda form. +ENV is the runtime representation of the lexical environment, +i.e. a list whose elements can be either plain symbols (which indicate +that this symbol should use dynamic scoping) or pairs (SYMBOL . VALUE) +for the lexical bindings." (cl-assert (eq (car-safe fun) 'lambda)) (let ((lexvars (delq nil (mapcar #'car-safe env)))) - (if (null lexvars) - ;; The lexical environment is empty, so there's no need to - ;; look for free variables. + (if (or (null lexvars) + ;; Functions with a `:closure-dont-trim-context' marker + ;; should keep their whole context untrimmed (bug#59213). + (and (eq :closure-dont-trim-context (nth 2 fun)) + ;; Check the function doesn't just return the magic keyword. + (nthcdr 3 fun))) + ;; The lexical environment is empty, or needs to be preserved, + ;; so there's no need to look for free variables. + ;; Attempting to replace ,(cdr fun) by a macroexpanded version + ;; causes bootstrap to fail. `(closure ,env . ,(cdr fun)) ;; We could try and cache the result of the macroexpansion and ;; `cconv-fv' analysis. Not sure it's worth the trouble. diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index c5e69d5ef56..dd7cfd82b1d 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1611,8 +1611,11 @@ may require more formatting") (let ((f nil) (m nil) (start (point)) ;; Ignore the "A-" modifier: it is uncommon in practice, ;; and leads to false positives in regexp ranges. - (re "[^`‘A-Za-z0-9_]\\([CMs]-[a-zA-Z]\\|\\(\\([CMs]-\\)?\ -mouse-[0-3]\\)\\)\\>")) + (re (rx (not (any "0-9A-Za-z_`‘-")) + (group (or (seq (any "CMs") "-" (any "A-Za-z")) + (group (opt (group (any "CMs") "-")) + "mouse-" (any "0-3")))) + eow))) ;; Find the first key sequence not in a sample (while (and (not f) (setq m (re-search-forward re e t))) (setq f (not (checkdoc-in-sample-code-p start e)))) @@ -1779,7 +1782,7 @@ function,command,variable,option or symbol." ms1)))))) (order (and (nth 3 fp) (car (nth 3 fp)))) (nocheck (append '("&optional" "&rest" "&key" "&aux" "&context" "&environment" "&whole" - "&body" "&allow-other-keys") + "&body" "&allow-other-keys" "nil") (nth 3 fp))) (inopts nil)) (while (and args found (> found last-pos)) @@ -2042,8 +2045,7 @@ from the comment." (condition-case nil (setq lst (read (current-buffer))) (error (setq lst nil))) ; error in text - (if (not (listp lst)) ; not a list of args - (setq lst (list lst))) + (setq lst (ensure-list lst)) (if (and lst (not (symbolp (car lst)))) ;weird arg (setq lst nil)) (while lst @@ -2382,7 +2384,7 @@ Code:, and others referenced in the style guide." err (or ;; * Commentary Section - (if (and (not (lm-commentary-mark)) + (if (and (not (lm-commentary-start)) ;; No need for a commentary section in test files. (not (string-match (rx (or (seq (or "-test.el" "-tests.el") string-end) @@ -2419,10 +2421,10 @@ Code:, and others referenced in the style guide." (if (or (not checkdoc-force-history-flag) (file-exists-p "ChangeLog") (file-exists-p "../ChangeLog") - (lm-history-mark)) + (lm-history-start)) nil (progn - (goto-char (or (lm-commentary-mark) (point-min))) + (goto-char (or (lm-commentary-start) (point-min))) (cond ((re-search-forward "write\\s-+to\\s-+the\\s-+Free Software Foundation, Inc." @@ -2443,7 +2445,7 @@ Code:, and others referenced in the style guide." err (or ;; * Code section - (if (not (lm-code-mark)) + (if (not (lm-code-start)) (let ((cont t) pos) (goto-char (point-min)) @@ -2494,7 +2496,7 @@ Code:, and others referenced in the style guide." ;; Let's spellcheck the commentary section. This is the only ;; section that is easy to pick out, and it is also the most ;; visible section (with the finder). - (let ((cm (lm-commentary-mark))) + (let ((cm (lm-commentary-start))) (when cm (save-excursion (goto-char cm) @@ -2546,11 +2548,11 @@ Argument END is the maximum bounds to search in." (rx "(" (* (syntax whitespace)) (group - (or (seq (* (group (or wordchar (syntax symbol)))) + (or (seq (* (or wordchar (syntax symbol))) "error") - (seq (* (group (or wordchar (syntax symbol)))) + (seq (* (or wordchar (syntax symbol))) (or "y-or-n-p" "yes-or-no-p") - (? (group "-with-timeout"))) + (? "-with-timeout")) "checkdoc-autofix-ask-replace")) (+ (any "\n\t "))) end t)) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 8ba320cdfb6..454076eb3f0 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -408,6 +408,7 @@ Other non-digit chars are considered junk. RADIX is an integer between 2 and 36, the default is 10. Signal an error if the substring between START and END cannot be parsed as an integer unless JUNK-ALLOWED is non-nil." + (declare (side-effect-free t)) (cl-check-type string string) (let* ((start (or start 0)) (len (length string)) @@ -569,6 +570,7 @@ too large if positive or too small if negative)." ;;;###autoload (defun cl-revappend (x y) "Equivalent to (append (reverse X) Y)." + (declare (side-effect-free t)) (nconc (reverse x) y)) ;;;###autoload @@ -636,13 +638,12 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) ;;;###autoload -(defun cl-remprop (sym tag) - "Remove from SYMBOL's plist the property PROPNAME and its value. -\n(fn SYMBOL PROPNAME)" - (let ((plist (symbol-plist sym))) - (if (and plist (eq tag (car plist))) - (progn (setplist sym (cdr (cdr plist))) t) - (cl--do-remf plist tag)))) +(defun cl-remprop (symbol propname) + "Remove from SYMBOL's plist the property PROPNAME and its value." + (let ((plist (symbol-plist symbol))) + (if (and plist (eq propname (car plist))) + (progn (setplist symbol (cdr (cdr plist))) t) + (cl--do-remf plist propname)))) ;;; Streams. @@ -877,7 +878,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" "%s") formats) (cl-incf col (+ col-space (aref cols i)))) - (let ((format (mapconcat #'identity (nreverse formats) ""))) + (let ((format (mapconcat #'identity (nreverse formats)))) (insert (apply #'format format (mapcar (lambda (str) (propertize str 'face 'italic)) header)) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index b062c280a41..0ef0d1e192a 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -272,7 +272,7 @@ DEFAULT-BODY, if present, is used as the body of a default method. (list (macroexp-warn-and-return (format "Non-symbol arguments to cl-defgeneric: %s" - (mapconcat #'prin1-to-string nonsymargs "")) + (mapconcat #'prin1-to-string nonsymargs " ")) nil nil nil nonsymargs))))) next-head) (while (progn (setq next-head (car-safe (car options-and-methods))) @@ -1101,10 +1101,10 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (qualifiers (cl--generic-method-qualifiers method)) (call-con (cl--generic-method-call-con method)) (function (cl--generic-method-function method)) - (args (help-function-arglist (if (not (eq call-con 'curried)) - function - (funcall function #'ignore)) - 'names)) + (function (if (not (eq call-con 'curried)) + function + (funcall function #'ignore))) + (args (help-function-arglist function 'names)) (docstring (documentation function)) (qual-string (if (null qualifiers) "" @@ -1379,6 +1379,7 @@ See the full list and their hierarchy in `cl--typeof-types'." (cl--generic-prefill-dispatchers 0 integer) (cl--generic-prefill-dispatchers 1 integer) (cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer) +(cl--generic-prefill-dispatchers 0 (eql 'x) integer) ;;; Dispatch on major mode. @@ -1391,11 +1392,8 @@ See the full list and their hierarchy in `cl--typeof-types'." (defun cl--generic-derived-specializers (mode &rest _) ;; FIXME: Handle (derived-mode <mode1> ... <modeN>) - (let ((specializers ())) - (while mode - (push `(derived-mode ,mode) specializers) - (setq mode (get mode 'derived-mode-parent))) - (nreverse specializers))) + (mapcar (lambda (mode) `(derived-mode ,mode)) + (derived-mode-all-parents mode))) (cl-generic-define-generalizer cl--generic-derived-generalizer 90 (lambda (name) `(and (symbolp ,name) (functionp ,name) ,name)) diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 8920579755e..ee50f572157 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -192,7 +192,7 @@ the standard Lisp indent package." (list (cond ((not (lisp-extended-loop-p (elt state 1))) (+ loop-indentation lisp-simple-loop-indentation)) - ((looking-at "^\\s-*\\(:?\\sw+\\|;\\)") + ((looking-at "^\\s-*\\(?::?\\sw+\\|;\\)") (+ loop-indentation lisp-loop-keyword-indentation)) (t (+ loop-indentation lisp-loop-forms-indentation))) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index ac986adc722..779f25df572 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -171,6 +171,17 @@ to an element already in the list stored in PLACE. val (and (< end (length str)) (substring str end)))) +(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)))))))) ;;; Blocks and exits. @@ -204,7 +215,7 @@ should return. Note that Emacs Lisp doesn't really support multiple values, so all this function does is return LIST." (unless (listp list) - (signal 'wrong-type-argument list)) + (signal 'wrong-type-argument (list list))) list) (defsubst cl-multiple-value-list (expression) @@ -462,6 +473,7 @@ Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to (defun cl-copy-list (list) "Return a copy of LIST, which may be a dotted list. The elements of LIST are not copied, just the list structure itself." + (declare (side-effect-free error-free)) (if (consp list) (let ((res nil)) (while (consp list) (push (pop list) res)) @@ -524,7 +536,12 @@ If ALIST is non-nil, the new pairs are prepended to it." (unless (load "cl-loaddefs" 'noerror 'quiet) ;; When bootstrapping, cl-loaddefs hasn't been built yet! (require 'cl-macs) - (require 'cl-seq)) + (require 'cl-seq) + ;; FIXME: Arguably we should also load `cl-extra', except that this + ;; currently causes more bootstrap troubles, and `cl-extra' is + ;; rarely used, so instead we explicitly (require 'cl-extra) at + ;; those rare places where we do need it. + ) (defun cl--old-struct-type-of (orig-fun object) (or (and (vectorp object) (> (length object) 0) @@ -562,6 +579,7 @@ of record objects." (advice-add 'type-of :around #'cl--old-struct-type-of)) (t (advice-remove 'type-of #'cl--old-struct-type-of)))) +(make-obsolete 'cl-old-struct-compat-mode nil "30.1") (defun cl-constantly (value) "Return a function that takes any number of arguments, but returns VALUE." diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 43207ce7026..7b69404cfac 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -101,6 +101,7 @@ (and (> size 0) (1- size)))) (defun cl--simple-exprs-p (xs) + "Map `cl--simple-expr-p' to each element of list XS." (while (and xs (cl--simple-expr-p (car xs))) (setq xs (cdr xs))) (not xs)) @@ -116,8 +117,10 @@ (while (and (setq x (cdr x)) (cl--safe-expr-p (car x)))) (null x))))) -;;; Check if constant (i.e., no side effects or dependencies). (defun cl--const-expr-p (x) + "Check if X is constant (i.e., no side effects or dependencies). + +See `macroexp-const-p' for similar functionality without cl-lib dependency." (cond ((consp x) (or (eq (car x) 'quote) (and (memq (car x) '(function cl-function)) @@ -243,6 +246,29 @@ The name is made by appending a number to PREFIX, default \"T\"." (defvar cl--bind-enquote) ;Non-nil if &cl-quote was in the formal arglist! (defvar cl--bind-lets) (defvar cl--bind-forms) +(defun cl--slet (bindings body &optional nowarn) + "Like `cl--slet*' but for \"parallel let\"." + (let ((dyns nil)) ;Vars declared as dynbound among the bindings? + (when lexical-binding + (dolist (binding bindings) ;; `seq-some' lead to bootstrap problems. + (when (macroexp--dynamic-variable-p (car binding)) + (push (car binding) dyns)))) + (cond + (dyns + (let ((form `(funcall (lambda (,@(mapcar #'car bindings)) + ,@(macroexp-unprogn body)) + ,@(mapcar #'cadr bindings)))) + (if (not nowarn) form + `(with-suppressed-warnings ((lexical ,@dyns)) ,form)))) + ((null (cdr bindings)) + (macroexp-let* bindings body)) + (t `(let ,bindings ,@(macroexp-unprogn body)))))) + +(defun cl--slet* (bindings body) + "Like `macroexp-let*' but uses static scoping for all the BINDINGS." + (if (null bindings) body + (cl--slet `(,(car bindings)) (cl--slet* (cdr bindings) body)))) + (defun cl--transform-lambda (form bind-block) "Transform a function form FORM of name BIND-BLOCK. BIND-BLOCK is the name of the symbol to which the function will be bound, @@ -337,10 +363,11 @@ FORM is of the form (ARGS . BODY)." (list '&rest (car (pop cl--bind-lets)))))))) `((,@(nreverse simple-args) ,@rest-args) ,@header - ,(macroexp-let* cl--bind-lets - (macroexp-progn - `(,@(nreverse cl--bind-forms) - ,@body))))))) + ;; Function arguments are unconditionally statically scoped (bug#47552). + ,(cl--slet* cl--bind-lets + (macroexp-progn + `(,@(nreverse cl--bind-forms) + ,@body))))))) ;;;###autoload (defmacro cl-defun (name args &rest body) @@ -365,7 +392,7 @@ more details. \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug ;; Same as defun but use cl-lambda-list. - (&define [&name sexp] ;Allow (setf ...) additionally to symbols. + (&define [&name symbolp] cl-lambda-list cl-declarations-or-string [&optional ("interactive" interactive)] @@ -1441,6 +1468,7 @@ For more details, see Info node `(cl)Loop Facility'. (t (setq buf (cl--pop2 cl--loop-args))))) (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) (setq var1 (car var) var2 (cdr var)) + (push (list var nil) loop-for-bindings) (push (list var `(cons ,var1 ,var2)) loop-for-sets)) (cl--loop-set-iterator-function 'intervals (lambda (body) @@ -2013,7 +2041,16 @@ a `let' form, except that the list of symbols can be computed at run-time." ;; *after* handling `function', but we want to stop macroexpansion from ;; being applied infinitely, so we use a cache to return the exact `form' ;; being expanded even though we don't receive it. - ((eq f (car cl--labels-convert-cache)) (cdr cl--labels-convert-cache)) + ;; In Common Lisp, we'd use the `&whole' arg instead (see + ;; "Macro Lambda Lists" in the CLHS). + ((let ((symbols-with-pos-enabled nil)) ;Don't rewrite #'<X@5> => #'<X@3> + (eq f (car cl--labels-convert-cache))) + ;; This value should be `eq' to the `&whole' form. + ;; If this is not the case, we have a bug. + (prog1 (cdr cl--labels-convert-cache) + ;; Drop it, so it can't accidentally interfere with some + ;; unrelated subsequent use of `function' with the same symbol. + (setq cl--labels-convert-cache nil))) (t (let* ((found (assq f macroexpand-all-environment)) (replacement (and found @@ -2021,6 +2058,8 @@ a `let' form, except that the list of symbols can be computed at run-time." (funcall (cdr found) cl--labels-magic))))) (if (and replacement (eq cl--labels-magic (car replacement))) (nth 1 replacement) + ;; FIXME: Here, we'd like to return the `&whole' form, but since ELisp + ;; doesn't have that, we approximate it via `cl--labels-convert-cache'. (let ((res `(function ,f))) (setq cl--labels-convert-cache (cons f res)) res)))))) @@ -2040,6 +2079,13 @@ info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) + ;; The first (symbolp form) case doesn't use `&name' because + ;; it's hard to associate this name with the body of the function + ;; that `form' will return (bug#65344). + ;; We could try and use a `&name' for those cases where the + ;; body of the function can be found, (e.g. the form wraps + ;; some `prog1/progn/let' around the final `lambda'), but it's + ;; not clear it's worth the trouble. (debug ((&rest [&or (symbolp form) (&define [&name symbolp "@cl-flet@"] [&name [] gensym] ;Make it unique! @@ -2052,7 +2098,8 @@ info node `(cl) Function Bindings' for details. (dolist (binding bindings) (let ((var (make-symbol (format "--cl-%s--" (car binding)))) (args-and-body (cdr binding))) - (if (and (= (length args-and-body) 1) (symbolp (car args-and-body))) + (if (and (= (length args-and-body) 1) + (macroexp-copyable-p (car args-and-body))) ;; Optimize (cl-flet ((fun var)) body). (setq var (car args-and-body)) (push (list var (if (= (length args-and-body) 1) @@ -2757,26 +2804,29 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. ;; Common-Lisp's `psetf' does the first, so we'll do the same. (if (null bindings) (if (and (null binds) (null simplebinds)) (macroexp-progn body) + (let ((body-form + (macroexp-progn + (append + (delq nil + (mapcar (lambda (x) + (pcase x + ;; If there's no vnew, do nothing. + (`(,_vold ,_getter ,setter ,vnew) + (funcall setter vnew)))) + binds)) + body)))) `(let* (,@(mapcar (lambda (x) (pcase-let ((`(,vold ,getter ,_setter ,_vnew) x)) (list vold getter))) binds) ,@simplebinds) - (unwind-protect - ,(macroexp-progn - (append - (delq nil - (mapcar (lambda (x) - (pcase x - ;; If there's no vnew, do nothing. - (`(,_vold ,_getter ,setter ,vnew) - (funcall setter vnew)))) - binds)) - body)) - ,@(mapcar (lambda (x) - (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x)) - (funcall setter vold))) - binds)))) + ,(if binds + `(unwind-protect ,body-form + ,@(mapcar (lambda (x) + (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x)) + (funcall setter vold))) + binds)) + body-form)))) (let* ((binding (car bindings)) (place (car binding))) (gv-letplace (getter setter) place @@ -2884,48 +2934,25 @@ The function's arguments should be treated as immutable. ,(if (memq '&key args) `(&whole cl-whole &cl-quote ,@args) (cons '&cl-quote args)) - ,(format "compiler-macro for inlining `%s'." name) + ;; NB. This will produce incorrect results in some + ;; cases, as our coding conventions says that the first + ;; line must be a full sentence. However, if we don't + ;; word wrap we will have byte-compiler warnings about + ;; overly long docstrings. So we can't have a perfect + ;; result here, and choose to avoid the byte-compiler + ;; warnings. + ,(internal--format-docstring-line "compiler-macro for `%s'." name) (cl--defsubst-expand ',argns '(cl-block ,name ,@(cdr (macroexp-parse-body body))) - ;; We used to pass `simple' as - ;; (not (or unsafe (cl-expr-access-order pbody argns))) - ;; But this is much too simplistic since it - ;; does not pay attention to the argvs (and - ;; cl-expr-access-order itself is also too naive). nil ,(and (memq '&key args) 'cl-whole) nil ,@argns))) (cl-defun ,name ,args ,@body)))) -(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs) - (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole - (if (cl--simple-exprs-p argvs) (setq simple t)) - (let* ((substs ()) - (lets (delq nil - (cl-mapcar (lambda (argn argv) - (if (or simple (macroexp-const-p argv)) - (progn (push (cons argn argv) substs) - nil) - (list argn argv))) - argns argvs)))) - ;; FIXME: `sublis/subst' will happily substitute the symbol - ;; `argn' in places where it's not used as a reference - ;; to a variable. - ;; FIXME: `sublis/subst' will happily copy `argv' to a different - ;; scope, leading to name capture. - (setq body (cond ((null substs) body) - ((null (cdr substs)) - (cl-subst (cdar substs) (caar substs) body)) - (t (cl--sublis substs body)))) - (if lets `(let ,lets ,body) body)))) - -(defun cl--sublis (alist tree) - "Perform substitutions indicated by ALIST in TREE (non-destructively)." - (let ((x (assq tree alist))) - (cond - (x (cdr x)) - ((consp tree) - (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree)))) - (t tree)))) +(defun cl--defsubst-expand (argns body _simple whole _unsafe &rest argvs) + (if (and whole (not (cl--safe-expr-p (macroexp-progn argvs)))) + whole + ;; Function arguments are unconditionally statically scoped (bug#47552). + (cl--slet (cl-mapcar #'list argns argvs) body 'nowarn))) ;;; Structures. @@ -3017,6 +3044,7 @@ To see the documentation for a defined struct type, use (defsym (if cl--struct-inline 'cl-defsubst 'defun)) (forms nil) (docstring (if (stringp (car descs)) (pop descs))) + (dynbound-slotnames '()) pred-form pred-check) ;; Can't use `cl-check-type' yet. (unless (cl--struct-name-p name) @@ -3067,7 +3095,11 @@ To see the documentation for a defined struct type, use descs))) (t (error "Structure option %s unrecognized" opt))))) - (unless (or include-name type) + (unless (or include-name type + ;; Don't create a bogus parent to `cl-structure-object' + ;; while compiling the (cl-defstruct cl-structure-object ..) + ;; in `cl-preloaded.el'. + (eq name cl--struct-default-parent)) (setq include-name cl--struct-default-parent)) (when include-name (setq include (cl--struct-get-class include-name))) (if print-func @@ -3120,19 +3152,24 @@ To see the documentation for a defined struct type, use (cons 'and (cdddr pred-form)) `(,predicate cl-x)))) (when pred-form - (push `(,defsym ,predicate (cl-x) + (push `(eval-and-compile + ;; Define the predicate to be effective at compile time + ;; as native comp relies on `cl-typep' that relies on + ;; predicates to be defined as they are registered in + ;; cl-deftype-satisfies. + (,defsym ,predicate (cl-x) (declare (side-effect-free error-free) (pure t)) ,(if (eq (car pred-form) 'and) (append pred-form '(t)) `(and ,pred-form t))) - forms) - (push `(eval-and-compile (define-symbol-prop ',name 'cl-deftype-satisfies ',predicate)) forms)) (let ((pos 0) (descp descs)) (while descp (let* ((desc (pop descp)) (slot (pop desc))) + (when (macroexp--dynamic-variable-p slot) + (push slot dynbound-slotnames)) (if (memq slot '(cl-tag-slot cl-skip-slot)) (progn (push nil slots) @@ -3157,26 +3194,39 @@ To see the documentation for a defined struct type, use ;; The arg "cl-x" is referenced by name in e.g. pred-form ;; and pred-check, so changing it is not straightforward. (push `(,defsym ,accessor (cl-x) - ,(concat - ;; NB. This will produce incorrect results - ;; in some cases, as our coding conventions - ;; says that the first line must be a full - ;; sentence. However, if we don't word wrap - ;; we will have byte-compiler warnings about - ;; overly long docstrings. So we can't have - ;; a perfect result here, and choose to avoid - ;; the byte-compiler warnings. - (internal--format-docstring-line - "Access slot \"%s\" of `%s' struct CL-X." slot name) - (if doc (concat "\n" doc) "")) + ,(let ((long-docstring + (format "Access slot \"%s\" of `%s' struct CL-X." slot name))) + (concat + ;; NB. This will produce incorrect results + ;; in some cases, as our coding conventions + ;; says that the first line must be a full + ;; sentence. However, if we don't word + ;; wrap we will have byte-compiler warnings + ;; about overly long docstrings. So we + ;; can't have a perfect result here, and + ;; choose to avoid the byte-compiler + ;; warnings. + (if (>= (length long-docstring) + (or (bound-and-true-p + byte-compile-docstring-max-column) + 80)) + (concat + (internal--format-docstring-line + "Access slot \"%s\" of CL-X." slot) + "\n" + (internal--format-docstring-line + "Struct CL-X is a `%s'." name)) + (internal--format-docstring-line long-docstring)) + (if doc (concat "\n" doc) ""))) (declare (side-effect-free t)) ,access-body) forms) (when (cl-oddp (length desc)) (push (macroexp-warn-and-return - (format "Missing value for option `%S' of slot `%s' in struct %s!" - (car (last desc)) slot name) + (format-message + "Missing value for option `%S' of slot `%s' in struct %s!" + (car (last desc)) slot name) nil nil nil (car (last desc))) forms) (when (and (keywordp (car defaults)) @@ -3184,8 +3234,9 @@ To see the documentation for a defined struct type, use (let ((kw (car defaults))) (push (macroexp-warn-and-return - (format " I'll take `%s' to be an option rather than a default value." - kw) + (format-message + " I'll take `%s' to be an option rather than a default value." + kw) nil nil nil kw) forms) (push kw desc) @@ -3238,22 +3289,20 @@ To see the documentation for a defined struct type, use (let* ((anames (cl--arglist-args args)) (make (cl-mapcar (lambda (s d) (if (memq s anames) s d)) slots defaults)) - ;; `cl-defsubst' is fundamentally broken: it substitutes - ;; its arguments into the body's `sexp' much too naively - ;; when inlinling, which results in various problems. - ;; For example it generates broken code if your - ;; argument's name happens to be the same as some - ;; function used within the body. - ;; E.g. (cl-defsubst sm-foo (list) (list list)) - ;; will expand `(sm-foo 1)' to `(1 1)' rather than to `(list t)'! - ;; Try to catch this known case! - (con-fun (or type #'record)) - (unsafe-cl-defsubst - (or (memq con-fun args) (assq con-fun args)))) - (push `(,(if unsafe-cl-defsubst 'cl-defun cldefsym) ,cname + (con-fun (or type #'record))) + (push `(,cldefsym ,cname (&cl-defs (nil ,@descs) ,@args) ,(if (stringp doc) doc - (format "Constructor for objects of type `%s'." name)) + ;; NB. This will produce incorrect results in + ;; some cases, as our coding conventions says that + ;; the first line must be a full sentence. + ;; However, if we don't word wrap we will have + ;; byte-compiler warnings about overly long + ;; docstrings. So we can't have a perfect result + ;; here, and choose to avoid the byte-compiler + ;; warnings. + (internal--format-docstring-line + "Constructor for objects of type `%s'." name)) ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) '((declare (side-effect-free t)))) (,con-fun ,@make)) @@ -3272,7 +3321,10 @@ To see the documentation for a defined struct type, use ;; forms)) `(progn (defvar ,tag-symbol) - ,@(nreverse forms) + ,@(if (null dynbound-slotnames) + (nreverse forms) + `((with-suppressed-warnings ((lexical . ,dynbound-slotnames)) + ,@(nreverse forms)))) :autoload-end ;; Call cl-struct-define during compilation as well, so that ;; a subsequent cl-defstruct in the same file can correctly include this @@ -3285,18 +3337,6 @@ To see the documentation for a defined struct type, use ;;; Add cl-struct support to pcase -(defun cl--struct-all-parents (class) - (when (cl--struct-class-p class) - (let ((res ()) - (classes (list class))) - ;; BFS precedence. - (while (let ((class (pop classes))) - (push class res) - (setq classes - (append classes - (cl--class-parents class))))) - (nreverse res)))) - ;;;###autoload (pcase-defmacro cl-struct (type &rest fields) "Pcase patterns that match cl-struct EXPVAL of type TYPE. @@ -3342,8 +3382,8 @@ the form NAME which is a shorthand for (NAME NAME)." (let ((c1 (cl--find-class t1)) (c2 (cl--find-class t2))) (and c1 c2 - (not (or (memq c1 (cl--struct-all-parents c2)) - (memq c2 (cl--struct-all-parents c1))))))) + (not (or (memq t1 (cl--class-allparents c2)) + (memq t2 (cl--class-allparents c1))))))) (let ((c1 (and (symbolp t1) (cl--find-class t1)))) (and c1 (cl--struct-class-p c1) (funcall orig (cl--defstruct-predicate t1) @@ -3456,7 +3496,8 @@ Of course, we really can't know that for sure, so it's just a heuristic." (symbol . symbolp) (vector . vectorp) (window . windowp) - ;; FIXME: Do we really want to consider this a type? + ;; FIXME: Do we really want to consider these types? + (number-or-marker . number-or-marker-p) (integer-or-marker . integer-or-marker-p) )) (put type 'cl-deftype-satisfies pred)) @@ -3575,7 +3616,8 @@ possible. Unlike regular macros, BODY can decide to \"punt\" and leave the original function call alone by declaring an initial `&whole foo' parameter and then returning foo." ;; Like `cl-defmacro', but with the `&whole' special case. - (declare (debug (&define name cl-macro-list + (declare (debug (&define [&name symbolp "@cl-compiler-macro"] + cl-macro-list cl-declarations-or-string def-body)) (indent 2)) (let ((p args) (res nil)) @@ -3680,18 +3722,57 @@ macro that returns its `&whole' argument." ;;; Things that are inline. (cl-proclaim '(inline cl-acons cl-map cl-notany cl-notevery cl-revappend - cl-nreconc gethash)) + cl-nreconc)) ;;; Things that are side-effect-free. (mapc (lambda (x) (function-put x 'side-effect-free t)) - '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd + '(cl-oddp cl-evenp cl-signum cl-ldiff cl-pairlis cl-gcd cl-lcm cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem cl-subseq cl-list-length cl-get cl-getf)) ;;; Things that are side-effect-and-error-free. (mapc (lambda (x) (function-put x 'side-effect-free 'error-free)) - '(eql cl-list* cl-subst cl-acons cl-equalp - cl-random-state-p copy-tree cl-sublis)) + '(cl-list* cl-acons cl-equalp + cl-random-state-p copy-tree)) + +;;; Things whose return value should probably be used. +(mapc (lambda (x) (function-put x 'important-return-value t)) + '( + ;; Functions that are side-effect-free except for the + ;; behavior of functions passed as argument. + cl-mapcar cl-mapcan cl-maplist cl-map cl-mapcon + cl-reduce + cl-assoc cl-assoc-if cl-assoc-if-not + cl-rassoc cl-rassoc-if cl-rassoc-if-not + cl-member cl-member-if cl-member-if-not + cl-adjoin + cl-mismatch cl-search + cl-find cl-find-if cl-find-if-not + cl-position cl-position-if cl-position-if-not + cl-count cl-count-if cl-count-if-not + cl-remove cl-remove-if cl-remove-if-not + cl-remove-duplicates + cl-subst cl-subst-if cl-subst-if-not + cl-substitute cl-substitute-if cl-substitute-if-not + cl-sublis + cl-union cl-intersection cl-set-difference cl-set-exclusive-or + cl-subsetp + cl-every cl-some cl-notevery cl-notany + cl-tree-equal + + ;; Functions that mutate and return a list. + cl-delete cl-delete-if cl-delete-if-not + cl-delete-duplicates + cl-nsubst cl-nsubst-if cl-nsubst-if-not + cl-nsubstitute cl-nsubstitute-if cl-nsubstitute-if-not + cl-nunion cl-nintersection cl-nset-difference cl-nset-exclusive-or + cl-nreconc cl-nsublis + cl-merge + ;; It's safe to ignore the value of `cl-sort' and `cl-stable-sort' + ;; when used on arrays, but most calls pass lists. + cl-sort cl-stable-sort + )) + ;;; Types and assertions. diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 5235be52996..3d0c2b54785 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -52,20 +52,20 @@ (defconst cl--typeof-types ;; Hand made from the source code of `type-of'. - '((integer number number-or-marker atom) + '((integer number integer-or-marker number-or-marker atom) (symbol-with-pos symbol atom) (symbol atom) (string array sequence atom) (cons list sequence) ;; Markers aren't `numberp', yet they are accepted wherever integers are ;; accepted, pretty much. - (marker number-or-marker atom) - (overlay atom) (float number atom) (window-configuration atom) - (process atom) (window atom) + (marker integer-or-marker number-or-marker atom) + (overlay atom) (float number number-or-marker atom) + (window-configuration atom) (process atom) (window atom) ;; FIXME: We'd want to put `function' here, but that's only true ;; for those `subr's which aren't special forms! (subr atom) ;; FIXME: We should probably reverse the order between ;; `compiled-function' and `byte-code-function' since arguably - ;; `subr' and also "compiled functions" but not "byte code functions", + ;; `subr' is also "compiled functions" but not "byte code functions", ;; but it would require changing the value returned by `type-of' for ;; byte code objects, which risks breaking existing code, which doesn't ;; seem worth the trouble. @@ -113,6 +113,7 @@ supertypes from the most specific to least specific.") (record 'cl-slot-descriptor name initform type props))) +;; In use by comp.el (defun cl--struct-get-class (name) (or (if (not (symbolp name)) name) (cl--find-class name) @@ -158,7 +159,9 @@ supertypes from the most specific to least specific.") (cl-check-type name (satisfies cl--struct-name-p)) (unless type ;; Legacy defstruct, using tagged vectors. Enable backward compatibility. - (cl-old-struct-compat-mode 1)) + (with-suppressed-warnings ((obsolete cl-old-struct-compat-mode)) + (message "cl-old-struct-compat-mode is obsolete!") + (cl-old-struct-compat-mode 1))) (if (eq type 'record) ;; Defstruct using record objects. (setq type nil)) @@ -320,15 +323,12 @@ supertypes from the most specific to least specific.") (cl-assert (cl--class-p (cl--find-class 'cl-structure-object))) (defun cl--class-allparents (class) - (let ((parents ()) - (classes (list class))) - ;; BFS precedence. FIXME: Use a topological sort. - (while (let ((class (pop classes))) - (cl-pushnew (cl--class-name class) parents) - (setq classes - (append classes - (cl--class-parents class))))) - (nreverse parents))) + (cons (cl--class-name class) + (merge-ordered-lists (mapcar #'cl--class-allparents + (cl--class-parents class))))) + +(eval-and-compile + (cl-assert (null (cl--class-parents (cl--find-class 'cl-structure-object))))) ;; Make sure functions defined with cl-defsubst can be inlined even in ;; packages which do not require CL. We don't put an autoload cookie diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 61586526ca1..56e35078d39 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -54,9 +54,12 @@ call other entry points instead, such as `cl-prin1'." (prin1 object stream)) (cl-defgeneric cl-print-object-contents (_object _start _stream) - "Dispatcher to print the contents of OBJECT on STREAM. -Print the contents starting with the item at START, without -delimiters." + "Dispatcher to print partial contents of OBJECT on STREAM. +This is used when replacing an ellipsis with the contents it +represents. OBJECT is the object that has been partially printed +and START represents the place at which the contents were +replaced with an ellipsis. +Print the contents hidden by the ellipsis to STREAM." ;; Every cl-print-object method which can print an ellipsis should ;; have a matching cl-print-object-contents method to expand an ;; ellipsis. @@ -65,9 +68,8 @@ delimiters." (cl-defmethod cl-print-object ((object cons) stream) (if (and cl-print--depth (natnump print-level) (> cl-print--depth print-level)) - (cl-print-insert-ellipsis object 0 stream) - (let ((car (pop object)) - (count 1)) + (cl-print-insert-ellipsis object nil stream) + (let ((car (pop object))) (if (and print-quoted (memq car '(\, quote function \` \,@ \,.)) (consp object) @@ -80,26 +82,12 @@ delimiters." stream) (cl-print-object (car object) stream)) (princ "(" stream) - (cl-print-object car stream) - (while (and (consp object) - (not (cond - (cl-print--number-table - (numberp (gethash object cl-print--number-table))) - ((memq object cl-print--currently-printing)) - (t (push object cl-print--currently-printing) - nil)))) - (princ " " stream) - (if (or (not (natnump print-length)) (> print-length count)) - (cl-print-object (pop object) stream) - (cl-print-insert-ellipsis object print-length stream) - (setq object nil)) - (cl-incf count)) - (when object - (princ " . " stream) (cl-print-object object stream)) + (cl-print--cons-tail car object stream) (princ ")" stream))))) -(cl-defmethod cl-print-object-contents ((object cons) _start stream) - (let ((count 0)) +(defun cl-print--cons-tail (car object stream) + (let ((count 1)) + (cl-print-object car stream) (while (and (consp object) (not (cond (cl-print--number-table @@ -107,33 +95,27 @@ delimiters." ((memq object cl-print--currently-printing)) (t (push object cl-print--currently-printing) nil)))) - (unless (zerop count) - (princ " " stream)) + (princ " " stream) (if (or (not (natnump print-length)) (> print-length count)) (cl-print-object (pop object) stream) - (cl-print-insert-ellipsis object print-length stream) + (cl-print-insert-ellipsis object t stream) (setq object nil)) (cl-incf count)) (when object (princ " . " stream) (cl-print-object object stream)))) +(cl-defmethod cl-print-object-contents ((object cons) _start stream) + (cl-print--cons-tail (car object) (cdr object) stream)) + (cl-defmethod cl-print-object ((object vector) stream) (if (and cl-print--depth (natnump print-level) (> cl-print--depth print-level)) - (cl-print-insert-ellipsis object 0 stream) + (cl-print-insert-ellipsis object nil stream) (princ "[" stream) - (let* ((len (length object)) - (limit (if (natnump print-length) - (min print-length len) len))) - (dotimes (i limit) - (unless (zerop i) (princ " " stream)) - (cl-print-object (aref object i) stream)) - (when (< limit len) - (princ " " stream) - (cl-print-insert-ellipsis object limit stream))) + (cl-print--vector-contents object 0 stream) (princ "]" stream))) -(cl-defmethod cl-print-object-contents ((object vector) start stream) +(defun cl-print--vector-contents (object start stream) (let* ((len (length object)) (limit (if (natnump print-length) (min (+ start print-length) len) len)) @@ -146,16 +128,34 @@ delimiters." (princ " " stream) (cl-print-insert-ellipsis object limit stream)))) +(cl-defmethod cl-print-object-contents ((object vector) start stream) + (cl-print--vector-contents object start stream)) ;FIXME: η-redex! + (cl-defmethod cl-print-object ((object hash-table) stream) + ;; Make sure `pp-fill' can pretty print the result! (princ "#<hash-table " stream) (princ (hash-table-test object) stream) (princ " " stream) (princ (hash-table-count object) stream) (princ "/" stream) (princ (hash-table-size object) stream) - (princ (format " %#x" (sxhash object)) stream) + (princ (format " %#x " (sxhash object)) stream) + (cl-print-insert-ellipsis object t stream) (princ ">" stream)) +(cl-defmethod cl-print-object-contents ((object hash-table) _start stream) + ;; If we want to obey `print-length' here, it's not completely obvious + ;; what we should use as marker of "where we are" within the hash-table. + ;; We could use here a simple number or a set of keys already printed, + ;; but it still breaks down if elements get added/removed. + ;; Instead here we convert the hash-table to an alist once and for all. + (let ((alist nil)) + (maphash (lambda (k v) (push (cons k v) alist)) object) + ;; While the order of elements seen by `maphash' is "arbitrary" + ;; it tends to be in the order objects have been added, which is + ;; sometimes handy, so it's nice to preserve this order here. + (cl-print-object (nreverse alist) stream))) + (define-button-type 'help-byte-code 'follow-link t 'action (lambda (button) @@ -165,6 +165,7 @@ delimiters." (defvar cl-print-compiled nil "Control how to print byte-compiled functions. Acceptable values include: +- `raw' to print out the full contents of the function using `prin1'. - `static' to print the vector of constants. - `disassemble' to print the disassembly of the code. - nil to skip printing any details about the code.") @@ -176,6 +177,9 @@ into a button whose action shows the function's disassembly.") (autoload 'disassemble-1 "disass") +;; FIXME: Don't degenerate to `prin1' for the contents of char-tables +;; and records! + (cl-defmethod cl-print-object ((object compiled-function) stream) (unless stream (setq stream standard-output)) ;; We use "#f(...)" rather than "#<...>" so that pp.el gives better results. @@ -184,42 +188,54 @@ into a button whose action shows the function's disassembly.") (if args (prin1 args stream) (princ "()" stream))) - (pcase (help-split-fundoc (documentation object 'raw) object) - ;; Drop args which `help-function-arglist' already printed. - (`(,_usage . ,(and doc (guard (stringp doc)))) - (princ " " stream) - (prin1 doc stream))) - (let ((inter (interactive-form object))) - (when inter - (princ " " stream) - (cl-print-object - (if (eq 'byte-code (car-safe (cadr inter))) - `(interactive ,(make-byte-code nil (nth 1 (cadr inter)) - (nth 2 (cadr inter)) - (nth 3 (cadr inter)))) - inter) - stream))) - (if (eq cl-print-compiled 'disassemble) - (princ - (with-temp-buffer - (insert "\n") - (disassemble-1 object 0) - (buffer-string)) - stream) - (princ " " stream) - (let ((button-start (and cl-print-compiled-button - (bufferp stream) - (with-current-buffer stream (point))))) - (princ (format "#<bytecode %#x>" (sxhash object)) stream) - (when (eq cl-print-compiled 'static) + (if (eq cl-print-compiled 'raw) + (let ((button-start + (and cl-print-compiled-button + (bufferp stream) + (with-current-buffer stream (1+ (point)))))) + (princ " " stream) + (prin1 object stream) + (when button-start + (with-current-buffer stream + (make-text-button button-start (point) + :type 'help-byte-code + 'byte-code-function object)))) + (pcase (help-split-fundoc (documentation object 'raw) object) + ;; Drop args which `help-function-arglist' already printed. + (`(,_usage . ,(and doc (guard (stringp doc)))) + (princ " " stream) + (prin1 doc stream))) + (let ((inter (interactive-form object))) + (when inter (princ " " stream) - (cl-print-object (aref object 2) stream)) - (when button-start - (with-current-buffer stream - (make-text-button button-start (point) - :type 'help-byte-code - 'byte-code-function object))))) - (princ ")" stream)) + (cl-print-object + (if (eq 'byte-code (car-safe (cadr inter))) + `(interactive ,(make-byte-code nil (nth 1 (cadr inter)) + (nth 2 (cadr inter)) + (nth 3 (cadr inter)))) + inter) + stream))) + (if (eq cl-print-compiled 'disassemble) + (princ + (with-temp-buffer + (insert "\n") + (disassemble-1 object 0) + (buffer-string)) + stream) + (princ " " stream) + (let ((button-start (and cl-print-compiled-button + (bufferp stream) + (with-current-buffer stream (point))))) + (princ (format "#<bytecode %#x>" (sxhash object)) stream) + (when (eq cl-print-compiled 'static) + (princ " " stream) + (cl-print-object (aref object 2) stream)) + (when button-start + (with-current-buffer stream + (make-text-button button-start (point) + :type 'help-byte-code + 'byte-code-function object))))) + (princ ")" stream))) ;; This belongs in oclosure.el, of course, but some load-ordering issues make it ;; complicated. @@ -230,26 +246,13 @@ into a button whose action shows the function's disassembly.") (cl-defmethod cl-print-object ((object cl-structure-object) stream) (if (and cl-print--depth (natnump print-level) (> cl-print--depth print-level)) - (cl-print-insert-ellipsis object 0 stream) + (cl-print-insert-ellipsis object nil stream) (princ "#s(" stream) - (let* ((class (cl-find-class (type-of object))) - (slots (cl--struct-class-slots class)) - (len (length slots)) - (limit (if (natnump print-length) - (min print-length len) len))) - (princ (cl--struct-class-name class) stream) - (dotimes (i limit) - (let ((slot (aref slots i))) - (princ " :" stream) - (princ (cl--slot-descriptor-name slot) stream) - (princ " " stream) - (cl-print-object (aref object (1+ i)) stream))) - (when (< limit len) - (princ " " stream) - (cl-print-insert-ellipsis object limit stream))) + (princ (cl--struct-class-name (cl-find-class (type-of object))) stream) + (cl-print--struct-contents object 0 stream) (princ ")" stream))) -(cl-defmethod cl-print-object-contents ((object cl-structure-object) start stream) +(defun cl-print--struct-contents (object start stream) (let* ((class (cl-find-class (type-of object))) (slots (cl--struct-class-slots class)) (len (length slots)) @@ -258,7 +261,7 @@ into a button whose action shows the function's disassembly.") (i start)) (while (< i limit) (let ((slot (aref slots i))) - (unless (= i start) (princ " " stream)) + (unless (and (= i start) (> i 0)) (princ " " stream)) (princ ":" stream) (princ (cl--slot-descriptor-name slot) stream) (princ " " stream) @@ -268,17 +271,34 @@ into a button whose action shows the function's disassembly.") (princ " " stream) (cl-print-insert-ellipsis object limit stream)))) +(cl-defmethod cl-print-object-contents ((object cl-structure-object) start stream) + (cl-print--struct-contents object start stream)) ;FIXME: η-redex! + +(defvar cl-print-string-length nil + "Maximum length of string to print before abbreviating. +A value of nil means no limit. + +When Emacs abbreviates a string, it prints the first +`cl-print-string-length' characters of the string, followed by +\"...\". You can type RET, or click on this ellipsis to expand +the string. + +This variable has effect only in the `cl-prin*' functions, not in +primitives such as `prin1'.") + (cl-defmethod cl-print-object ((object string) stream) (unless stream (setq stream standard-output)) (let* ((has-properties (or (text-properties-at 0 object) (next-property-change 0 object))) (len (length object)) - (limit (if (natnump print-length) (min print-length len) len))) + (limit (if (natnump cl-print-string-length) + (min cl-print-string-length len) + len))) (if (and has-properties cl-print--depth (natnump print-level) (> cl-print--depth print-level)) - (cl-print-insert-ellipsis object 0 stream) + (cl-print-insert-ellipsis object nil stream) ;; Print all or part of the string (when has-properties (princ "#(" stream)) @@ -294,28 +314,36 @@ into a button whose action shows the function's disassembly.") (- (point) 1) stream))))) ;; Print the property list. (when has-properties - (let* ((interval-limit (and (natnump print-length) - (max 1 (/ print-length 3)))) - (interval-count 0) - (start-pos (if (text-properties-at 0 object) - 0 (next-property-change 0 object))) - (end-pos (next-property-change start-pos object len))) - (while (and (or (null interval-limit) - (< interval-count interval-limit)) - (< start-pos len)) - (let ((props (text-properties-at start-pos object))) - (when props - (princ " " stream) (princ start-pos stream) - (princ " " stream) (princ end-pos stream) - (princ " " stream) (cl-print-object props stream) - (cl-incf interval-count)) - (setq start-pos end-pos - end-pos (next-property-change start-pos object len)))) - (when (< start-pos len) - (princ " " stream) - (cl-print-insert-ellipsis object (list start-pos) stream))) + (cl-print--string-props object 0 stream) (princ ")" stream))))) +(defun cl-print--string-props (object start stream) + (let* ((first (not (eq start 0))) + (len (length object)) + (interval-limit (and (natnump print-length) + (max 1 (/ print-length 3)))) + (interval-count 0) + (start-pos (if (text-properties-at start object) + start (next-property-change start object))) + (end-pos (next-property-change start-pos object len))) + (while (and (or (null interval-limit) + (< interval-count interval-limit)) + (< start-pos len)) + (let ((props (text-properties-at start-pos object))) + (when props + (if first + (setq first nil) + (princ " " stream)) + (princ start-pos stream) + (princ " " stream) (princ end-pos stream) + (princ " " stream) (cl-print-object props stream) + (cl-incf interval-count)) + (setq start-pos end-pos + end-pos (next-property-change start-pos object len)))) + (when (< start-pos len) + (princ " " stream) + (cl-print-insert-ellipsis object (list start-pos) stream)))) + (cl-defmethod cl-print-object-contents ((object string) start stream) ;; If START is an integer, it is an index into the string, and the ;; ellipsis that needs to be expanded is part of the string. If @@ -324,39 +352,18 @@ into a button whose action shows the function's disassembly.") (let* ((len (length object))) (if (atom start) ;; Print part of the string. - (let* ((limit (if (natnump print-length) - (min (+ start print-length) len) len)) + (let* ((limit (if (natnump cl-print-string-length) + (min (+ start cl-print-string-length) len) + len)) (substr (substring-no-properties object start limit)) (printed (prin1-to-string substr)) - (trimmed (substring printed 1 (1- (length printed))))) - (princ trimmed) + (trimmed (substring printed 1 -1))) + (princ trimmed stream) (when (< limit len) (cl-print-insert-ellipsis object limit stream))) ;; Print part of the property list. - (let* ((first t) - (interval-limit (and (natnump print-length) - (max 1 (/ print-length 3)))) - (interval-count 0) - (start-pos (car start)) - (end-pos (next-property-change start-pos object len))) - (while (and (or (null interval-limit) - (< interval-count interval-limit)) - (< start-pos len)) - (let ((props (text-properties-at start-pos object))) - (when props - (if first - (setq first nil) - (princ " " stream)) - (princ start-pos stream) - (princ " " stream) (princ end-pos stream) - (princ " " stream) (cl-print-object props stream) - (cl-incf interval-count)) - (setq start-pos end-pos - end-pos (next-property-change start-pos object len)))) - (when (< start-pos len) - (princ " " stream) - (cl-print-insert-ellipsis object (list start-pos) stream)))))) + (cl-print--string-props object (car start) stream)))) ;;; Circularity and sharing. @@ -367,6 +374,7 @@ into a button whose action shows the function's disassembly.") (cl-defmethod cl-print-object :around (object stream) ;; FIXME: Only put such an :around method on types where it's relevant. (let ((cl-print--depth (if cl-print--depth (1+ cl-print--depth) 1))) + ;; FIXME: Handle print-level here once and forall? (cond (print-circle (let ((n (gethash object cl-print--number-table))) @@ -443,10 +451,53 @@ into a button whose action shows the function's disassembly.") (cl-print--find-sharing object print-number-table))) print-number-table)) +(define-button-type 'cl-print-ellipsis + 'skip t 'action #'cl-print-expand-ellipsis + 'help-echo "mouse-2, RET: expand this ellipsis") + +(defvar cl-print-expand-ellipsis-function + #'cl-print--default-expand-ellipsis + "Function to tweak the way ellipses are expanded. +The function is called with 3 arguments, BEG, END, and FUNC. +BEG and END delimit the ellipsis that will be replaced. +FUNC is the function that will do the expansion. +It should be called with a single argument specifying the desired +limit of the expansion's length, as used in `cl-print-to-string-with-limit'. +FUNC will return the position of the end of the newly printed text.") + +(defun cl-print--default-expand-ellipsis (begin end value line-length) + (delete-region begin end) + (insert (cl-print-to-string-with-limit + #'cl-print--expand-ellipsis value line-length)) + (point)) + + +(defun cl-print-expand-ellipsis (&optional button) + "Expand display of the elided form at BUTTON. +BUTTON can also be a buffer position or nil (to mean point)." + (interactive) + (goto-char (cond + ((null button) (point)) + (t (button-start button)))) + (unless (get-text-property (point) 'cl-print-ellipsis) + (if (and (> (point) (point-min)) + (get-text-property (1- (point)) 'cl-print-ellipsis)) + (backward-char) + (user-error "No ellipsis to expand here"))) + (let* ((end (next-single-property-change (point) 'cl-print-ellipsis)) + (begin (previous-single-property-change end 'cl-print-ellipsis)) + (value (get-text-property begin 'cl-print-ellipsis))) + ;; FIXME: Rather than `t' (i.e. reuse the print-length/level unchanged), + ;; I think it would make sense to increase the level by 1 and to + ;; double the length at each expansion step. + (funcall cl-print-expand-ellipsis-function + begin end value t) + (goto-char begin))) + (defun cl-print-insert-ellipsis (object start stream) "Print \"...\" to STREAM with the `cl-print-ellipsis' text property. Save state in the text property in order to print the elided part -of OBJECT later. START should be 0 if the whole OBJECT is being +of OBJECT later. START should be nil if the whole OBJECT is being elided, otherwise it should be an index or other pointer into the internals of OBJECT which can be passed to `cl-print-object-contents' at a future time." @@ -466,10 +517,10 @@ STREAM should be a buffer. OBJECT and START are as described in (let ((value (list object start cl-print--number-table cl-print--currently-printing))) (with-current-buffer stream - (put-text-property beg end 'cl-print-ellipsis value stream)))) + (put-text-property beg end 'cl-print-ellipsis value stream) + (make-text-button beg end :type 'cl-print-ellipsis)))) -;;;###autoload -(defun cl-print-expand-ellipsis (value stream) +(defun cl-print--expand-ellipsis (value stream) "Print the expansion of an ellipsis to STREAM. VALUE should be the value of the `cl-print-ellipsis' text property which was attached to the ellipsis by `cl-prin1'." @@ -481,7 +532,7 @@ which was attached to the ellipsis by `cl-prin1'." (cl-print--currently-printing (nth 3 value))) (when (eq object (car cl-print--currently-printing)) (pop cl-print--currently-printing)) - (if (equal start 0) + (if (memq start '(0 nil)) (cl-print-object object stream) (cl-print-object-contents object start stream)))) @@ -511,27 +562,35 @@ node `(elisp)Output Variables'." (defun cl-print-to-string-with-limit (print-function value limit) "Return a string containing a printed representation of VALUE. Attempt to get the length of the returned string under LIMIT -characters with appropriate settings of `print-level' and -`print-length.' Use PRINT-FUNCTION to print, which should take -the arguments VALUE and STREAM and which should respect -`print-length' and `print-level'. LIMIT may be nil or zero in -which case PRINT-FUNCTION will be called with `print-level' and -`print-length' bound to nil. +characters with appropriate settings of `print-level', +`print-length', and `cl-print-string-length'. Use +PRINT-FUNCTION to print, which should take the arguments VALUE +and STREAM and which should respect `print-length', +`print-level', and `cl-print-string-length'. LIMIT may be nil or +zero in which case PRINT-FUNCTION will be called with these +settings bound to nil, and it can also be t in which case +PRINT-FUNCTION will be called with their current values. Use this function with `cl-prin1' to print an object, -abbreviating it with ellipses to fit within a size limit. Use -this function with `cl-prin1-expand-ellipsis' to expand an -ellipsis, abbreviating the expansion to stay within a size -limit." - (setq limit (and (natnump limit) - (not (zerop limit)) - limit)) +abbreviating it with ellipses to fit within a size limit." + (setq limit (and (not (eq limit 0)) limit)) ;; Since this is used by the debugger when stack space may be ;; limited, if you increase print-level here, add more depth in ;; call_debugger (bug#31919). - (let* ((print-length (when limit (min limit 50))) - (print-level (when limit (min 8 (truncate (log limit))))) - (delta-length (when limit + (let* ((print-length (cond + ((eq limit t) print-length) + ((or (null limit) (zerop limit)) nil) + (t (min limit 50)))) + (print-level (cond + ((eq limit t) print-level) + ((or (null limit) (zerop limit)) nil) + (t (min 8 (truncate (log limit)))))) + (cl-print-string-length + (cond + ((eq limit t) cl-print-string-length) + ((or (null limit) (zerop limit)) nil) + (t (max 0 (- limit 3))))) + (delta-length (when (natnump limit) (max 1 (truncate (/ print-length print-level)))))) (with-temp-buffer (catch 'done @@ -541,12 +600,15 @@ limit." (let ((result (- (point-max) (point-min)))) ;; Stop when either print-level is too low or the value is ;; successfully printed in the space allowed. - (when (or (not limit) (< result limit) (<= print-level 2)) + (when (or (not (natnump limit)) (< result limit) (<= print-level 2)) (throw 'done (buffer-string))) (let* ((ratio (/ result limit)) (delta-level (max 1 (min (- print-level 2) ratio)))) (cl-decf print-level delta-level) - (cl-decf print-length (* delta-length delta-level))))))))) + (cl-decf print-length (* delta-length delta-level)) + (when cl-print-string-length + (cl-decf cl-print-string-length + (ceiling cl-print-string-length 4.0)))))))))) (provide 'cl-print) ;;; cl-print.el ends here diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el new file mode 100644 index 00000000000..b7a685223ed --- /dev/null +++ b/lisp/emacs-lisp/comp-common.el @@ -0,0 +1,553 @@ +;;; comp-common.el --- common code -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Andrea Corallo <acorallo@gnu.org> +;; 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 file holds common code required by comp.el and comp-run.el. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) + +;; These variables and functions are defined in comp.c +(defvar comp-native-version-dir) +(defvar native-comp-eln-load-path) + +(defgroup comp-common nil + "Emacs Lisp native compiler common code." + :group 'lisp) + +(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 'natnum + :risky t + :version "28.1") + +(defcustom native-comp-never-optimize-functions + ;; We used to list those functions here that were advised during + ;; preload, but we now prefer to disallow preload advices in + ;; loadup.el (bug#67005). + '(eval) + "Primitive functions to exclude from trampoline optimization. + +Primitive functions included in this list will not be called +directly by the natively-compiled code, which makes trampolines for +those primitives unnecessary in case of function redefinition/advice." + :type '(repeat symbol) + :version "30.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") + +(defconst comp-known-type-specifiers + `( + ;; Functions we can trust not to be redefined, or, if redefined, + ;; to expose the same type. The vast majority of these are + ;; 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) (or string null))) + (buffer-list (function (&optional frame) list)) + (buffer-local-variables (function (&optional buffer) list)) + (buffer-modified-p + (function (&optional buffer) (or boolean (member autosaved)))) + (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)) (or fixnum null))) + (char-before (function (&optional (or marker integer)) (or fixnum null))) + (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) + (or cons null + (member bottom-divider right-divider mode-line header-line + tab-line left-fringe right-fringe vertical-line + left-margin right-margin)))) + (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 () (or cons null))) + (current-minor-mode-maps (function () (or cons null))) + (current-time (function () cons)) + (current-time-string (function (&optional (or number list) + (or symbol string cons integer)) + string)) + (current-time-zone (function (&optional (or number list) + (or symbol string cons integer)) + cons)) + (custom-variable-p (function (symbol) t)) + (decode-char (function (cons t) (or fixnum null))) + (decode-time (function (&optional (or number list) + (or symbol string cons integer) + 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) number)) + (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) (or boolean string))) + (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) (or boolean string))) + (file-writable-p (function (string) boolean)) + (fixnump (function (t) boolean)) + (float (function (number) float)) + (float-time (function (&optional (or number list)) 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 (or number list) + (or symbol string cons integer)) + 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) (or boolean (member icon)))) + (framep (function (t) symbol)) + (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) (or window null))) + (get-lru-window (function (&optional t t t) (or window null))) + (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) (or buffer null))) + (markerp (function (t) boolean)) + (max (function ((or number marker) &rest (or number marker)) number)) + (max-char (function (&optional t) 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 () (or window null))) + (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 &optional t) t)) + (plist-member (function (list t &optional 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 t) string)) + (processp (function (t) boolean)) + (proper-list-p (function (t) (or fixnum null))) + (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) (or cons null))) + (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 ((or number list) &optional (or symbol integer)) + (or cons number))) + (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-limple-calls '(call + callref + direct-call + direct-callref) + "Limple operators used to call subrs.") + +(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-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.") + +(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'.") + +(defconst comp-log-buffer-name "*Native-compile-Log*" + "Name of the native-compiler log buffer.") + +(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)))) + +(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-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) + (unless (derived-mode-p 'compilation-mode) + (emacs-lisp-compilation-mode)) + (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-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-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-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)) + +;;;###autoload +(defun comp-function-type-spec (function) + "Return the type specifier of FUNCTION. + +This function returns a cons cell whose car is the function +specifier, and cdr is a symbol, either `inferred' or `know'. +If the symbol is `inferred', the type specifier is automatically +inferred from the code itself by the native compiler; if it is +`know', the type specifier comes from `comp-known-type-specifiers'." + (let ((kind 'know) + type-spec ) + (when-let ((res (assoc function comp-known-type-specifiers))) + (setf type-spec (cadr res))) + (let ((f (and (symbolp function) + (symbol-function function)))) + (when (and f + (null type-spec) + (subr-native-elisp-p f)) + (setf kind 'inferred + type-spec (subr-type f)))) + (when type-spec + (cons type-spec kind)))) + +(provide 'comp-common) + +;;; comp-common.el ends here diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 4653e1f991c..339a6142178 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -36,6 +36,7 @@ ;;; Code: (require 'cl-lib) +(require 'cl-extra) ;HACK: For `cl-find-class' when `cl-loaddefs' is missing. (defconst comp--typeof-builtin-types (mapcar (lambda (x) (append x '(t))) @@ -86,7 +87,43 @@ Integer values are handled in the `range' slot.") (ret nil :type (or comp-cstr comp-cstr-f) :documentation "Returned value.")) +(defun comp--cl-class-hierarchy (x) + "Given a class name `x' return its hierarchy." + `(,@(cl--class-allparents (cl--struct-get-class x)) + ;; FIXME: AFAICT, `comp--all-classes' will also find those struct types + ;; which use :type and can thus be either `vector' or `cons' (the latter + ;; isn't `atom'). + atom + t)) + +(defun comp--all-classes () + "Return all non built-in type names currently defined." + (let (res) + (mapatoms (lambda (x) + (when (cl-find-class x) + (push x res))) + obarray) + res)) + +(defun comp--compute-typeof-types () + (append comp--typeof-builtin-types + (mapcar #'comp--cl-class-hierarchy (comp--all-classes)))) + +(defun comp--compute--pred-type-h () + (cl-loop with h = (make-hash-table :test #'eq) + for class-name in (comp--all-classes) + for pred = (get class-name 'cl-deftype-satisfies) + when pred + do (puthash pred class-name h) + finally return h)) + (cl-defstruct comp-cstr-ctxt + (typeof-types (comp--compute-typeof-types) + :type list + :documentation "Type hierarchy.") + (pred-type-h (comp--compute--pred-type-h) + :type hash-table + :documentation "Hash pred -> type.") (union-typesets-mem (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for `comp-union-typesets'.") @@ -107,6 +144,15 @@ Integer values are handled in the `range' slot.") :documentation "Serve memoization for `intersection-mem'.")) +(defun comp-cstr-ctxt-update-type-slots (ctxt) + "Update the type related slots of CTXT. +This must run after byte compilation in order to account for user +defined types." + (setf (comp-cstr-ctxt-typeof-types ctxt) + (comp--compute-typeof-types)) + (setf (comp-cstr-ctxt-pred-type-h ctxt) + (comp--compute--pred-type-h))) + (defmacro with-comp-cstr-accessors (&rest body) "Define some quick accessor to reduce code vergosity in BODY." (declare (debug (form body)) @@ -218,69 +264,130 @@ Return them as multiple value." ;;; 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--sym-lessp (x y) + "Like `string-lessp' but for symbol names." + (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-builtin-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)))) +(defun comp--direct-supertypes (type) + "Return the direct supertypes of TYPE." + (let ((supers (comp-supertypes type))) + (cl-assert (eq type (car supers))) + (cl-loop + with notdirect = nil + with direct = nil + for parent in (cdr supers) + unless (memq parent notdirect) + do (progn + (push parent direct) + (setq notdirect (append notdirect (comp-supertypes parent)))) + finally return direct))) (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) + (memq type2 (comp-supertypes type1)) (comp-cstr-ctxt-subtype-p-mem comp-ctxt))))) +(defun comp--normalize-typeset0 (typeset) + ;; For every type search its supertypes. If all the subtypes of a + ;; supertype are presents remove all of them, add the identified + ;; supertype and restart. + ;; FIXME: The intention is to return a 100% equivalent but simpler + ;; typeset, but this is only the case when the supertype is abstract + ;; and "final/closed" (i.e. can't have new subtypes). + (when typeset + (while (eq 'restart + (cl-loop + named main + for sup in (cl-remove-duplicates + (apply #'append + (mapcar #'comp--direct-supertypes typeset))) + for subs = (comp--direct-subtypes sup) + when (and (length> subs 1) ;;FIXME: Why? + ;; Every subtype of `sup` is a subtype of + ;; some element of `typeset`? + ;; It's tempting to just check (member x typeset), + ;; but think of the typeset (marker number), + ;; where `sup' is `integer-or-marker' and `sub' + ;; is `integer'. + (cl-every (lambda (sub) + (cl-some (lambda (type) + (comp-subtype-p sub type)) + typeset)) + subs)) + do (progn + (setq typeset (cons sup (cl-set-difference typeset subs))) + (cl-return-from main 'restart))))) + typeset)) + +(defun comp-normalize-typeset (typeset) + "Sort TYPESET and return it." + (cl-sort (comp--normalize-typeset0 (cl-remove-duplicates typeset)) #'comp--sym-lessp)) + +(defun comp--direct-subtypes (type) + "Return all the direct subtypes of TYPE." + ;; TODO: memoize. + (let ((subtypes ())) + (dolist (j (comp-cstr-ctxt-typeof-types comp-ctxt)) + (let ((occur (memq type j))) + (when occur + (while (not (eq j occur)) + (let ((candidate (pop j))) + (when (and (not (memq candidate subtypes)) + (memq type (comp--direct-supertypes candidate))) + (push candidate subtypes))))))) + (cl-sort subtypes #'comp--sym-lessp))) + +(defun comp--intersection (list1 list2) + "Like `cl-intersection` but preserves the order of one of its args." + (if (equal list1 list2) list1 + (let ((res nil)) + (while list2 + (if (memq (car list2) list1) + (push (car list2) res)) + (pop list2)) + (nreverse res)))) + +(defun comp-supertypes (type) + "Return the ordered list of supertypes of TYPE." + ;; FIXME: We should probably keep the results in + ;; `comp-cstr-ctxt-typeof-types' (or maybe even precompute them + ;; and maybe turn `comp-cstr-ctxt-typeof-types' into a hash-table). + ;; Or maybe we shouldn't keep structs and defclasses in it, + ;; and just use `cl--class-allparents' when needed (and refuse to + ;; compute their direct subtypes since we can't know them). + (cl-loop + named loop + with above + for lane in (comp-cstr-ctxt-typeof-types comp-ctxt) + do (let ((x (memq type lane))) + (cond + ((null x) nil) + ((eq x lane) (cl-return-from loop x)) ;A base type: easy case. + (t (setq above + (if above (comp--intersection x above) x))))) + finally return above)) + (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) + ;; List of (TYPE . SUPERTYPES)", ordered from + ;; "most general" to "least general" + with typess = (sort (mapcar #'comp-supertypes + (apply #'append typesets)) + (lambda (l1 l2) + (<= (length l1) (length l2)))) with res = '() - for lane in comp--typeof-builtin-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))) + for types in typess + ;; Don't keep this type if it's a subtype of one of + ;; the other types. + unless (comp--intersection types res) + do (push (car types) res) finally return (comp-normalize-typeset res)) (comp-cstr-ctxt-union-typesets-mem comp-ctxt)))) @@ -774,7 +881,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (comp-subtype-p neg-type pos-type)) do (cl-loop with found - for (type . _) in (comp-supertypes neg-type) + for type in (comp-supertypes neg-type) when found collect type into res when (eq type pos-type) @@ -867,6 +974,23 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (null (neg cstr)) (equal (typeset cstr) '(cons))))) +;; Move to comp.el? +(defsubst comp-cstr-cl-tag-p (cstr) + "Return non-nil if CSTR is a CL tag." + (with-comp-cstr-accessors + (and (null (range cstr)) + (null (neg cstr)) + (null (typeset cstr)) + (length= (valset cstr) 1) + (string-match (rx "cl-struct-" (group-n 1 (1+ not-newline)) "-tags") + (symbol-name (car (valset cstr))))))) + +(defsubst comp-cstr-cl-tag (cstr) + "If CSTR is a CL tag return its tag name." + (with-comp-cstr-accessors + (and (comp-cstr-cl-tag-p cstr) + (intern (match-string 1 (symbol-name (car (valset cstr)))))))) + (defun comp-cstr-= (dst op1 op2) "Constraint OP1 being = OP2 setting the result into DST." (with-comp-cstr-accessors @@ -1121,8 +1245,8 @@ FN non-nil indicates we are parsing a function lambda list." :ret (comp-type-spec-to-cstr ret))) (_ (error "Invalid type specifier")))) -(defun comp-cstr-to-type-spec (cstr) - "Given CSTR return its type specifier." +(defun comp--simple-cstr-to-type-spec (cstr) + "Given a non comp-cstr-f CSTR return its type specifier." (let ((valset (comp-cstr-valset cstr)) (typeset (comp-cstr-typeset cstr)) (range (comp-cstr-range cstr)) @@ -1176,6 +1300,20 @@ FN non-nil indicates we are parsing a function lambda list." `(not ,final) final)))) +(defun comp-cstr-to-type-spec (cstr) + "Given CSTR return its type specifier." + (cl-etypecase cstr + (comp-cstr-f + `(function + ,(mapcar (lambda (x) + (cl-etypecase x + (comp-cstr (comp-cstr-to-type-spec x)) + (symbol x))) + (comp-cstr-f-args cstr)) + ,(comp--simple-cstr-to-type-spec (comp-cstr-f-ret cstr)))) + (comp-cstr + (comp--simple-cstr-to-type-spec cstr)))) + (provide 'comp-cstr) ;;; comp-cstr.el ends here diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el new file mode 100644 index 00000000000..4b1d2451a4e --- /dev/null +++ b/lisp/emacs-lisp/comp-run.el @@ -0,0 +1,460 @@ +;;; comp-runtime.el --- runtime Lisp native compiler code -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Andrea Corallo <acorallo@gnu.org> +;; 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: + +;; While the main native compiler is implemented in comp.el, when +;; commonly used as a jit compiler it is only loaded by Emacs sub +;; processes performing async compilation. This files contains all +;; the code needed to drive async compilations and any Lisp code +;; needed at runtime to run native code. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'comp-common) +(require 'bytecomp) ;; For `emacs-lisp-compilation-mode'. + +(defgroup comp-run nil + "Emacs Lisp native compiler runtime." + :group 'lisp) + +(defcustom native-comp-jit-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-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 'natnum + :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-always-compile nil + "Non-nil means unconditionally (re-)compile all files." + :type 'boolean + :version "28.1") + +(make-obsolete-variable 'native-comp-deferred-compilation-deny-list + 'native-comp-jit-compilation-deny-list + "29.1") + +(defcustom native-comp-async-cu-done-functions nil + "List of functions to call when asynchronous compilation of a file is done. +Each function is called with one argument FILE, the filename whose +compilation has completed." + :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-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") + +(defconst comp-async-buffer-name "*Async-native-compile-log*" + "Name of the async compilation buffer log.") + +(defvar comp-no-spawn nil + "Non-nil don't spawn native compilation processes.") + +(defvar comp-async-compilations (make-hash-table :test #'equal) + "Hash table file-name -> async compilation process.") + +;; These variables and functions are defined in comp.c +(defvar comp--no-native-compile) +(defvar comp-deferred-pending-h) +(defvar comp-installed-trampolines-h) +(defvar native-comp-enable-subr-trampolines) + +(declare-function comp--install-trampoline "comp.c") +(declare-function comp-el-to-eln-filename "comp.c") +(declare-function native-elisp-load "comp.c") + +(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) + (gethash (file-name-with-extension file "elc") comp--no-native-compile) + (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-jit-compilation-deny-list' matches. + (and (eq load 'late) + (seq-some (lambda (re) + (string-match-p re file)) + native-comp-jit-compilation-deny-list)))) + +(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)) + +(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 + (max 1 (/ (num-processors) 2)))) + native-comp-async-jobs-number)) + +(defvar comp-last-scanned-async-output nil) +(make-variable-buffer-local 'comp-last-scanned-async-output) +;; From warnings.el +(defvar warning-suppress-types) +(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))) + +(defconst comp-valid-source-re (rx ".el" (? ".gz") eos) + "Regexp to match filename of valid input source files.") + +(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." + (cl-assert (null comp-no-spawn)) + (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. + ;; Skip compilation if `comp-el-to-eln-filename' fails + ;; to find a writable directory. + (with-demoted-errors "Async compilation :%S" + (file-newer-than-file-p + source-file (comp-el-to-eln-filename source-file)))) + do (let* ((expr `((require 'comp) + (setq comp-async-compilation t + warning-fill-column most-positive-fixnum) + ,(let ((set (list 'setq))) + (dolist (var '(comp-file-preloaded-p + native-compile-target-directory + native-comp-speed + native-comp-debug + native-comp-verbose + comp-libgccjit-reproducer + native-comp-eln-load-path + native-comp-compiler-options + native-comp-driver-options + load-path + backtrace-line-length + byte-compile-warnings + ;; package-load-list + ;; package-user-dir + ;; package-directory-list + )) + (when (boundp var) + (push var set) + (push `',(symbol-value var) set))) + (nreverse set)) + ;; FIXME: Activating all packages would align the + ;; functionality offered with what is usually done + ;; for ELPA packages (and thus fix some compilation + ;; issues with some ELPA packages), but it's too + ;; blunt an instrument (e.g. we don't even know if + ;; we're compiling such an ELPA package at + ;; this point). + ;;(package-activate-all) + ,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) + (default-directory invocation-directory) + (process (make-process + :name (concat "Compiling: " source-file) + :buffer (with-current-buffer + (get-buffer-create + comp-async-buffer-name) + (unless (derived-mode-p 'compilation-mode) + (emacs-lisp-compilation-mode)) + (current-buffer)) + :command (list + (expand-file-name invocation-name + invocation-directory) + "-no-comp-spawn" "-Q" "--batch" + "--eval" + ;; Suppress Abort dialogs on MS-Windows + "(setq w32-disable-abort-dialog t)" + "-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 + (unless (derived-mode-p 'compilation-mode) + (emacs-lisp-compilation-mode)) + (let ((inhibit-read-only t)) + (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))) + +(defconst comp-warn-primitives + '(null memq gethash and subrp not subr-native-elisp-p + comp--install-trampoline concat if symbolp symbol-name make-string + length aset aref length> mapcar expand-file-name + file-name-as-directory file-exists-p native-elisp-load) + "List of primitives we want to warn about in case of redefinition. +This are essential for the trampoline machinery to work properly.") + +(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)))) + +(declare-function comp-trampoline-compile "comp") +;;;###autoload +(defun comp-subr-trampoline-install (subr-name) + "Make SUBR-NAME effectively advice-able when called from native code." + (when (memq subr-name comp-warn-primitives) + (warn "Redefining `%s' might break native compilation of trampolines." + subr-name)) + (unless (or (null native-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))) + (when-let ((trampoline (or (comp-trampoline-search subr-name) + (comp-trampoline-compile subr-name)))) + (comp--install-trampoline subr-name trampoline)))) + +;;;###autoload +(defun native--compile-async (files &optional recursively load selector) + ;; BEWARE, this function is also called directly from C. + "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 ((added-something nil) + file-list) + (dolist (file-or-dir files) + (cond ((file-directory-p file-or-dir) + (dolist (file (if recursively + (directory-files-recursively + file-or-dir comp-valid-source-re) + (directory-files file-or-dir + t comp-valid-source-re))) + (push file file-list))) + ((file-exists-p file-or-dir) (push file-or-dir file-list)) + (t (signal 'native-compiler-error + (list "Not a file nor directory" file-or-dir))))) + (dolist (file file-list) + (if-let ((entry (seq-find (lambda (x) (string= file (car x))) comp-files-queue))) + ;; 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))) + (setf comp-files-queue + (cl-loop for i in comp-files-queue + with old = (car entry) + if (string= (car i) old) + collect (cons file load) + else + collect i))) + + (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))) + added-something t) + (display-warning 'comp + (format "No write access for %s skipping." + out-filename))))))) + ;; Perhaps nothing passed `native-compile-async-skip-p'? + (when (and added-something + ;; Don't start if there's one already running. + (zerop (comp-async-runnings))) + (comp-run-async-workers)))) + +;;;###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-run) + +;;; comp-run.el ends here diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 586a4df3890..f9eeef1b9e8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -29,16 +29,27 @@ ;;; 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-common) (require 'comp-cstr) +;; These variables and functions are defined in comp.c +(defvar comp-native-version-dir) +(defvar comp-subr-arities-h) +(defvar native-comp-eln-load-path) +(defvar native-comp-enable-subr-trampolines) + +(declare-function comp--compile-ctxt-to-file "comp.c") +(declare-function comp--init-ctxt "comp.c") +(declare-function comp--release-ctxt "comp.c") +(declare-function comp-el-to-eln-filename "comp.c") +(declare-function comp-el-to-eln-rel-filename "comp.c") +(declare-function native-elisp-load "comp.c") + (defgroup comp nil "Emacs Lisp native compiler." :group 'lisp) @@ -69,33 +80,6 @@ This is intended for debugging the compiler itself. :safe #'natnump :version "29.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 'natnum - :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-jit-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") - -(make-obsolete-variable 'native-comp-deferred-compilation-deny-list - 'native-comp-jit-compilation-deny-list - "29.1") - (defcustom native-comp-bootstrap-deny-list '() "List of regexps to exclude files from native compilation during bootstrap. @@ -104,78 +88,6 @@ 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. - -Primitive functions included in this list will not be called -directly by the natively-compiled code, which makes trampolines for -those primitives unnecessary in case of function redefinition/advice." - :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 'natnum - :risky t - :version "28.1") - -(defcustom native-comp-async-cu-done-functions nil - "List of functions to call when asynchronous compilation of a file is done. -Each function is called with one argument FILE, the filename whose -compilation has completed." - :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-compiler-options nil "Command line options passed verbatim to GCC compiler. Note that not all options are meaningful and some options might even @@ -186,8 +98,9 @@ and above." :type '(repeat string) :version "28.1") -(defcustom native-comp-driver-options (when (eq system-type 'darwin) - '("-Wl,-w")) +(defcustom native-comp-driver-options + (cond ((eq system-type 'darwin) '("-Wl,-w")) + ((eq system-type 'cygwin) '("-Wl,-dynamicbase"))) "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. @@ -230,15 +143,6 @@ Emacs Lisp file: (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 @@ -273,324 +177,6 @@ For internal use by the test suite only.") 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) (or string null))) - (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)) (or fixnum null))) - (char-before (function (&optional (or marker integer)) (or fixnum null))) - (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 () (or cons null))) - (current-minor-mode-maps (function () (or cons null))) - (current-time (function () cons)) - (current-time-string (function (&optional (or number list) - (or symbol string cons integer)) - string)) - (current-time-zone (function (&optional (or number list) - (or symbol string cons integer)) - cons)) - (custom-variable-p (function (symbol) boolean)) - (decode-char (function (cons t) (or fixnum null))) - (decode-time (function (&optional (or number list) - (or symbol string cons integer) - 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 (or number list)) 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 (or number list) - (or symbol string cons integer)) - 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) (or window null))) - (get-lru-window (function (&optional t t t) (or window null))) - (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) (or buffer null))) - (markerp (function (t) boolean)) - (max (function ((or number marker) &rest (or number marker)) number)) - (max-char (function (&optional t) 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 () (or window null))) - (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 &optional t) t)) - (plist-member (function (list t &optional 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 t) string)) - (processp (function (t) boolean)) - (proper-list-p (function (t) boolean)) - (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) (or cons null))) - (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 ((or number list) &optional (or symbol integer)) - (or cons number))) - (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) @@ -638,13 +224,16 @@ Useful to hook into pass checkers.") finally return h) "Hash table function -> `comp-constraint'.") -(defun comp-known-predicate-p (predicate) +(defun comp--known-predicate-p (predicate) "Return t if PREDICATE is known." - (when (gethash predicate comp-known-predicates-h) t)) + (when (or (gethash predicate comp-known-predicates-h) + (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))) + t)) -(defun comp-pred-to-cstr (predicate) +(defun comp--pred-to-cstr (predicate) "Given PREDICATE, return the corresponding constraint." - (gethash predicate comp-known-predicates-h)) + (or (gethash predicate comp-known-predicates-h) + (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))) (defconst comp-symbol-values-optimizable '(most-positive-fixnum most-negative-fixnum) @@ -654,33 +243,6 @@ Useful to hook into pass checkers.") 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.") @@ -698,30 +260,6 @@ Useful to hook into pass checkers.") (defvar comp-no-spawn nil "Non-nil don't spawn native compilation processes.") -(defconst comp-warn-primitives - '(null memq gethash and subrp not subr-native-elisp-p - comp--install-trampoline concat if symbolp symbol-name make-string - length aset aref length> mapcar expand-file-name - file-name-as-directory file-exists-p native-elisp-load) - "List of primitives we want to warn about in case of redefinition. -This are essential for the trampoline machinery to work properly.") - -;; 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." - (when (memq subr-name comp-warn-primitives) - (warn "Redefining `%s' might break native compilation of trampolines." - subr-name)) - (unless (or (null native-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))) - (when-let ((trampoline (or (comp-trampoline-search subr-name) - (comp-trampoline-compile subr-name)))) - (comp--install-trampoline subr-name trampoline)))) - (cl-defstruct (comp-vec (:copier nil)) "A re-sizable vector like object." @@ -892,7 +430,7 @@ non local exit (ends with an `unreachable' insn).")) (:include comp-block)) "A basic block holding only constraints.") -(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) +(cl-defstruct (comp-edge (:copier nil) (:constructor comp--edge-make0)) "An edge connecting two basic blocks." (src nil :type (or null comp-block)) (dst nil :type (or null comp-block)) @@ -900,19 +438,19 @@ non local exit (ends with an `unreachable' insn).")) :documentation "The index number corresponding to this edge in the edge hash.")) -(defun make-comp-edge (&rest args) +(defun comp--edge-make (&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) + (apply #'comp--edge-make0 :number n args) (comp-func-edges-h comp-func)))) -(defun comp-block-preds (basic-block) +(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 () +(defun comp--gen-counter () "Return a sequential number generator." (let ((n -1)) (lambda () @@ -946,9 +484,9 @@ CFG is mutated by a pass.") :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 + (block-cnt-gen (funcall #'comp--gen-counter) :type function :documentation "Generates block numbers.") - (edge-cnt-gen (funcall #'comp-gen-counter) :type function + (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.") @@ -987,49 +525,39 @@ In use by the back-end." -(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) +(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) +(defun comp--arithm-cmp-fun-p (function) "Predicate for arithmetic comparison functions." (when (memq function '(= > < >= <=)) t)) -(defun comp-set-op-p (op) +(defun comp--set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) -(defun comp-assign-op-p (op) +(defun comp--assign-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-assignments) t)) -(defun comp-call-op-p (op) +(defun comp--call-op-p (op) "Call predicate for OP." (when (memq op comp-limple-calls) t)) -(defun comp-branch-op-p (op) +(defun comp--branch-op-p (op) "Branch predicate for OP." (when (memq op comp-limple-branches) t)) -(defsubst comp-limple-insn-call-p (insn) +(defsubst comp--limple-insn-call-p (insn) "Limple INSN call predicate." - (comp-call-op-p (car-safe insn))) + (comp--call-op-p (car-safe insn))) -(defun comp-type-hint-p (func) +(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) +(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) @@ -1041,110 +569,46 @@ To be used by all entry points." finally return t) t)) -(defsubst comp-symbol-func-to-fun (symbol-funcion) +(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) +(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))) + (when-let ((func (comp--symbol-func-to-fun f))) (comp-func-pure func)))) -(defun comp-alloc-class-to-container (alloc-class) +(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) +(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 + (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) +(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) +(defun comp--prettyformat-insn (insn) (cond ((comp-mvar-p insn) - (comp-prettyformat-mvar insn)) + (comp--prettyformat-mvar insn)) ((proper-list-p insn) - (concat "(" (mapconcat #'comp-prettyformat-insn insn " ") ")")) + (concat "(" (mapconcat #'comp--prettyformat-insn insn " ") ")")) (t (prin1-to-string insn)))) -(defun comp-log-func (func verbosity) +(defun comp--log-func (func verbosity) "Log function FUNC at VERBOSITY. VERBOSITY is a number between 0 and 3." (when (>= native-comp-verbose verbosity) @@ -1155,9 +619,9 @@ VERBOSITY is a number between 0 and 3." 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))))) + do (comp-log (comp--prettyformat-insn insn) verbosity))))) -(defun comp-log-edges (func) +(defun comp--log-edges (func) "Log edges in FUNC." (let ((edges (comp-func-edges-h func))) (comp-log (format "\nEdges in function: %s\n" @@ -1241,7 +705,7 @@ clashes." (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)) + (signal 'native-compiler-error-dyn-func (list function-name))) (let ((rest (not (= (logand x 128) 0))) (mandatory (logand x 127)) (nonrest (ash x -8))) @@ -1274,75 +738,32 @@ clashes." (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) - :command-modes (command-modes f) - :speed (comp-spill-speed function-name) - :pure (comp-spill-decl-spec function-name - 'pure)))) + (byte-code (byte-compile function-name)) + (c-name (comp-c-func-name function-name "F"))) (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)))) + '("can't native compile an already byte-compiled function"))) (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)))) + :c-name c-name + :byte-func byte-code))) + (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))) (cl-defmethod comp-spill-lap-function ((form list)) "Byte-compile FORM, spilling data from the byte compiler." - (unless (eq (car-safe form) 'lambda) + (unless (memq (car-safe form) '(lambda closure)) (signal 'native-compiler-error - "Cannot native-compile, form is not a lambda")) + '("Cannot native-compile, form is not a lambda or closure"))) (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) - :command-modes (command-modes form) - :speed (comp-ctxt-speed comp-ctxt)) - (make-comp-func-d :c-name c-name - :doc (documentation form t) - :int-spec (interactive-form form) - :command-modes (command-modes 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) + (c-name (comp-c-func-name "anonymous-lambda" "F"))) + (setf (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)))) + :c-name c-name + :byte-func byte-code))) + (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))) (defun comp-intern-func-in-ctxt (_ obj) "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'." @@ -1390,7 +811,7 @@ clashes." (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)) + (signal 'native-compiler-error-empty-byte (list filename))) (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) (comp-el-to-eln-filename filename native-compile-target-directory))) @@ -1424,11 +845,13 @@ clashes." "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))) + (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 ()) + (res (comp-spill-lap-function input))) + (comp-cstr-ctxt-update-type-slots comp-ctxt) + res)) ;;; Limplification pass specific code. @@ -1536,14 +959,16 @@ STACK-OFF is the index of the first slot frame involved." for sp from stack-off collect (comp-slot-n sp)))) -(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) +(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type neg) "`comp-mvar' initializer." (let ((mvar (make--comp-mvar :slot slot))) (when const-vld - (comp-add-const-to-relocs constant) + (comp--add-const-to-relocs constant) (setf (comp-cstr-imm mvar) constant)) (when type (setf (comp-mvar-typeset mvar) (list type))) + (when neg + (setf (comp-mvar-neg mvar) t)) mvar)) (defun comp-new-frame (size vsize &optional ssa) @@ -1583,7 +1008,7 @@ If DST-N is specified, use it; otherwise assume it to be the current slot." (defsubst comp-emit-setimm (val) "Set constant VAL to current slot." - (comp-add-const-to-relocs val) + (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))) @@ -1708,14 +1133,15 @@ Return value is the fall-through block name." (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)) + ;; Identify LAP sequences like: + ;; (byte-constant #s(hash-table size 3 test eq rehash-size 1.5 rehash-threshold 0.8125 purecopy t data (created 126 deleted 126 changed 126)) . 24) + ;; (byte-switch) + ;; (TAG 126 . 10) + (let ((targets (hash-table-values jmp-table))) + (when (apply #'= targets) + (pcase (nth (1+ (comp-limplify-pc comp-pass)) (comp-func-lap comp-func)) + (`(TAG ,target . ,_label-sp) + (= target (car targets))))))) (defun comp-emit-switch (var last-insn) "Emit a Limple for a lap jump table given VAR and LAST-INSN." @@ -1758,7 +1184,7 @@ Return value is the fall-through block name." 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")))) + '("missing previous setimm while creating a switch"))))) (defun comp--func-arity (subr-name) "Like `func-arity' but invariant against primitive redefinitions. @@ -1790,7 +1216,7 @@ SP-DELTA is the stack adjustment." (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))) + (intern (string-replace "byte-" "" x))) (defun comp-body-eff (body op-name sp-delta) "Given the original BODY, compute the effective one. @@ -2070,7 +1496,7 @@ and the annotation emission." (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) + (comp--log-func func 2) func) (cl-defgeneric comp-prepare-args-for-top-level (function) @@ -2144,7 +1570,7 @@ and the annotation emission." 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--add-const-to-relocs (comp-func-byte-func func))) (comp-emit (comp-call 'comp--register-lambda ;; mvar to be fixed-up when containers are @@ -2347,7 +1773,7 @@ into the C code forwarding the compilation unit." do (cl-loop for insn in (comp-block-insns b) for (op . args) = insn - if (comp-assign-op-p op) + if (comp--assign-op-p op) do (comp-collect-mvars (cdr args)) else do (comp-collect-mvars args)))) @@ -2396,7 +1822,7 @@ The assume is emitted at the beginning of the block BB." (comp-cstr-negation-make rhs) rhs))) (comp-block-insns bb)))) - ((pred comp-arithm-cmp-fun-p) + ((pred comp--arithm-cmp-fun-p) (when-let ((kind (if negated (comp-negate-arithm-cmp-fun kind) kind))) @@ -2429,7 +1855,7 @@ Return OP otherwise." (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) + with new-edge = (comp--edge-make :src bb-a :dst new-bb) for ed in (comp-block-in-edges bb-b) when (eq (comp-edge-src ed) bb-a) do @@ -2460,7 +1886,7 @@ Keep on searching till EXIT-INSN is encountered." 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) + (`(,(pred comp--assign-op-p) ,(pred targetp) ,rhs) (setf res rhs))) finally (cl-assert nil)))) @@ -2532,10 +1958,27 @@ TARGET-BB-SYM is the symbol name of the target block." for insns-seq on (comp-block-insns b) do (pcase insns-seq + (`((set ,(and (pred comp-mvar-p) mvar-tested-copy) + ,(and (pred comp-mvar-p) mvar-tested)) + (set ,(and (pred comp-mvar-p) mvar-1) + (call type-of ,(and (pred comp-mvar-p) mvar-tested-copy))) + (set ,(and (pred comp-mvar-p) mvar-2) + (call symbol-value ,(and (pred comp-cstr-cl-tag-p) mvar-tag))) + (set ,(and (pred comp-mvar-p) mvar-3) + (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2))) + (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2)) + (comp-emit-assume 'and mvar-tested + (make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)) + (comp-add-cond-cstrs-target-block b bb2) + nil) + (comp-emit-assume 'and mvar-tested + (make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)) + (comp-add-cond-cstrs-target-block b bb1) + t)) (`((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)) + (,(pred comp--call-op-p) + ,(and (or (pred comp--equality-fun-p) + (pred comp--arithm-cmp-fun-p)) fun) ,op1 ,op2)) ;; (comment ,_comment-str) @@ -2567,14 +2010,14 @@ TARGET-BB-SYM is the symbol name of the target block." 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) + (,(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) + 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) @@ -2586,14 +2029,14 @@ TARGET-BB-SYM is the symbol name of the target block." 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) + (,(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) + 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) @@ -2645,10 +2088,10 @@ TARGET-BB-SYM is the symbol name of the target block." (comp-loop-insn-in-block bb (when-let ((match (pcase insn - (`(set ,lhs (,(pred comp-call-op-p) ,f . ,args)) + (`(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) + (`(,(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 @@ -2687,7 +2130,7 @@ blocks." (comp-add-cond-cstrs-simple) (comp-add-cond-cstrs) (comp-add-call-cstr) - (comp-log-func comp-func 3)))) + (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2706,9 +2149,9 @@ blocks." do (cl-loop for insn in (comp-block-insns b) do (pcase insn - (`(set ,_lval (,(pred comp-call-op-p) ,f . ,_rest)) + (`(set ,_lval (,(pred comp--call-op-p) ,f . ,_rest)) (puthash f t h)) - (`(,(pred comp-call-op-p) ,f . ,_rest) + (`(,(pred comp--call-op-p) ,f . ,_rest) (puthash f t h)))) finally return (cl-loop for f being each hash-key of h @@ -2721,7 +2164,7 @@ blocks." (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) + (or (comp--function-pure-p x) (eq x (comp-func-name f)))) (comp-collect-calls f)) (not (eq (comp-func-pure f) t))) @@ -2785,16 +2228,16 @@ blocks." for (op first second third forth) = last-insn do (cl-case op (jump - (make-comp-edge :src bb :dst (gethash first blocks))) + (comp--edge-make :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))) + (comp--edge-make :src bb :dst (gethash third blocks)) + (comp--edge-make :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))) + (comp--edge-make :src bb :dst (gethash second blocks)) + (comp--edge-make :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))) + (comp--edge-make :src bb :dst (gethash third blocks)) + (comp--edge-make :src bb :dst (gethash forth blocks))) (return) (unreachable) (otherwise @@ -2811,7 +2254,7 @@ blocks." (comp-block-out-edges (comp-edge-src edge))) (push edge (comp-block-in-edges (comp-edge-dst edge)))) - (comp-log-edges comp-func))) + (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." @@ -2844,9 +2287,9 @@ blocks." finger2 (comp-block-post-num b2)))) b1)) (first-processed (l) - (if-let ((p (cl-find-if (lambda (p) (comp-block-idom p)) l))) + (if-let ((p (cl-find-if #'comp-block-idom l))) p - (signal 'native-ice "can't find first preprocessed")))) + (signal 'native-ice '("can't find first preprocessed"))))) (when-let ((blocks (comp-func-blocks comp-func)) (entry (gethash 'entry blocks)) @@ -2867,7 +2310,7 @@ blocks." do (cl-loop for name in (cdr rev-bb-list) for b = (gethash name blocks) - for preds = (comp-block-preds b) + 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) @@ -2887,7 +2330,7 @@ blocks." (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) + for preds = (comp--block-preds b) when (length> preds 1) ; All joins do (cl-loop for p in preds for runner = p @@ -2919,7 +2362,7 @@ blocks." ;; 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) + 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!!! @@ -2985,7 +2428,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (setf (comp-vec-aref frame slot-n) mvar (cadr insn) mvar)))) (pcase insn - (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) + (`(,(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)) @@ -3072,7 +2515,7 @@ Return t when one or more block was removed, nil otherwise." (comp-place-phis) (comp-ssa-rename) (comp-finalize-phis) - (comp-log-func comp-func 3) + (comp--log-func comp-func 3) (setf (comp-func-ssa-status f) t)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -3135,7 +2578,7 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or (defun comp-function-foldable-p (f args) "Given function F called with ARGS, return non-nil when optimizable." - (and (comp-function-pure-p f) + (and (comp--function-pure-p f) (cl-every #'comp-cstr-imm-vld-p args))) (defun comp-function-call-maybe-fold (insn f args) @@ -3143,7 +2586,7 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or 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) + (comp--add-const-to-relocs value) (setf (car insn) 'setimm (cddr insn) `(,value)))) (cond @@ -3160,7 +2603,7 @@ Return non-nil if the function is folded successfully." ;; 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)) + (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) @@ -3187,7 +2630,11 @@ Fold the call in case." (+ (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)))))) + (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one))) + (record (when (comp-cstr-imm-vld-p (car args)) + (comp-cstr-shallow-copy lval + (comp-type-spec-to-cstr + (comp-cstr-imm (car args))))))))) (defun comp-fwprop-insn (insn) "Propagate within INSN." @@ -3202,6 +2649,8 @@ Fold the call in case." (_ (comp-cstr-shallow-copy lval rval)))) (`(assume ,lval ,(and (pred comp-mvar-p) rval)) + ;; NOTE we should probably assert this case in the future when + ;; will be possible. (comp-cstr-shallow-copy lval rval)) (`(assume ,lval (,kind . ,operands)) (cl-case kind @@ -3233,7 +2682,7 @@ Fold the call in case." (comp-func-blocks comp-func)))) (or (comp-latch-p bb) (when (comp-block-cstr-p bb) - (comp-latch-p (car (comp-block-preds bb))))))) + (comp-latch-p (car (comp--block-preds bb))))))) rest)) (prop-fn (if from-latch #'comp-cstr-union-no-range @@ -3300,7 +2749,7 @@ Return t if something was changed." (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--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -3323,7 +2772,7 @@ Return t if something was changed." "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) + (comp--symbol-func-to-fun func) (cl-assert (byte-code-function-p func)) (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt)))) @@ -3340,6 +2789,14 @@ FUNCTION can be a function-name or byte compiled function." (symbol-function callee) (cl-assert (byte-code-function-p callee)) callee)) + ;; Below call to `subrp' returns nil on an advised + ;; primitive F, so that we do not optimize calls to F + ;; with the funcall trampoline removal below. But if F + ;; is advised while we compile its call, it is very + ;; likely to be advised also when that call is executed. + ;; And in that case an "unoptimized" call to F is + ;; actually cheaper since it avoids the call to the + ;; intermediate native trampoline (bug#67005). (subrp (subrp f)) (comp-func-callee (comp-func-in-unit callee))) (cond @@ -3361,7 +2818,7 @@ FUNCTION can be a function-name or byte compiled function." ((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)) + (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. @@ -3373,7 +2830,7 @@ FUNCTION can be a function-name or byte compiled function." args (fill-args args (comp-args-max func-args))))) `(,call-type ,(comp-func-c-name comp-func-callee) ,@args))) - ((comp-type-hint-p callee) + ((comp--type-hint-p callee) `(call ,callee ,@args))))))) (defun comp-call-optim-func () @@ -3430,7 +2887,7 @@ Return the list of m-var ids nuked." do (cl-loop for insn in (comp-block-insns b) for (op arg0 . rest) = insn - if (comp-assign-op-p op) + 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 @@ -3448,10 +2905,10 @@ Return the list of m-var ids nuked." 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) + (when (and (comp--assign-op-p op) (memq (comp-mvar-id arg0) nuke-list)) (setf insn - (if (comp-limple-insn-call-p arg1) + (if (comp--limple-insn-call-p arg1) arg1 `(comment ,(format "optimized out: %s" insn)))))))) @@ -3468,7 +2925,7 @@ Return the list of m-var ids nuked." 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--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -3508,7 +2965,7 @@ Return the list of m-var ids nuked." (not (comp-func-has-non-local f))) (let ((comp-func f)) (comp-tco-func) - (comp-log-func comp-func 3)))) + (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -3524,7 +2981,7 @@ These are substituted with a normal `set' op." 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)) + (`(set ,l-val (call ,(pred comp--type-hint-p) ,r-val)) (setf insn `(set ,l-val ,r-val))))))) (defun comp-remove-type-hints (_) @@ -3533,7 +2990,7 @@ These are substituted with a normal `set' op." (when (>= (comp-func-speed f) 2) (let ((comp-func f)) (comp-remove-type-hints-func) - (comp-log-func comp-func 3)))) + (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -3586,7 +3043,7 @@ Set it into the `type' slot." 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) + (comp--add-const-to-relocs type) ;; Fix it up. (setf (comp-cstr-imm (comp-func-type func)) type)))) @@ -3615,7 +3072,7 @@ 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 symbol-with-pos-p)) + (mapc #'comp--add-const-to-relocs '(nil t consp listp symbol-with-pos-p)) (let* ((d-default (comp-ctxt-d-default comp-ctxt)) (d-default-idx (comp-data-container-idx d-default)) @@ -3670,7 +3127,7 @@ 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--log-func f 1)) (comp-ctxt-funcs-h comp-ctxt)) (unless (file-exists-p dir) ;; In case it's created in the meanwhile. @@ -3679,13 +3136,10 @@ Prepare every function for final compilation and drive the C back-end." (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)))) + (comp--init-ctxt) + (unwind-protect + (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt)) + (comp--release-ctxt))) (defvar comp-async-compilation nil "Non-nil while executing an asynchronous native compilation.") @@ -3746,7 +3200,7 @@ Prepare every function for final compilation and drive the C back-end." (progn (delete-file temp-file) output) - (signal 'native-compiler-error (buffer-string))) + (signal 'native-compiler-error (list (buffer-string)))) (comp-log-to-buffer (buffer-string)))))))) @@ -3769,19 +3223,6 @@ Prepare every function for final compilation and drive the C back-end." ;; 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)) @@ -3797,16 +3238,6 @@ Account for `native-comp-eln-load-path' and `comp-native-version-dir'." (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-abs-filename (subr-name) "Return the absolute filename for a trampoline for SUBR-NAME." (cl-loop @@ -3832,6 +3263,8 @@ Return the trampoline if found or nil otherwise." (make-temp-file (file-name-sans-extension rel-filename) nil ".eln" nil)))) +;; Called from comp-run.el +;;;###autoload (defun comp-trampoline-compile (subr-name) "Synthesize compile and return a trampoline for SUBR-NAME." (let* ((lambda-list (comp-make-lambda-list-from-subr @@ -3906,174 +3339,9 @@ session." ;; 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)) - -(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 - (max 1 (/ (num-processors) 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." - (cl-assert (null comp-no-spawn)) - (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. - ;; Skip compilation if `comp-el-to-eln-filename' fails - ;; to find a writable directory. - (with-demoted-errors "Async compilation :%S" - (file-newer-than-file-p - source-file (comp-el-to-eln-filename source-file)))) - do (let* ((expr `((require 'comp) - (setq comp-async-compilation t - warning-fill-column most-positive-fixnum) - ,(let ((set (list 'setq))) - (dolist (var '(comp-file-preloaded-p - native-compile-target-directory - native-comp-speed - native-comp-debug - native-comp-verbose - comp-libgccjit-reproducer - native-comp-eln-load-path - native-comp-compiler-options - native-comp-driver-options - load-path - backtrace-line-length - byte-compile-warnings - ;; package-load-list - ;; package-user-dir - ;; package-directory-list - )) - (when (boundp var) - (push var set) - (push `',(symbol-value var) set))) - (nreverse set)) - ;; FIXME: Activating all packages would align the - ;; functionality offered with what is usually done - ;; for ELPA packages (and thus fix some compilation - ;; issues with some ELPA packages), but it's too - ;; blunt an instrument (e.g. we don't even know if - ;; we're compiling such an ELPA package at - ;; this point). - ;;(package-activate-all) - ,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) - (default-directory invocation-directory) - (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) - "-no-comp-spawn" "-Q" "--batch" - "--eval" - ;; Suppress Abort dialogs on MS-Windows - "(setq w32-disable-abort-dialog t)" - "-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 ((inhibit-read-only t)) - (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))) + (t (if newfile + (rename-file newfile oldfile t) + (delete-file oldfile))))) (defun comp--native-compile (function-or-file &optional with-late-load output) "Compile FUNCTION-OR-FILE into native code. @@ -4102,14 +3370,14 @@ the deferred compilation mechanism." (comp-log "\n \n" 1) (unwind-protect (progn - (condition-case err + (condition-case-unless-debug 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" + (comp-log (format "\n(%s) Running pass %s:\n" function-or-file pass) 2) (setf data (funcall pass data)) @@ -4121,7 +3389,8 @@ the deferred compilation mechanism." (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)))) + pass time) + 0)))) (native-compiler-skip) (t (let ((err-val (cdr err))) @@ -4156,100 +3425,6 @@ the deferred compilation mechanism." (ignore-errors (delete-file (comp-ctxt-output comp-ctxt)))) (t (delete-file (comp-ctxt-output comp-ctxt)))))))))) -(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) - (gethash (file-name-with-extension file "elc") comp--no-native-compile) - (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-jit-compilation-deny-list' matches. - (and (eq load 'late) - (cl-some (lambda (re) - (string-match-p re file)) - native-comp-jit-compilation-deny-list)))) - -(defun native--compile-async (files &optional recursively load selector) - ;; BEWARE, this function is also called directly from C. - "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 ((added-something nil) - file-list) - (dolist (file-or-dir files) - (cond ((file-directory-p file-or-dir) - (dolist (file (if recursively - (directory-files-recursively - file-or-dir comp-valid-source-re) - (directory-files file-or-dir - t comp-valid-source-re))) - (push file file-list))) - ((file-exists-p file-or-dir) (push file-or-dir file-list)) - (t (signal 'native-compiler-error - (list "Not a file nor directory" file-or-dir))))) - (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))) - added-something t) - (display-warning 'comp - (format "No write access for %s skipping." - out-filename))))))) - ;; Perhaps nothing passed `native-compile-async-skip-p'? - (when (and added-something - ;; Don't start if there's one already running. - (zerop (comp-async-runnings))) - (comp-run-async-workers)))) - ;;; Compiler entry points. @@ -4357,29 +3532,6 @@ variable \"NATIVE_DISABLED\" is set, only byte compile." (comp-write-bytecode-file eln-file) (setq command-line-args-left (cdr command-line-args-left))))) -;;;###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))) - (defun native-compile-prune-cache () "Remove .eln files that aren't applicable to the current Emacs invocation." (interactive) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 5411088189d..e0b6ca31b9e 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -237,12 +237,11 @@ the debugger will not be entered." (unwind-protect (save-excursion (when (eq (car debugger-args) 'debug) - ;; Skip the frames for backtrace-debug, byte-code, - ;; debug--implement-debug-on-entry and the advice's `apply'. - (backtrace-debug 4 t) - ;; Place an extra debug-on-exit for macro's. - (when (eq 'lambda (car-safe (cadr (backtrace-frame 4)))) - (backtrace-debug 5 t))) + (let ((base (debugger--backtrace-base))) + (backtrace-debug 1 t base) ;FIXME! + ;; Place an extra debug-on-exit for macro's. + (when (eq 'lambda (car-safe (cadr (backtrace-frame 1 base)))) + (backtrace-debug 2 t base)))) (with-current-buffer debugger-buffer (unless (derived-mode-p 'debugger-mode) (debugger-mode)) @@ -343,11 +342,10 @@ Make functions into cross-reference buttons if DO-XREFS is non-nil." (defun debugger-setup-buffer (args) "Initialize the `*Backtrace*' buffer for entry to the debugger. That buffer should be current already and in `debugger-mode'." - (setq backtrace-frames (nthcdr - ;; Remove debug--implement-debug-on-entry and the - ;; advice's `apply' frame. - (if (eq (car args) 'debug) 3 1) - (backtrace-get-frames 'debug))) + (setq backtrace-frames + ;; The `base' frame is the one that gets index 0 and it is the entry to + ;; the debugger, so drop it with `cdr'. + (cdr (backtrace-get-frames (debugger--backtrace-base)))) (when (eq (car-safe args) 'exit) (setq debugger-value (nth 1 args)) (setf (cl-getf (backtrace-frame-flags (car backtrace-frames)) @@ -477,26 +475,29 @@ removes itself from that hook." (setq debugger-jumping-flag nil) (remove-hook 'post-command-hook 'debugger-reenable)) -(defun debugger-frame-number (&optional skip-base) +(defun debugger-frame-number () "Return number of frames in backtrace before the one point points at." - (let ((index (backtrace-get-index)) - (count 0)) + (let ((index (backtrace-get-index))) (unless index (error "This line is not a function call")) - (unless skip-base - (while (not (eq (cadr (backtrace-frame count)) 'debug)) - (setq count (1+ count))) - ;; Skip debug--implement-debug-on-entry frame. - (when (eq 'debug--implement-debug-on-entry - (cadr (backtrace-frame (1+ count)))) - (setq count (+ 2 count)))) - (+ count index))) + ;; We have 3 representations of the backtrace: the real in C in `specpdl', + ;; the one stored in `backtrace-frames' and the textual version in + ;; the buffer. Check here that the one from `backtrace-frames' is in sync + ;; with the one from `specpdl'. + (cl-assert (equal (backtrace-frame-fun (nth index backtrace-frames)) + (nth 1 (backtrace-frame (1+ index) + (debugger--backtrace-base))))) + ;; The `base' frame is the one that gets index 0 and it is the entry to + ;; the debugger, so the first non-debugger frame is 1. + ;; This `+1' skips the same frame as the `cdr' in + ;; `debugger-setup-buffer'. + (1+ index))) (defun debugger-frame () "Request entry to debugger when this frame exits. Applies to the frame whose line point is on in the backtrace." (interactive) - (backtrace-debug (debugger-frame-number) t) + (backtrace-debug (debugger-frame-number) t (debugger--backtrace-base)) (setf (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames)) :debug-on-exit) @@ -507,7 +508,7 @@ Applies to the frame whose line point is on in the backtrace." "Do not enter debugger when this frame exits. Applies to the frame whose line point is on in the backtrace." (interactive) - (backtrace-debug (debugger-frame-number) nil) + (backtrace-debug (debugger-frame-number) nil (debugger--backtrace-base)) (setf (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames)) :debug-on-exit) @@ -526,10 +527,8 @@ Applies to the frame whose line point is on in the backtrace." (defun debugger--backtrace-base () "Return the function name that marks the top of the backtrace. See `backtrace-frame'." - (cond ((eq 'debug--implement-debug-on-entry - (cadr (backtrace-frame 1 'debug))) - 'debug--implement-debug-on-entry) - (t 'debug))) + (or (cadr (memq :backtrace-base debugger-args)) + #'debug)) (defun debugger-eval-expression (exp &optional nframe) "Eval an expression, in an environment like that outside the debugger. @@ -537,7 +536,7 @@ The environment used is the one when entering the activation frame at point." (interactive (list (read--expression "Eval in stack frame: "))) (let ((nframe (or nframe - (condition-case nil (1+ (debugger-frame-number 'skip-base)) + (condition-case nil (debugger-frame-number) (error 0)))) ;; If on first line. (base (debugger--backtrace-base))) (debugger-env-macro @@ -670,7 +669,10 @@ functions to break on entry." (if (or inhibit-debug-on-entry debugger-jumping-flag) nil (let ((inhibit-debug-on-entry t)) - (funcall debugger 'debug)))) + (funcall debugger 'debug :backtrace-base + ;; An offset of 1 because we need to skip the advice + ;; OClosure that called us. + '(1 . debug--implement-debug-on-entry))))) ;;;###autoload (defun debug-on-entry (function) diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index b35994364a7..dec5883767d 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -240,7 +240,9 @@ No problems result if this variable is not bound. (unless (get ',abbrev 'variable-documentation) (put ',abbrev 'variable-documentation (purecopy ,(format "Abbrev table for `%s'." child)))))) - (put ',child 'derived-mode-parent ',parent) + (if (fboundp 'derived-mode-set-parent) ;; Emacs≥30.1 + (derived-mode-set-parent ',child ',parent) + (put ',child 'derived-mode-parent ',parent)) ,(if group `(put ',child 'custom-mode-group ,group)) (defun ,child () diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index f9f7448d81c..d9295686e9f 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -63,16 +63,19 @@ redefine OBJECT if it is a symbol." (list (intern (completing-read (format-prompt "Disassemble function" fn) obarray 'fboundp t nil nil def)) nil 0 t))) - (if (and (consp object) (not (functionp object))) - (setq object `(lambda () ,object))) - (or indent (setq indent 0)) ;Default indent to zero - (save-excursion - (if (or interactive-p (null buffer)) - (with-output-to-temp-buffer "*Disassemble*" - (set-buffer "*Disassemble*") - (disassemble-internal object indent (not interactive-p))) - (set-buffer buffer) - (disassemble-internal object indent nil))) + (let ((lb lexical-binding)) + (if (and (consp object) (not (functionp object))) + (setq object `(lambda () ,object))) + (or indent (setq indent 0)) ;Default indent to zero + (save-excursion + (if (or interactive-p (null buffer)) + (with-output-to-temp-buffer "*Disassemble*" + (set-buffer "*Disassemble*") + (let ((lexical-binding lb)) + (disassemble-internal object indent (not interactive-p)))) + (set-buffer buffer) + (let ((lexical-binding lb)) + (disassemble-internal object indent nil))))) nil) (declare-function native-comp-unit-file "data.c") @@ -298,6 +301,23 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (insert "\n"))))) nil) +(defun re-disassemble (regexp &optional case-table) + "Describe the compiled form of REGEXP in a separate window. +If CASE-TABLE is non-nil, use it as translation table for case-folding. + +This function is mainly intended for maintenance of Emacs itself +and may change at any time. It requires Emacs to be built with +`--enable-checking'." + (interactive "XRegexp (Lisp expression): ") + (let ((desc (with-temp-buffer + (when case-table + (set-case-table case-table)) + (let ((case-fold-search (and case-table t))) + (re--describe-compiled regexp))))) + (with-output-to-temp-buffer "*Regexp-disassemble*" + (with-current-buffer standard-output + (insert desc))))) + (provide 'disass) ;;; disass.el ends here diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 98c211325ab..c9e7b3a4dfe 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -143,8 +143,6 @@ it is disabled.") (buffer-string))))) ;;;###autoload -(defalias 'easy-mmode-define-minor-mode #'define-minor-mode) -;;;###autoload (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 @@ -250,7 +248,8 @@ INIT-VALUE LIGHTER KEYMAP. (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'" + (format-message + "Use keywords rather than deprecated positional arguments to `define-minor-mode'") exp)))) keyw keymap-sym tmp) @@ -417,6 +416,8 @@ No problems result if this variable is not bound. `(defvar ,keymap-sym (let ((m ,keymap)) (cond ((keymapp m) m) + ;; FIXME: `easy-mmode-define-keymap' is obsolete, + ;; so this form should also be obsolete somehow. ((listp m) (with-suppressed-warnings ((obsolete easy-mmode-define-keymap)) @@ -440,8 +441,6 @@ No problems result if this variable is not bound. ;;; ;;;###autoload -(defalias 'easy-mmode-define-global-mode #'define-globalized-minor-mode) -;;;###autoload (defalias 'define-global-minor-mode #'define-globalized-minor-mode) ;;;###autoload (defmacro define-globalized-minor-mode (global-mode mode turn-on &rest body) @@ -662,7 +661,7 @@ list." (throw 'found nil)) ((and (consp elem) (eq (car elem) 'not)) - (when (apply #'derived-mode-p (cdr elem)) + (when (derived-mode-p (cdr elem)) (throw 'found nil))) ((symbolp elem) (when (derived-mode-p elem) @@ -693,6 +692,7 @@ Valid keywords and arguments are: :group Ignored. :suppress Non-nil to call `suppress-keymap' on keymap, `nodigits' to suppress digits as prefix arguments." + (declare (obsolete define-keymap "29.1")) (let (inherit dense suppress) (while args (let ((key (pop args)) @@ -733,9 +733,7 @@ The M, BS, and ARGS arguments are as per that function. DOC is the constant's documentation. This macro is deprecated; use `defvar-keymap' instead." - ;; FIXME: Declare obsolete in favor of `defvar-keymap'. It is still - ;; used for `gud-menu-map' and `gud-minor-mode-map', so fix that first. - (declare (doc-string 3) (indent 1)) + (declare (doc-string 3) (indent 1) (obsolete defvar-keymap "29.1")) `(defconst ,m (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args)) ,doc)) @@ -839,6 +837,12 @@ Interactively, COUNT is the prefix numeric argument, and defaults to 1." ,@body)) (put ',prev-sym 'definition-name ',base)))) +;; When deleting these two, also delete them from loaddefs-gen.el. +;;;###autoload +(define-obsolete-function-alias 'easy-mmode-define-minor-mode #'define-minor-mode "30.1") +;;;###autoload +(define-obsolete-function-alias 'easy-mmode-define-global-mode #'define-globalized-minor-mode "30.1") + (provide 'easy-mmode) ;;; easy-mmode.el ends here diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 2f7d03e9d79..aa68978f6d6 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1225,8 +1225,10 @@ purpose by adding an entry to this alist, and setting ;; But the list will just be reversed. ,@(nreverse edebug-def-args)) 'nil) - (function (lambda () ,@forms)) - )) + ;; Make sure `forms' is not nil so we don't accidentally return + ;; the magic keyword. Mark the closure so we don't throw away + ;; unused vars (bug#59213). + #'(lambda () :closure-dont-trim-context ,@(or forms '(nil))))) (defvar edebug-form-begin-marker) ; the mark for def being instrumented @@ -1542,9 +1544,7 @@ contains a circular object." (defun edebug-list-form (cursor) ;; Return an instrumented form built from the list form. ;; 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)) + (let ((head (edebug-top-element-required cursor "Expected elements"))) ;; Skip the first offset. (edebug-set-cursor cursor (edebug-cursor-expressions cursor) (cdr (edebug-cursor-offsets cursor))) @@ -2467,12 +2467,52 @@ MSG is printed after `::::} '." (setf (cdr (assq 'edebug edebug-behavior-alist)) '(edebug-default-enter edebug-fast-before edebug-fast-after))) -(defalias 'edebug-before nil +;; The following versions of `edebug-before' and `edebug-after' exist +;; to handle the error which occurs if either of them gets called +;; without an enclosing `edebug-enter'. This can happen, for example, +;; when a macro mistakenly has a `form' element in its edebug spec, +;; and it additionally, at macro-expansion time, calls `eval', +;; `apply', or `funcall' (etc.) on the corresponding argument. This +;; is intended to fix bug#65620. + +(defun edebug-b/a-error (func) + "Throw an error for an invalid call of FUNC. +FUNC is expected to be `edebug-before' or `edebug-after'." + (let (this-macro + (n 0) + bt-frame) + (while (and (setq bt-frame (backtrace-frame n)) + (not (and (car bt-frame) + (memq (cadr bt-frame) + '(macroexpand macroexpand-1))))) + (setq n (1+ n))) + (when bt-frame + (setq this-macro (caaddr bt-frame))) + + (error + (concat "Invalid call to `" (symbol-name func) "'" + (if this-macro + (concat ". Is the edebug spec for `" + (symbol-name this-macro) + "' correct?") + "" ; Not sure this case is possible (ACM, 2023-09-02) + ))))) + +(defun edebug-before (_before-index) "Function called by Edebug before a form is evaluated. -See `edebug-behavior-alist' for implementations.") -(defalias 'edebug-after nil +See `edebug-behavior-alist' for other implementations. This +version of `edebug-before' gets called when edebug is not yet set +up. `edebug-enter' binds the function cell to a real function +when edebug becomes active." + (edebug-b/a-error 'edebug-before)) + +(defun edebug-after (_before-index _after-index _form) "Function called by Edebug after a form is evaluated. -See `edebug-behavior-alist' for implementations.") +See `edebug-behavior-alist' for other implementations. This +version of `edebug-after' gets called when edebug is not yet set +up. `edebug-enter' binds the function cell to a real function +when edebug becomes active." + (edebug-b/a-error 'edebug-after)) (defun edebug--update-coverage (after-index value) (let ((old-result (aref edebug-coverage after-index))) @@ -2851,81 +2891,81 @@ See `edebug-behavior-alist' for implementations.") edebug-inside-windows ) - (unwind-protect - (let ( - ;; Declare global values local but using the same global value. - ;; We could set these to the values for previous edebug call. - (last-command last-command) - (this-command this-command) - (current-prefix-arg nil) - - (last-input-event nil) - (last-command-event nil) - (last-event-frame nil) - (last-nonmenu-event nil) - (track-mouse nil) - - (standard-output t) - (standard-input t) - - ;; Don't keep reading from an executing kbd macro - ;; within edebug unless edebug-continue-kbd-macro is - ;; non-nil. Again, local binding may not be best. - (executing-kbd-macro - (if edebug-continue-kbd-macro executing-kbd-macro)) - - ;; Don't get confused by the user's keymap changes. - (overriding-local-map nil) - (overriding-terminal-local-map nil) - ;; Override other minor modes that may bind the keys - ;; edebug uses. - (minor-mode-overriding-map-alist - (list (cons 'edebug-mode edebug-mode-map))) - - ;; Bind again to outside values. - (debug-on-error edebug-outside-debug-on-error) - (debug-on-quit edebug-outside-debug-on-quit) - - ;; Don't keep defining a kbd macro. - (defining-kbd-macro - (if edebug-continue-kbd-macro defining-kbd-macro)) - - ;; others?? - ) - (if (and (eq edebug-execution-mode 'go) - (not (memq arg-mode '(after error)))) - (message "Break")) - - (setq signal-hook-function nil) - - (edebug-mode 1) - (unwind-protect - (recursive-edit) ; <<<<<<<<<< Recursive edit - - ;; Do the following, even if quit occurs. - (setq signal-hook-function #'edebug-signal) - (if edebug-backtrace-buffer - (kill-buffer edebug-backtrace-buffer)) - - ;; Remember selected-window after recursive-edit. - ;; (setq edebug-inside-window (selected-window)) - - (set-match-data edebug-outside-match-data) - - ;; Recursive edit may have changed buffers, - ;; so set it back before exiting let. - (if (buffer-name edebug-buffer) ; if it still exists - (progn - (set-buffer edebug-buffer) - (when (memq edebug-execution-mode '(go Go-nonstop)) - (edebug-overlay-arrow) - (sit-for 0)) - (edebug-mode -1)) - ;; gotta have a buffer to let its buffer local variables be set - (get-buffer-create " bogus edebug buffer")) - ));; inner let - ))) + (let ( + ;; Declare global values local but using the same global value. + ;; We could set these to the values for previous edebug call. + (last-command last-command) + (this-command this-command) + (current-prefix-arg nil) + + (last-input-event nil) + (last-command-event nil) + (last-event-frame nil) + (last-nonmenu-event nil) + (track-mouse nil) + + (standard-output t) + (standard-input t) + + ;; Don't keep reading from an executing kbd macro + ;; within edebug unless edebug-continue-kbd-macro is + ;; non-nil. Again, local binding may not be best. + (executing-kbd-macro + (if edebug-continue-kbd-macro executing-kbd-macro)) + + ;; Don't get confused by the user's keymap changes. + (overriding-local-map nil) + (overriding-terminal-local-map nil) + ;; Override other minor modes that may bind the keys + ;; edebug uses. + (minor-mode-overriding-map-alist + (list (cons 'edebug-mode edebug-mode-map))) + + ;; Bind again to outside values. + (debug-on-error edebug-outside-debug-on-error) + (debug-on-quit edebug-outside-debug-on-quit) + + ;; Don't keep defining a kbd macro. + (defining-kbd-macro + (if edebug-continue-kbd-macro defining-kbd-macro)) + + ;; others?? + ) + + (if (and (eq edebug-execution-mode 'go) + (not (memq arg-mode '(after error)))) + (message "Break")) + + (setq signal-hook-function nil) + + (edebug-mode 1) + (unwind-protect + (recursive-edit) ; <<<<<<<<<< Recursive edit + + ;; Do the following, even if quit occurs. + (setq signal-hook-function #'edebug-signal) + (if edebug-backtrace-buffer + (kill-buffer edebug-backtrace-buffer)) + + ;; Remember selected-window after recursive-edit. + ;; (setq edebug-inside-window (selected-window)) + + (set-match-data edebug-outside-match-data) + + ;; Recursive edit may have changed buffers, + ;; so set it back before exiting let. + (if (buffer-name edebug-buffer) ; if it still exists + (progn + (set-buffer edebug-buffer) + (when (memq edebug-execution-mode '(go Go-nonstop)) + (edebug-overlay-arrow) + (sit-for 0)) + (edebug-mode -1)) + ;; gotta have a buffer to let its buffer local variables be set + (get-buffer-create " bogus edebug buffer")) + ));; inner let + )) ;;; Display related functions diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index f5ff04ff372..37c5ebdb6da 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -951,7 +951,10 @@ not nil." (let ((slots (eieio--class-slots (eieio--object-class obj)))) (dotimes (i (length slots)) (let* ((name (cl--slot-descriptor-name (aref slots i))) - (df (eieio-oref-default obj name))) + ;; If the `:initform` signals an error, just skip it, + ;; since the error is intended to be signal'ed from + ;; `initialize-instance` rather than at the time of `defclass`. + (df (ignore-errors (eieio-oref-default obj name)))) (if (or df set-all) (eieio-oset obj name df)))))) @@ -964,49 +967,6 @@ need be... May remove that later...)" (cdr tuple) nil))) -;;; -;; Method Invocation order: C3 -(defun eieio--c3-candidate (class remaining-inputs) - "Return CLASS if it can go in the result now, otherwise nil." - ;; Ensure CLASS is not in any position but the first in any of the - ;; element lists of REMAINING-INPUTS. - (and (not (let ((found nil)) - (while (and remaining-inputs (not found)) - (setq found (member class (cdr (car remaining-inputs))) - remaining-inputs (cdr remaining-inputs))) - found)) - class)) - -(defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs) - "Try to merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order. -If a consistent order does not exist, signal an error." - (setq remaining-inputs (delq nil remaining-inputs)) - (if (null remaining-inputs) - ;; If all remaining inputs are empty lists, we are done. - (nreverse reversed-partial-result) - ;; Otherwise, we try to find the next element of the result. This - ;; is achieved by considering the first element of each - ;; (non-empty) input list and accepting a candidate if it is - ;; consistent with the rests of the input lists. - (let* ((found nil) - (tail remaining-inputs) - (next (progn - (while (and tail (not found)) - (setq found (eieio--c3-candidate (caar tail) - remaining-inputs) - tail (cdr tail))) - found))) - (if next - ;; The graph is consistent so far, add NEXT to result and - ;; merge input lists, dropping NEXT from their heads where - ;; applicable. - (eieio--c3-merge-lists - (cons next reversed-partial-result) - (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l)) - remaining-inputs)) - ;; The graph is inconsistent, give up - (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) - (defsubst eieio--class/struct-parents (class) (or (eieio--class-parents class) `(,eieio-default-superclass))) @@ -1014,14 +974,16 @@ If a consistent order does not exist, signal an error." (defun eieio--class-precedence-c3 (class) "Return all parents of CLASS in c3 order." (let ((parents (eieio--class-parents class))) - (eieio--c3-merge-lists - (list class) - (append - (or - (mapcar #'eieio--class-precedence-c3 parents) - `((,eieio-default-superclass))) - (list parents)))) - ) + (cons class + (merge-ordered-lists + (append + (or + (mapcar #'eieio--class-precedence-c3 parents) + `((,eieio-default-superclass))) + (list parents)) + (lambda (remaining-inputs) + (signal 'inconsistent-class-hierarchy + (list remaining-inputs))))))) ;;; ;; Method Invocation Order: Depth First diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index dcb4fe5ee6f..8224606ec57 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -184,8 +184,9 @@ and reference them using the function `class-option'." (when (and initarg (eq alloc :class)) (push (cons sname - (format "Meaningless :initarg for class allocated slot '%S'" - sname)) + (format-message + "Meaningless :initarg for class allocated slot `%S'" + sname)) warnings)) (let ((init (plist-get soptions :initform))) @@ -212,9 +213,8 @@ and reference them using the function `class-option'." ,(internal--format-docstring-line "Retrieve the slot `%S' from an object of class `%S'." sname name) - ;; FIXME: Why is this different from the :reader case? - (if (slot-boundp this ',sname) (eieio-oref this ',sname))) - accessors) + (slot-value this ',sname)) + accessors) (when (and eieio-backward-compatibility (eq alloc :class)) ;; FIXME: How could I declare this *method* as obsolete. (push `(cl-defmethod ,acces ((this (subclass ,name))) @@ -648,8 +648,7 @@ If SLOT is unbound, bind it to the list containing ITEM." (setq ov (list item)) (setq ov (eieio-oref object slot)) ;; turn it into a list. - (unless (listp ov) - (setq ov (list ov))) + (setq ov (ensure-list ov)) ;; Do the combination (if (not (member item ov)) (setq ov diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index bc498d4372f..4ee825136c9 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -5,7 +5,7 @@ ;; Author: Noah Friedman <friedman@splode.com> ;; Keywords: extensions ;; Created: 1995-10-06 -;; Version: 1.13.0 +;; Version: 1.15.0 ;; Package-Requires: ((emacs "26.3")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -300,13 +300,9 @@ reflect the change." This function displays the message produced by formatting ARGS with FORMAT-STRING on the mode line when the current buffer is a minibuffer. Otherwise, it displays the message like `message' would." - (if (minibufferp) + (if (or (bound-and-true-p edebug-mode) (minibufferp)) (progn - (add-hook 'minibuffer-exit-hook - (lambda () (setq eldoc-mode-line-string nil - ;; https://debbugs.gnu.org/16920 - eldoc-last-message nil)) - nil t) + (add-hook 'post-command-hook #'eldoc-minibuffer--cleanup) (with-current-buffer (window-buffer (or (window-in-direction 'above (minibuffer-window)) @@ -325,6 +321,13 @@ Otherwise, it displays the message like `message' would." (force-mode-line-update))) (apply #'message format-string args))) +(defun eldoc-minibuffer--cleanup () + (unless (or (bound-and-true-p edebug-mode) (minibufferp)) + (setq eldoc-mode-line-string nil + ;; https://debbugs.gnu.org/16920 + eldoc-last-message nil) + (remove-hook 'post-command-hook #'eldoc-minibuffer--cleanup))) + (make-obsolete 'eldoc-message "use `eldoc-documentation-functions' instead." "eldoc-1.1.0") (defun eldoc-message (&optional string) (eldoc--message string)) @@ -392,7 +395,6 @@ Also store it in `eldoc-last-message' and return that value." (defun eldoc-display-message-no-interference-p () "Return nil if displaying a message would cause interference." (not (or executing-kbd-macro - (bound-and-true-p edebug-active) ;; The following configuration shows "Matches..." in the ;; echo area when point is after a closing bracket, which ;; conflicts with eldoc. @@ -439,7 +441,7 @@ documentation-producing backend to cooperate with specific documentation-displaying frontends. For example, KEY can be: * `:thing', VALUE being a short string or symbol designating what - is being reported on. It can, for example be the name of the + DOCSTRING reports on. It can, for example be the name of the function whose signature is being documented, or the name of the variable whose docstring is being documented. `eldoc-display-in-echo-area', a member of @@ -450,6 +452,17 @@ documentation-displaying frontends. For example, KEY can be: `eldoc-display-in-echo-area' and `eldoc-display-in-buffer' will use when displaying `:thing''s value. +* `:echo', controlling how `eldoc-display-in-echo-area' should + present this documentation item in the echo area, to save + space. If VALUE is a string, echo it instead of DOCSTRING. If + a number, only echo DOCSTRING up to that character position. + If `skip', don't echo DOCSTRING at all. + +The additional KEY `:origin' is always added by ElDoc, its VALUE +being the member of `eldoc-documentation-functions' where +DOCSTRING originated. `eldoc-display-functions' may use this +information to organize display of multiple docstrings. + Finally, major modes should modify this hook locally, for example: (add-hook \\='eldoc-documentation-functions #\\='foo-mode-eldoc nil t) @@ -473,8 +486,6 @@ directly from the user or from ElDoc's automatic mechanisms'.") (defvar eldoc--doc-buffer nil "Buffer displaying latest ElDoc-produced docs.") -(defvar eldoc--doc-buffer-docs nil "Documentation items in `eldoc--doc-buffer'.") - (defun eldoc-doc-buffer (&optional interactive) "Get or display ElDoc documentation buffer. @@ -492,46 +503,70 @@ If INTERACTIVE, display it. Else, return said buffer." (display-buffer (current-buffer))) (t (current-buffer))))) +(defvar eldoc-doc-buffer-separator + (concat "\n" (propertize "\n" 'face '(:inherit separator-line :extend t)) "\n") + "String used to separate items in Eldoc documentation buffer.") + (defun eldoc--format-doc-buffer (docs) "Ensure DOCS are displayed in an *eldoc* buffer." (with-current-buffer (if (buffer-live-p eldoc--doc-buffer) eldoc--doc-buffer (setq eldoc--doc-buffer (get-buffer-create " *eldoc*"))) - (unless (eq docs eldoc--doc-buffer-docs) - (setq-local eldoc--doc-buffer-docs docs) - (let ((inhibit-read-only t) - (things-reported-on)) - (special-mode) - (erase-buffer) - (setq-local nobreak-char-display nil) - (cl-loop for (docs . rest) on docs - for (this-doc . plist) = docs - for thing = (plist-get plist :thing) - when thing do - (cl-pushnew thing things-reported-on) - (setq this-doc - (concat - (propertize (format "%s" thing) - 'face (plist-get plist :face)) - ": " - this-doc)) - do (insert this-doc) - when rest do (insert "\n") - finally (goto-char (point-min))) - ;; Rename the buffer, taking into account whether it was - ;; hidden or not - (rename-buffer (format "%s*eldoc%s*" - (if (string-match "^ " (buffer-name)) " " "") - (if things-reported-on - (format " for %s" - (mapconcat - (lambda (s) (format "%s" s)) - things-reported-on - ", ")) - "")))))) + (let ((inhibit-read-only t) + (things-reported-on)) + (special-mode) + (erase-buffer) + (setq-local nobreak-char-display nil) + (cl-loop for (docs . rest) on docs + for (this-doc . plist) = docs + for thing = (plist-get plist :thing) + when thing do + (cl-pushnew thing things-reported-on) + (setq this-doc + (concat + (propertize (format "%s" thing) + 'face (plist-get plist :face)) + ": " + this-doc)) + do (insert this-doc) + when rest do + (insert eldoc-doc-buffer-separator) + finally (goto-char (point-min))) + ;; Rename the buffer, taking into account whether it was + ;; hidden or not + (rename-buffer (format "%s*eldoc%s*" + (if (string-match "^ " (buffer-name)) " " "") + (if things-reported-on + (format " for %s" + (mapconcat + (lambda (s) (format "%s" s)) + things-reported-on + ", ")) + ""))))) eldoc--doc-buffer) +(defun eldoc--echo-area-render (docs) + "Similar to `eldoc--format-doc-buffer', but for echo area. +Helper for `eldoc-display-in-echo-area'." + (cl-loop for (item . rest) on docs + for (this-doc . plist) = item + for echo = (plist-get plist :echo) + for thing = (plist-get plist :thing) + unless (eq echo 'skip) do + (setq this-doc + (cond ((integerp echo) (substring this-doc 0 echo)) + ((stringp echo) echo) + (t this-doc))) + (when thing (setq this-doc + (concat + (propertize (format "%s" thing) + 'face (plist-get plist :face)) + ": " + this-doc))) + (insert this-doc) + (when rest (insert "\n")))) + (defun eldoc--echo-area-substring (available) "Given AVAILABLE lines, get buffer substring to display in echo area. Helper for `eldoc-display-in-echo-area'." @@ -570,25 +605,29 @@ known to be truncated." 'maybe))) (get-buffer-window eldoc--doc-buffer t))) -(defun eldoc-display-in-echo-area (docs _interactive) +(defun eldoc-display-in-echo-area (docs interactive) "Display DOCS in echo area. -Honor `eldoc-echo-area-use-multiline-p' and +INTERACTIVE is non-nil if user explicitly invoked ElDoc. Honor +`eldoc-echo-area-use-multiline-p' and `eldoc-echo-area-prefer-doc-buffer'." (cond - (;; Check if we have permission to mess with echo area at all. For - ;; example, if this-command is non-nil while running via an idle - ;; timer, we're still in the middle of executing a command, e.g. a - ;; query-replace where it would be annoying to overwrite the echo - ;; area. - (or - (not (eldoc-display-message-no-interference-p)) - this-command - (not (eldoc--message-command-p last-command)))) - (;; If we do but nothing to report, clear the echo area. + ((and (not interactive) + ;; When called non-interactively, check if we have permission + ;; to mess with echo area at all. For example, if + ;; this-command is non-nil while running via an idle timer, + ;; we're still in the middle of executing a command, e.g. a + ;; query-replace where it would be annoying to overwrite the + ;; echo area. + (or + (not (eldoc-display-message-no-interference-p)) + this-command + (not (eldoc--message-command-p last-command))))) + (;; If nothing to report, clear the echo area. (null docs) (eldoc--message nil)) (t - ;; Otherwise, establish some parameters. + ;; Otherwise, proceed to change the echo area. Start by + ;; establishing some parameters. (let* ((width (1- (window-width (minibuffer-window)))) (val (if (and (symbolp eldoc-echo-area-use-multiline-p) @@ -617,15 +656,15 @@ Honor `eldoc-echo-area-use-multiline-p' and single-doc) ((and (numberp available) (cl-plusp available)) - ;; Else, given a positive number of logical lines, we - ;; format the *eldoc* buffer, using as most of its - ;; contents as we know will fit. - (with-current-buffer (eldoc--format-doc-buffer docs) - (save-excursion - (eldoc--echo-area-substring available)))) + ;; Else, given a positive number of logical lines, grab + ;; as many as we can. + (with-temp-buffer + (eldoc--echo-area-render docs) + (eldoc--echo-area-substring available))) (t ;; this is the "truncate brutally" situation (let ((string - (with-current-buffer (eldoc--format-doc-buffer docs) + (with-temp-buffer + (eldoc--echo-area-render docs) (buffer-substring (goto-char (point-min)) (progn (end-of-visible-line) (point)))))) @@ -646,38 +685,45 @@ If INTERACTIVE is t, also display the buffer." (defun eldoc-documentation-default () "Show the first non-nil documentation string for item at point. This is the default value for `eldoc-documentation-strategy'." - (run-hook-with-args-until-success 'eldoc-documentation-functions - (eldoc--make-callback :patient))) - -(defun eldoc--documentation-compose-1 (eagerlyp) - "Helper function for composing multiple doc strings. -If EAGERLYP is non-nil show documentation as soon as possible, -else wait for all doc strings." (run-hook-wrapped 'eldoc-documentation-functions (lambda (f) - (let* ((callback (eldoc--make-callback - (if eagerlyp :eager :patient))) - (str (funcall f callback))) - (if (or (null str) (stringp str)) (funcall callback str)) - nil))) - t) + (funcall f (eldoc--make-callback :eager f))))) (defun eldoc-documentation-compose () "Show multiple documentation strings together after waiting for all of them. This is meant to be used as a value for `eldoc-documentation-strategy'." - (eldoc--documentation-compose-1 nil)) + (let (fns-and-callbacks) + ;; Make all the callbacks, setting up state inside + ;; `eldoc--invoke-strategy' to know how many callbacks to wait for + ;; before displaying the result (bug#62816). + (run-hook-wrapped 'eldoc-documentation-functions + (lambda (f) + (push (cons f (eldoc--make-callback :patient f)) + fns-and-callbacks) + nil)) + ;; Now call them. The last one will trigger the display. + (cl-loop for (f . callback) in fns-and-callbacks + for str = (funcall f callback) + when (or (null str) (stringp str)) do (funcall callback str))) + t) (defun eldoc-documentation-compose-eagerly () "Show multiple documentation strings one by one as soon as possible. This is meant to be used as a value for `eldoc-documentation-strategy'." - (eldoc--documentation-compose-1 t)) + (run-hook-wrapped 'eldoc-documentation-functions + (lambda (f) + (let* ((callback (eldoc--make-callback :eager f)) + (str (funcall f callback))) + (if (or (null str) (stringp str)) (funcall callback str)) + nil))) + t) (defun eldoc-documentation-enthusiast () "Show most important documentation string produced so far. This is meant to be used as a value for `eldoc-documentation-strategy'." (run-hook-wrapped 'eldoc-documentation-functions (lambda (f) - (let* ((callback (eldoc--make-callback :enthusiast)) + (let* ((callback (eldoc--make-callback :enthusiast f)) (str (funcall f callback))) (if (stringp str) (funcall callback str)) nil))) @@ -782,7 +828,7 @@ before a higher priority one.") ;; `eldoc--invoke-strategy' could be moved to ;; `eldoc-documentation-strategy' or thereabouts if/when we decide to ;; extend or publish the `make-callback' protocol. -(defun eldoc--make-callback (method) +(defun eldoc--make-callback (method origin) "Make callback suitable for `eldoc-documentation-functions'. The return value is a function FN whose lambda list is (STRING &rest PLIST) and can be called by those functions. Its @@ -802,8 +848,11 @@ have the following values: `eldoc-documentation-functions' have been collected; - `:eager' says to display STRING along with all other competing - strings so far, as soon as possible." - (funcall eldoc--make-callback method)) + strings so far, as soon as possible. + +ORIGIN is the member of `eldoc-documentation-functions' which +will be responsible for eventually calling the FN." + (funcall eldoc--make-callback method origin)) (defun eldoc--invoke-strategy (interactive) "Invoke `eldoc-documentation-strategy' function. @@ -840,9 +889,10 @@ the docstrings eventually produced, using (docs-registered '())) (cl-labels ((register-doc - (pos string plist) + (pos string plist origin) (when (and string (> (length string) 0)) - (push (cons pos (cons string plist)) docs-registered))) + (push (cons pos (cons string `(:origin ,origin ,@plist))) + docs-registered))) (display-doc () (run-hook-with-args @@ -852,7 +902,7 @@ the docstrings eventually produced, using (lambda (a b) (< (car a) (car b)))))) interactive)) (make-callback - (method) + (method origin) (let ((pos (prog1 howmany (cl-incf howmany)))) (cl-ecase method (:enthusiast @@ -860,7 +910,7 @@ the docstrings eventually produced, using (when (and string (cl-loop for (p) in docs-registered never (< p pos))) (setq docs-registered '()) - (register-doc pos string plist)) + (register-doc pos string plist origin)) (when (and (timerp eldoc--enthusiasm-curbing-timer) (memq eldoc--enthusiasm-curbing-timer timer-list)) @@ -872,19 +922,22 @@ the docstrings eventually produced, using (:patient (cl-incf want) (lambda (string &rest plist) - (register-doc pos string plist) + (register-doc pos string plist origin) (when (zerop (cl-decf want)) (display-doc)) t)) (:eager (lambda (string &rest plist) - (register-doc pos string plist) + (register-doc pos string plist origin) (display-doc) t)))))) (let* ((eldoc--make-callback #'make-callback) (res (funcall eldoc-documentation-strategy))) ;; Observe the old and the new protocol: - (cond (;; Old protocol: got string, output immediately; - (stringp res) (register-doc 0 res nil) (display-doc)) + (cond (;; Old protocol: got string, e-d-strategy is itself the + ;; origin function, and we output immediately; + (stringp res) + (register-doc 0 res nil eldoc-documentation-strategy) + (display-doc)) (;; Old protocol: got nil, clear the echo area; (null res) (eldoc--message nil)) (;; New protocol: trust callback will be called; @@ -946,7 +999,8 @@ the docstrings eventually produced, using "mark-paragraph" "mouse-set-point" "move-" "move-beginning-of-" "move-end-of-" "newline" "next-" "other-window" "pop-global-mark" "previous-" "recenter" "right-" "scroll-" "self-insert-command" - "split-window-" "up-list") + "split-window-" "up-list" "touch-screen-handle-touch" + "analyze-text-conversion") (provide 'eldoc) diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index c04b15dd237..d8ab883b58d 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -80,16 +80,16 @@ are as follows, and suppress messages about the indicated features: empty-let - let-bindings with empty variable lists" :type '(choice (const :tag "Don't suppress any warnings" nil) (repeat :tag "List of issues to ignore" - (choice (const undefined-functions - :tag "Calls to unknown functions") - (const unbound-reference - :tag "Reference to unknown variables") - (const unbound-assignment - :tag "Assignment to unknown variables") - (const macro-expansion - :tag "Failure to expand macros") - (const empty-let - :tag "Let-binding with empty varlist")))) + (choice (const :tag "Calls to unknown functions" + undefined-functions) + (const :tag "Reference to unknown variables" + unbound-reference) + (const :tag "Assignment to unknown variables" + unbound-assignment) + (const :tag "Failure to expand macros" + macro-expansion) + (const :tag "Let-binding with empty varlist" + empty-let)))) :safe (lambda (value) (or (null value) (and (listp value) (equal value diff --git a/lisp/emacs-lisp/ert-font-lock.el b/lisp/emacs-lisp/ert-font-lock.el new file mode 100644 index 00000000000..8bde83bf278 --- /dev/null +++ b/lisp/emacs-lisp/ert-font-lock.el @@ -0,0 +1,364 @@ +;;; ert-font-lock.el --- ERT Font Lock -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Vladimir Kazanov +;; Keywords: lisp, tools + +;; 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: +;; +;; ERT Font Lock is an extension to the Emacs Lisp Regression Test +;; library (ERT) providing a convenient way to check syntax +;; highlighting provided by font-lock. +;; +;; ert-font-lock entry points are functions +;; `ert-font-lock-test-string' and `ert-font-lock-test-file' and +;; convenience macros: `ert-font-lock-deftest' and +;; `ert-font-lock-deftest-file'. +;; +;; See unit tests in ert-font-lock-tests.el for usage examples. + +;;; Code: + +(require 'ert) +(require 'newcomment) +(require 'pcase) + +(defconst ert-font-lock--assertion-re + (rx + ;; column specifiers + (group (or "^" "<-")) + (one-or-more " ") + ;; optional negation of the face specification + (group (optional "!")) + ;; face symbol name + (group (one-or-more (or alphanumeric "-" "_" ".")))) + "An ert-font-lock assertion regex.") + +(defun ert-font-lock--validate-major-mode (mode) + "Validate if MODE is a valid major mode." + (unless (functionp mode) + (error "Invalid major mode: %S. Please specify a valid major mode for + syntax highlighting tests" mode))) + +(defun ert-font-lock--test-body-str (mode str test-name) + "Run assertions from STR. +Argument MODE - major mode to test. +Argument TEST-NAME - name of the currently running ert test." + (ert-font-lock--validate-major-mode mode) + (with-temp-buffer + (insert str) + (funcall mode) + (font-lock-ensure) + (let ((tests (ert-font-lock--parse-comments))) + (ert-font-lock--check-faces tests))) + test-name) + +(defun ert-font-lock--test-body-file (mode file test-name) + "Run assertions from FILE. +Argument MODE - major mode to test. +Argument TEST-NAME - name of the currently running ert test." + (ert-font-lock--validate-major-mode mode) + (ert-font-lock-test-file file mode) + test-name) + +(defun ert-font-lock--parse-macro-args (doc-keys-mode-arg) + "Parse DOC-KEYS-MODE-ARG macro argument list." + (let (doc doc-p mode arg) + + (when (stringp (car doc-keys-mode-arg)) + (setq doc (pop doc-keys-mode-arg) + doc-p t)) + + (pcase-let + ((`(,keys ,mode-arg) + (ert--parse-keys-and-body doc-keys-mode-arg))) + + (unless (symbolp (car mode-arg)) + (error "A major mode symbol expected: %S" (car mode-arg))) + (setq mode (pop mode-arg)) + + (unless (stringp (car mode-arg)) + (error "A string or file with assertions expected: %S" (car mode-arg))) + (setq arg (pop mode-arg)) + + (list doc doc-p keys mode arg)))) + +;;;###autoload +(defmacro ert-font-lock-deftest (name &rest docstring-keys-mode-and-str) + "Define test NAME (a symbol) using assertions from TEST-STR. + +Other than MAJOR-MODE and TEST-STR parameters, this macro accepts +the same parameters and keywords as `ert-deftest' and is intended +to be used through `ert'. + +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ +[:tags \\='(TAG...)] MAJOR-MODE TEST-STR)" + (declare (debug (&define [&name "test@" symbolp] + sexp [&optional stringp] + [&rest keywordp sexp] + symbolp + stringp)) + (doc-string 3) + (indent 2)) + (pcase-let ((`(,documentation + ,documentation-supplied-p + ,keys ,mode ,arg) + (ert-font-lock--parse-macro-args docstring-keys-mode-and-str))) + + `(ert-set-test ',name + (make-ert-test + :name ',name + ,@(when documentation-supplied-p + `(:documentation ,documentation)) + ,@(when (map-contains-key keys :expected-result) + `(:expected-result-type ,(map-elt keys :expected-result))) + ,@(when (map-contains-key keys :tags) + `(:tags ,(map-elt keys :tags))) + :body (lambda () (ert-font-lock--test-body-str ',mode ,arg ',name)) + + :file-name ,(or (macroexp-file-name) buffer-file-name))))) + +;;;###autoload +(defmacro ert-font-lock-deftest-file (name &rest docstring-keys-mode-and-file) + "Define test NAME (a symbol) using assertions from FILE. + +FILE - path to a file with assertions in ERT resource director as +return by `ert-resource-directory'. + +Other than MAJOR-MODE and FILE parameters, this macro accepts the +same parameters and keywords as `ert-deftest' and is intended to +be used through `ert'. + +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ +[:tags \\='(TAG...)] MAJOR-MODE FILE)" + (declare (debug (&define [&name "test@" symbolp] + sexp [&optional stringp] + [&rest keywordp sexp] + symbolp + stringp)) + (doc-string 3) + (indent 2)) + + (pcase-let ((`(,documentation + ,documentation-supplied-p + ,keys ,mode ,arg) + (ert-font-lock--parse-macro-args docstring-keys-mode-and-file))) + + `(ert-set-test ',name + (make-ert-test + :name ',name + ,@(when documentation-supplied-p + `(:documentation ,documentation)) + ,@(when (map-contains-key keys :expected-result) + `(:expected-result-type ,(map-elt keys :expected-result))) + ,@(when (map-contains-key keys :tags) + `(:tags ,(map-elt keys :tags))) + :body (lambda () (ert-font-lock--test-body-file + ',mode (ert-resource-file ,arg) ',name)) + :file-name ,(or (macroexp-file-name) buffer-file-name))))) + +(defun ert-font-lock--in-comment-p () + "Check if the current point is inside a comment." + (nth 4 (syntax-ppss))) + +(defun ert-font-lock--comment-start-p () + "Check if the current point starts a comment." + (or + ;; regexps use syntax tables so let's check that first + (looking-at "\\s<") + + ;; check newcomment.el facilities + (and comment-start (looking-at (regexp-quote comment-start))) + (and comment-start-skip (looking-at comment-start-skip)) + + ;; sometimes comment syntax is just hardcoded + (and (derived-mode-p '(c-mode c++-mode java-mode)) + (looking-at-p "//")))) + +(defun ert-font-lock--line-comment-p () + "Return t if the current line is a comment-only line." + (syntax-ppss) + (save-excursion + (beginning-of-line) + (skip-syntax-forward " ") + ;; skip empty lines + (unless (eolp) + (or + ;; multiline comments + (ert-font-lock--in-comment-p) + + ;; single line comments + (ert-font-lock--comment-start-p))))) + +(defun ert-font-lock--line-assertion-p () + "Return t if the current line contains an assertion." + (syntax-ppss) + (save-excursion + (beginning-of-line) + (skip-syntax-forward " ") + (re-search-forward ert-font-lock--assertion-re + (line-end-position) t 1))) + +(defun ert-font-lock--goto-first-char () + "Move the point to the first character." + (beginning-of-line) + (skip-syntax-forward " ")) + +(defun ert-font-lock--get-first-char-column () + "Get the position of the first non-empty char in the current line." + (save-excursion + (ert-font-lock--goto-first-char) + (- (point) (line-beginning-position)))) + +(defun ert-font-lock--parse-comments () + "Read test assertions from comments in the current buffer." + (let ((tests '()) + (curline 1) + (linetocheck -1)) + + (goto-char (point-min)) + + ;; Go through all lines, for comments check if there are + ;; assertions. For non-comment and comment/non-assert lines + ;; remember the last line seen. + (while (not (eobp)) + (catch 'nextline + + ;; Not a comment? remember the line, move to the next one + (unless (ert-font-lock--line-comment-p) + (setq linetocheck curline) + (throw 'nextline t)) + + ;; A comment. Not an assertion? remember the line to be + ;; checked, move to the next line + (unless (ert-font-lock--line-assertion-p) + (setq linetocheck curline) + (throw 'nextline t)) + + + ;; Collect the assertion + (when (re-search-forward ert-font-lock--assertion-re + (line-end-position) t 1) + + (unless (> linetocheck -1) + (user-error "Invalid test comment syntax at line %d. Expected a line to test before the comment line" curline)) + + ;; construct a test + (let* (;; either comment start char column (for arrows) or + ;; caret column + (column-checked (if (equal (match-string-no-properties 1) "^") + (- (match-beginning 1) (line-beginning-position)) + (ert-font-lock--get-first-char-column))) + ;; negate the face? + (negation (string-equal (match-string-no-properties 2) "!")) + ;; the face that is supposed to be in the position specified + (face (match-string-no-properties 3))) + + (push (list :line-checked linetocheck + :line-assert curline + :column-checked column-checked + :face face + :negation negation) + tests)))) + + ;; next line + (setq curline (1+ curline)) + (forward-line 1)) + + (reverse tests))) + +(defun ert-font-lock--point-at-line-and-column (line column) + "Get the buffer position for LINE and COLUMN." + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (move-to-column column) + (point))) + +(defun ert-font-lock--get-line (line-number) + "Return the content of the line specified by LINE-NUMBER." + (save-excursion + (goto-char (point-min)) + (forward-line (1- line-number)) + (buffer-substring-no-properties (line-beginning-position) (line-end-position)))) + +(defun ert-font-lock--check-faces (tests) + "Check if the current buffer is fontified correctly. +TESTS - tests to run. + +The function is meant to be run from within an ERT test." + (dolist (test tests) + (let* ((line-checked (plist-get test :line-checked)) + (line-assert (plist-get test :line-assert)) + (column-checked (plist-get test :column-checked)) + (expected-face (intern (plist-get test :face))) + (negation (plist-get test :negation)) + + (actual-face (get-text-property (ert-font-lock--point-at-line-and-column line-checked column-checked) 'face)) + (line-str (ert-font-lock--get-line line-checked)) + (line-assert-str (ert-font-lock--get-line line-assert))) + + (when (not (eq actual-face expected-face)) + (ert-fail + (list (format "Expected face %S, got %S on line %d column %d" + expected-face actual-face line-checked column-checked) + :line line-str + :assert line-assert-str))) + + (when (and negation (eq actual-face expected-face)) + (ert-fail + (list (format "Did not expect face %S face on line %d, column %d" + actual-face line-checked column-checked) + :line line-str + :assert line-assert-str)))))) + +;;;###autoload +(defun ert-font-lock-test-string (test-string mode) + "Check font faces in TEST-STRING set by MODE. + +The function is meant to be run from within an ERT test." + (ert-font-lock--validate-major-mode mode) + (with-temp-buffer + (insert test-string) + (funcall mode) + (font-lock-ensure) + + (ert-font-lock--check-faces (ert-font-lock--parse-comments))) + + (ert-pass)) + +;;;###autoload +(defun ert-font-lock-test-file (filename mode) + "Check font faces in FILENAME set by MODE. + +The function is meant to be run from within an ERT test." + (ert-font-lock--validate-major-mode mode) + (with-temp-buffer + (insert-file-contents filename) + (funcall mode) + (font-lock-ensure) + + (ert-font-lock--check-faces (ert-font-lock--parse-comments))) + + (ert-pass)) + + +(provide 'ert-font-lock) + +;;; ert-font-lock.el ends here diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 98a017c8a8e..e8b0dd92989 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -563,9 +563,9 @@ The same keyword arguments are supported as in ;; Emacs's Makefile sets $HOME to a nonexistent value. Needed ;; in batch mode only, therefore. (when (and noninteractive (not (file-directory-p "~/"))) - (setenv "HOME" temporary-file-directory)) + (setenv "HOME" (directory-file-name temporary-file-directory))) (format "/mock::%s" temporary-file-directory)))) - "Temporary directory for remote file tests.") + "Temporary directory for remote file tests.") (provide 'ert-x) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 74c59953db6..84b50777684 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -34,17 +34,18 @@ ;; `ert-run-tests-batch-and-exit' for non-interactive use. ;; ;; The body of `ert-deftest' forms resembles a function body, but the -;; additional operators `should', `should-not', `should-error' and -;; `skip-unless' are available. `should' is similar to cl's `assert', -;; but signals a different error when its condition is violated that -;; is caught and processed by ERT. In addition, it analyzes its -;; argument form and records information that helps debugging -;; (`cl-assert' tries to do something similar when its second argument -;; SHOW-ARGS is true, but `should' is more sophisticated). For -;; information on `should-not' and `should-error', see their -;; docstrings. `skip-unless' skips the test immediately without -;; processing further, this is useful for checking the test -;; environment (like availability of features, external binaries, etc). +;; additional operators `should', `should-not', `should-error', +;; `skip-when' and `skip-unless' are available. `should' is similar +;; to cl's `assert', but signals a different error when its condition +;; is violated that is caught and processed by ERT. In addition, it +;; analyzes its argument form and records information that helps +;; debugging (`cl-assert' tries to do something similar when its +;; second argument SHOW-ARGS is true, but `should' is more +;; sophisticated). For information on `should-not' and +;; `should-error', see their docstrings. The `skip-when' and +;; `skip-unless' forms skip the test immediately, which is useful for +;; checking the test environment (like availability of features, +;; external binaries, etc). ;; ;; See ERT's Info manual `(ert) Top' as well as the docstrings for ;; more details. To see some examples of tests written in ERT, see @@ -194,8 +195,8 @@ and the body." BODY is evaluated as a `progn' when the test is run. It should signal a condition on failure or just return if the test passes. -`should', `should-not', `should-error' and `skip-unless' are -useful for assertions in BODY. +`should', `should-not', `should-error', `skip-when', and +`skip-unless' are useful for assertions in BODY. Use `ert' to run tests interactively. @@ -227,7 +228,8 @@ in batch mode, an error is signaled. (tags nil tags-supplied-p)) body) (ert--parse-keys-and-body docstring-keys-and-body) - `(cl-macrolet ((skip-unless (form) `(ert--skip-unless ,form))) + `(cl-macrolet ((skip-when (form) `(ert--skip-when ,form)) + (skip-unless (form) `(ert--skip-unless ,form))) (ert-set-test ',name (make-ert-test :name ',name @@ -237,7 +239,9 @@ in batch mode, an error is signaled. `(:expected-result-type ,expected-result)) ,@(when tags-supplied-p `(:tags ,tags)) - :body (lambda () ,@body) + ;; Add `nil' after the body to enable compiler warnings + ;; about unused computations at the end. + :body (lambda () ,@body nil) :file-name ,(or (macroexp-file-name) buffer-file-name))) ',name)))) @@ -462,6 +466,15 @@ failed." (list :fail-reason "did not signal an error"))))))))) +(cl-defmacro ert--skip-when (form) + "Evaluate FORM. If it returns t, skip the current test. +Errors during evaluation are caught and handled like t." + (declare (debug t)) + (ert--expand-should `(skip-when ,form) form + (lambda (inner-form form-description-form _value-var) + `(when (condition-case nil ,inner-form (t t)) + (ert-skip ,form-description-form))))) + (cl-defmacro ert--skip-unless (form) "Evaluate FORM. If it returns nil, skip the current test. Errors during evaluation are caught and handled like nil." diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index bf890fc35a9..24d31fefd7d 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -42,8 +42,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - ;;; User variables: (defgroup find-function nil @@ -247,13 +245,19 @@ LIBRARY should be a string (the name of the library)." ;; LIBRARY may be "foo.el" or "foo". (let ((load-re (concat "\\(" (regexp-quote (file-name-sans-extension library)) "\\)" - (regexp-opt (get-load-suffixes)) "\\'"))) - (cl-loop - for (file . _) in load-history thereis - (and (stringp file) (string-match load-re file) - (let ((dir (substring file 0 (match-beginning 1))) - (basename (match-string 1 file))) - (locate-file basename (list dir) (find-library-suffixes))))))) + (regexp-opt (get-load-suffixes)) "\\'")) + (alist load-history) + elt file found) + (while (and alist (null found)) + (setq elt (car alist) + alist (cdr alist) + file (car elt) + found (and (stringp file) (string-match load-re file) + (let ((dir (substring file 0 (match-beginning 1))) + (basename (match-string 1 file))) + (locate-file basename (list dir) + (find-library-suffixes)))))) + found)) (defvar find-function-C-source-directory (let ((dir (expand-file-name "src" source-directory))) @@ -469,7 +473,8 @@ Return t if any PRED returns t." ((not (consp form)) nil) ((funcall pred form) t) (t - (cl-destructuring-bind (left-child . right-child) form + (let ((left-child (car form)) + (right-child (cdr form))) (or (find-function--any-subform-p left-child pred) (find-function--any-subform-p right-child pred)))))) @@ -591,7 +596,7 @@ otherwise uses `variable-at-point'." (list (intern (completing-read (format-prompt "Find %s" symb prompt-type) obarray predicate - t nil nil (and symb (symbol-name symb))))))) + 'lambda nil nil (and symb (symbol-name symb))))))) (defun find-function-do-it (symbol type switch-fn) "Find Emacs Lisp SYMBOL in a buffer and display it. diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index ecb46152ce1..9f40c1f3c93 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -416,9 +416,9 @@ The return value is the last VAL in the list. (lambda (do key alist &optional default remove testfn) (macroexp-let2 macroexp-copyable-p k key (gv-letplace (getter setter) alist - (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq))) - (assoc ,k ,getter ,testfn) - (assq ,k ,getter)) + (macroexp-let2 nil p (if (member testfn '(nil 'eq #'eq)) + `(assq ,k ,getter) + `(assoc ,k ,getter ,testfn)) (funcall do (if (null default) `(cdr ,p) `(if ,p (cdr ,p) ,default)) (lambda (v) @@ -638,6 +638,13 @@ REF must have been previously obtained with `gv-ref'." ;;; Generalized variables. +;; You'd think no one would write `(setf (error ...) ..)' but it +;; appears naturally as the result of macroexpansion of things like +;; (setf (pcase-exhaustive ...)). +;; We could generalize this to `throw' and `signal', but it seems +;; preferable to wait until there's a concrete need. +(gv-define-expander error (lambda (_do &rest args) `(error . ,args))) + ;; Some Emacs-related place types. (gv-define-simple-setter buffer-file-name set-visited-file-name t) (make-obsolete-generalized-variable @@ -814,17 +821,5 @@ REF must have been previously obtained with `gv-ref'." ((eq ,getter ,val) ,(funcall setter `(not ,val)))))))))) (make-obsolete-generalized-variable 'eq nil "29.1") -(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/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 1fa1297e787..2c7c6816e9c 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -1,9 +1,8 @@ ;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers -*- lexical-binding:t -*- -;; Copyright (C) 1992, 1994, 1997, 2000-2023 Free Software Foundation, -;; Inc. +;; Copyright (C) 1992-2023 Free Software Foundation, Inc. -;; Author: Eric S. Raymond <esr@snark.thyrsus.com> +;; Author: Eric S. Raymond <esr@thyrsus.com> ;; Maintainer: emacs-devel@gnu.org ;; Created: 14 Jul 1992 ;; Keywords: docs @@ -52,7 +51,7 @@ ;; ;; * Copyright line, which looks more or less like this: ;; -;; ;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. +;; ;; Copyright (C) 1999-2001 Free Software Foundation, Inc. ;; ;; * A blank line ;; @@ -68,7 +67,7 @@ ;; ;; Noah Friedman <friedman@ai.mit.edu> ;; ;; Joe Wells <jbw@maverick.uswest.com> ;; ;; Dave Brennan <brennan@hal.com> -;; ;; Eric Raymond <esr@snark.thyrsus.com> +;; ;; Eric S. Raymond <esr@thyrsus.com> ;; ;; * Maintainer line --- should be a single name/address as in the Author ;; line, or an address only. If there is no maintainer @@ -187,7 +186,6 @@ If the given section does not exist, return nil." (goto-char (point-min)) (if (re-search-forward (lm-get-header-re header 'section) nil t) (line-beginning-position (if after 2)))))) -(defalias 'lm-section-mark 'lm-section-start) (defun lm-section-end (header) "Return the buffer location of the end of a given section. @@ -230,12 +228,10 @@ a section." (defun lm-code-start () "Return the buffer location of the `Code' start marker." (lm-section-start "Code")) -(defalias 'lm-code-mark 'lm-code-start) (defun lm-commentary-start () "Return the buffer location of the `Commentary' start marker." (lm-section-start lm-commentary-header)) -(defalias 'lm-commentary-mark 'lm-commentary-start) (defun lm-commentary-end () "Return the buffer location of the `Commentary' section end." @@ -244,7 +240,6 @@ a section." (defun lm-history-start () "Return the buffer location of the `History' start marker." (lm-section-start lm-history-header)) -(defalias 'lm-history-mark 'lm-history-start) (defun lm-copyright-mark () "Return the buffer location of the `Copyright' line." @@ -258,7 +253,7 @@ a section." "Return the contents of the header named HEADER." (goto-char (point-min)) (let ((case-fold-search t)) - (when (and (re-search-forward (lm-get-header-re header) (lm-code-mark) t) + (when (and (re-search-forward (lm-get-header-re header) (lm-code-start) t) ;; RCS ident likes format "$identifier: data$" (looking-at (if (save-excursion @@ -402,7 +397,7 @@ ISO-DATE non-nil means return the date in ISO 8601 format." (when (progn (goto-char (point-min)) (re-search-forward "\\$[I]d: [^ ]+ [^ ]+ \\([^/]+\\)/\\([^/]+\\)/\\([^ ]+\\) " - (lm-code-mark) t)) + (lm-code-start) t)) (let ((dd (match-string 3)) (mm (match-string 2)) (yyyy (match-string 1))) @@ -420,7 +415,7 @@ ISO-DATE non-nil means return the date in ISO 8601 format." This can be found in an RCS or SCCS header." (lm-with-file file (or (lm-header "version") - (let ((header-max (lm-code-mark))) + (let ((header-max (lm-code-start))) (goto-char (point-min)) (cond ;; Look for an RCS header @@ -439,6 +434,38 @@ This can be found in an RCS or SCCS header." header-max t) (match-string-no-properties 1))))))) +(defun lm--prepare-package-dependencies (deps) + "Turn DEPS into an acceptable list of dependencies. + +Any parts missing a version string get a default version string +of \"0\" (meaning any version) and an appropriate level of lists +is wrapped around any parts requiring it." + (cond + ((not (listp deps)) + (error "Invalid requirement specifier: %S" deps)) + (t (mapcar (lambda (dep) + (cond + ((symbolp dep) `(,dep "0")) + ((stringp dep) + (error "Invalid requirement specifier: %S" dep)) + ((and (listp dep) (null (cdr dep))) + (list (car dep) "0")) + (t dep))) + deps)))) + +(declare-function package-read-from-string "package" (str)) + +(defun lm-package-requires (&optional file) + "Return dependencies listed in file FILE, or current buffer if FILE is nil. +The return value is a list of elements of the form (PACKAGE VERSION) +where PACKAGE is the package name (a symbol) and VERSION is the +package version (a string)." + (require 'package) + (lm-with-file file + (and-let* ((require-lines (lm-header-multiline "package-requires"))) + (lm--prepare-package-dependencies + (package-read-from-string (mapconcat #'identity require-lines " ")))))) + (defun lm-keywords (&optional file) "Return the keywords given in file FILE, or current buffer if FILE is nil. The return is a `downcase'-ed string, or nil if no keywords @@ -524,6 +551,7 @@ says display \"OK\" in temp buffer for files that have no problems. Optional argument VERBOSE specifies verbosity level. Optional argument NON-FSF-OK if non-nil means a non-FSF copyright notice is allowed." + ;; FIXME: Make obsolete in favor of checkdoc? (interactive (list nil nil t)) (let* ((ret (and verbose "Ok")) name) @@ -557,19 +585,18 @@ copyright notice is allowed." "`Keywords:' tag missing") ((not (lm-keywords-finder-p)) "`Keywords:' has no valid finder keywords (see `finder-known-keywords')") - ((not (lm-commentary-mark)) + ((not (lm-commentary-start)) "Can't find a `Commentary' section marker") - ((not (lm-history-mark)) + ((not (lm-history-start)) "Can't find a `History' section marker") - ((not (lm-code-mark)) + ((not (lm-code-start)) "Can't find a `Code' section marker") ((progn (goto-char (point-max)) (not (re-search-backward - (concat "^;;;[ \t]+" name "[ \t]+ends here[ \t]*$" - "\\|^;;;[ \t]+ End of file[ \t]+" name) - nil t))) + (rx bol ";;; " (regexp name) " ends here") + nil t))) "Can't find the footer line") ((not (and (lm-copyright-mark) (lm-crack-copyright))) "Can't find a valid copyright notice") @@ -631,6 +658,11 @@ Prompts for bug subject TOPIC. Leaves you in a mail buffer." (message "%s" (substitute-command-keys "Type \\[mail-send] to send bug report.")))) +(define-obsolete-function-alias 'lm-section-mark #'lm-section-start "30.1") +(define-obsolete-function-alias 'lm-code-mark #'lm-code-start "30.1") +(define-obsolete-function-alias 'lm-commentary-mark #'lm-commentary-start "30.1") +(define-obsolete-function-alias 'lm-history-mark #'lm-history-start "30.1") + (provide 'lisp-mnt) ;;; lisp-mnt.el ends here diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index d44c9d6e23d..b1fc65b09ac 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -31,11 +31,6 @@ (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'subr-x)) -(defvar font-lock-comment-face) -(defvar font-lock-doc-face) -(defvar font-lock-keywords-case-fold-search) -(defvar font-lock-string-face) - (define-abbrev-table 'lisp-mode-abbrev-table () "Abbrev table for Lisp mode.") @@ -134,7 +129,7 @@ (purecopy (concat "^\\s-*(" (regexp-opt '(;; Elisp - "defconst" "defcustom" + "defconst" "defcustom" "defvar-keymap" ;; CL "defconstant" "defparameter" "define-symbol-macro") @@ -361,7 +356,7 @@ This will generate compile-time constants from BINDINGS." "define-globalized-minor-mode" "define-skeleton" "define-widget" "ert-deftest")) (el-vdefs '("defconst" "defcustom" "defvaralias" "defvar-local" - "defface")) + "defface" "define-error")) (el-tdefs '("defgroup" "deftheme")) (el-errs '("user-error")) ;; Common-Lisp constructs supported by EIEIO. FIXME: namespace. @@ -876,7 +871,7 @@ complete sexp in the innermost containing list at position 2 (counting from 0). This is important for Lisp indentation." (unless pos (setq pos (point))) (let ((pss (syntax-ppss pos))) - (if (nth 9 pss) + (if (and (not (nth 2 pss)) (nth 9 pss)) (let ((sexp-start (car (last (nth 9 pss))))) (parse-partial-sexp sexp-start pos nil nil (syntax-ppss sexp-start))) pss))) @@ -1453,7 +1448,7 @@ and initial semicolons." ;; are buffer-local, but we avoid changing them so that they can be set ;; to make `forward-paragraph' and friends do something the user wants. ;; - ;; `paragraph-start': The `(' in the character alternative and the + ;; `paragraph-start': The `(' in the bracket expression and the ;; left-singlequote plus `(' sequence after the \\| alternative prevent ;; sexps and backquoted sexps that follow a docstring from being filled ;; with the docstring. This setting has the consequence of inhibiting diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 0bd1cc8b2e0..c2d9b12c8ad 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -422,7 +422,8 @@ of a defun, nil if it failed to find one." "\\(?:" defun-prompt-regexp "\\)\\s(") "^\\s(") nil 'move arg)) - (nth 8 (syntax-ppss)))) + (save-match-data + (nth 8 (syntax-ppss))))) found) (progn (goto-char (1- (match-end 0))) t))) @@ -529,6 +530,7 @@ major mode's decisions about context.") "Return the \"far end\" position of the buffer, in direction ARG. If ARG is positive, that's the end of the buffer. Otherwise, that's the beginning of the buffer." + (declare (side-effect-free error-free)) (if (> arg 0) (point-max) (point-min))) (defun end-of-defun (&optional arg interactive) diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index d7b9b131bc8..04bea4723a2 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -48,6 +48,7 @@ Standard prefixes won't be registered anyway. I.e. if a file \"foo.el\" defines variables or functions that use \"foo-\" as prefix, that will not be registered. But all other prefixes will be included.") +;;;###autoload (put 'autoload-compute-prefixes 'safe-local-variable #'booleanp) (defvar no-update-autoloads nil diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 168de1bf180..78601c0648e 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -39,6 +39,18 @@ of `byte-compile-form', etc., and manually popped off at its end. This is to preserve the data in it in the event of a condition-case handling a signaled error.") +(defmacro macroexp--with-extended-form-stack (expr &rest body) + "Evaluate BODY with EXPR pushed onto `byte-compile-form-stack'." + (declare (indent 1)) + ;; FIXME: We really should just be using a simple dynamic let-binding here, + ;; but these explicit push and pop make the extended stack value visible + ;; to error handlers. Remove that need for that! + `(progn + (push ,expr byte-compile-form-stack) + (prog1 + (progn ,@body) + (pop byte-compile-form-stack)))) + ;; Bound by the top-level `macroexpand-all', and modified to include any ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) @@ -105,14 +117,21 @@ each clause." (macroexp--all-forms clause skip) clause))) +(defvar macroexp-inhibit-compiler-macros nil + "Inhibit application of compiler macros if non-nil.") + (defun macroexp--compiler-macro (handler form) - (condition-case-unless-debug err - (let ((symbols-with-pos-enabled t)) - (apply handler form (cdr form))) - (error - (message "Warning: Optimization failure for %S: Handler: %S\n%S" - (car form) handler err) - form))) + "Apply compiler macro HANDLER to FORM and return the result. +Unless `macroexp-inhibit-compiler-macros' is non-nil, in which +case return FORM unchanged." + (if macroexp-inhibit-compiler-macros + form + (condition-case-unless-debug err + (apply handler form (cdr form)) + (error + (message "Warning: Optimization failure for %S: Handler: %S\n%S" + (car form) handler err) + form)))) (defun macroexp--funcall-if-compiled (_form) "Pseudo function used internally by macroexp to delay warnings. @@ -227,84 +246,79 @@ It should normally be a symbol with position and it defaults to FORM." (defun macroexp-macroexpand (form env) "Like `macroexpand' but checking obsolescence." (let* ((macroexpand-all-environment env) - (new-form - (macroexpand form env))) - (if (and (not (eq form new-form)) ;It was a macro call. - (car-safe form) - (symbolp (car form)) - (get (car form) 'byte-obsolete-info)) - (let* ((fun (car form)) - (obsolete (get fun 'byte-obsolete-info))) - (macroexp-warn-and-return - (macroexp--obsolete-warning - fun obsolete - (if (symbolp (symbol-function fun)) - "alias" "macro")) - new-form (list 'obsolete fun) nil fun)) - new-form))) + new-form) + (while (not (eq form (setq new-form (macroexpand-1 form env)))) + (let ((fun (car-safe form))) + (setq form + (if (and fun (symbolp fun) + (get fun 'byte-obsolete-info)) + (macroexp-warn-and-return + (macroexp--obsolete-warning + fun (get fun 'byte-obsolete-info) + (if (symbolp (symbol-function fun)) "alias" "macro")) + new-form (list 'obsolete fun) nil fun) + new-form)))) + 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 nil nil arglist) - - ;; 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))))) + (pcase form + ((or `(funcall (function ,lambda) . ,actuals) `(,lambda . ,actuals)) + (let* ((formals (nth 1 lambda)) + (body (cdr (macroexp-parse-body (cddr lambda)))) + optionalp restp + (dynboundarg nil) + bindings) + ;; FIXME: The checks below do not belong in an optimization phase. + (while formals + (if (macroexp--dynamic-variable-p (car formals)) + (setq dynboundarg t)) + (cond ((eq (car formals) '&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 formals)) + (error "Nothing after &optional in %s" name)) + (setq optionalp t)) + ((eq (car formals) '&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 formalss. + (if (null (cdr formals)) + (error "Nothing after &rest in %s" name)) + (if (cdr (cdr formals)) + (error "Multiple vars after &rest in %s" name)) + (setq restp t)) + (restp + (setq bindings (cons (list (car formals) + (and actuals (cons 'list actuals))) + bindings) + actuals nil)) + ((and (not optionalp) (null actuals)) + (setq formals nil actuals 'too-few)) + (t + (setq bindings (cons (list (car formals) (car actuals)) + bindings) + actuals (cdr actuals)))) + (setq formals (cdr formals))) + (cond + (actuals + (macroexp-warn-and-return + (format-message + (if (eq actuals 'too-few) + "attempt to open-code `%s' with too few arguments" + "attempt to open-code `%s' with too many arguments") + name) + form nil nil formals)) + ;; In lexical-binding mode, let and functions don't bind vars in + ;; the same way (let obey special-variable-p, but functions + ;; don't). So if one of the vars is declared as dynamically scoped, we + ;; can't just convert the call to `let'. + ;; FIXME: We should α-rename the affected args and then use `let'. + (dynboundarg form) + (bindings `(let ,(nreverse bindings) . ,body)) + (t (macroexp-progn body))))) + (_ (error "Not an unfoldable form: %S" form)))) (defun macroexp--dynamic-variable-p (var) "Whether the variable VAR is dynamically scoped. @@ -320,8 +334,7 @@ Only valid during macro-expansion." "Expand all macros in FORM. This is an internal version of `macroexpand-all'. Assumes the caller has bound `macroexpand-all-environment'." - (push form byte-compile-form-stack) - (prog1 + (macroexp--with-extended-form-stack form (if (eq (car-safe form) 'backquote-list*) ;; Special-case `backquote-list*', as it is normally a macro that ;; generates exceedingly deep expansions from relatively shallow input @@ -336,16 +349,48 @@ Assumes the caller has bound `macroexpand-all-environment'." (let ((fn (car-safe form))) (pcase form (`(cond . ,clauses) - (macroexp--cons fn (macroexp--all-clauses clauses) form)) + ;; Check for rubbish clauses at the end before macro-expansion, + ;; to avoid nuisance warnings from clauses that become + ;; unconditional through that process. + ;; FIXME: this strategy is defeated by forced `macroexpand-all', + ;; such as in `cl-flet'. Haven't seen that in the wild, though. + (let ((default-tail nil) + (n 0) + (rest clauses)) + (while rest + (let ((c (car-safe (car rest)))) + (when (cond ((consp c) (and (memq (car c) '(quote function)) + (cadr c))) + ((symbolp c) (or (eq c t) (keywordp c))) + (t t)) + ;; This is unquestionably a default clause. + (setq default-tail (cdr rest)) + (setq clauses (take (1+ n) clauses)) ; trim the tail + (setq rest nil))) + (setq n (1+ n)) + (setq rest (cdr rest))) + (let ((expanded-form + (macroexp--cons fn (macroexp--all-clauses clauses) form))) + (if default-tail + (macroexp-warn-and-return + (format-message + "Useless clause following default `cond' clause") + expanded-form '(suspicious cond) t default-tail) + expanded-form)))) (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) - (macroexp--cons - fn - (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handlers 1) - (cddr form)) - (cdr form)) - form)) + (let ((exp-body (macroexp--expand-all body))) + (if handlers + (macroexp--cons fn + (macroexp--cons + err (macroexp--cons + exp-body + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) + form) + (macroexp-warn-and-return + (format-message "`condition-case' without handlers") + exp-body (list 'suspicious 'condition-case) t form)))) (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) (push name macroexp--dynvars) (macroexp--all-forms form 2)) @@ -367,16 +412,21 @@ Assumes the caller has bound `macroexpand-all-environment'." (if (null body) (macroexp-unprogn (macroexp-warn-and-return - (format "Empty %s body" fun) - nil nil 'compile-only fun)) + (format-message "`%s' with empty body" fun) + nil (list 'empty-body fun) 'compile-only fun)) (macroexp--all-forms body)) (cdr form)) form))) (`(while) (macroexp-warn-and-return - "missing `while' condition" + (format-message "missing `while' condition") `(signal 'wrong-number-of-arguments '(while 0)) nil 'compile-only form)) + (`(unwind-protect ,expr) + (macroexp-warn-and-return + (format-message "`unwind-protect' without unwind forms") + (macroexp--expand-all expr) + (list 'suspicious 'unwind-protect) t form)) (`(setq ,(and var (pred symbolp) (pred (not booleanp)) (pred (not keywordp))) ,expr) @@ -392,7 +442,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (let ((nargs (length args))) (if (/= (logand nargs 1) 0) (macroexp-warn-and-return - "odd number of arguments in `setq' form" + (format-message "odd number of arguments in `setq' form") `(signal 'wrong-number-of-arguments '(setq ,nargs)) nil 'compile-only fn) (let ((assignments nil)) @@ -426,50 +476,31 @@ Assumes the caller has bound `macroexpand-all-environment'." (setq args (cddr args))) (cons 'progn (nreverse assignments)))))) (`(,(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 (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)))) + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) + form)) (`(funcall ,exp . ,args) (let ((eexp (macroexp--expand-all exp)) (eargs (macroexp--all-forms args))) - ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' - ;; has a compiler-macro, or to unfold it. (pcase eexp + ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' + ;; has a compiler-macro, or to unfold it. ((and `#',f - (guard (not (or (special-form-p f) (macrop f))))) ;; bug#46636 + (guard (and (symbolp f) + ;; bug#46636 + (not (or (special-form-p f) (macrop f)))))) (macroexp--expand-all `(,f . ,eargs))) - (_ `(funcall ,eexp . ,eargs))))) + (`#'(lambda . ,_) + (macroexp--unfold-lambda `(,fn ,eexp . ,eargs))) + (_ `(,fn ,eexp . ,eargs))))) (`(funcall . ,_) form) ;bug#53227 (`(,func . ,_) - (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 nil nil (cadr arg)))))) + (let ((handler (function-get func 'compiler-macro))) ;; 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 - ;; are symbols). + ;; No compiler macro. We just expand each argument. (macroexp--all-forms form 1) ;; If the handler is not loaded yet, try (auto)loading the ;; function itself, which may in turn load the handler. @@ -486,23 +517,9 @@ Assumes the caller has bound `macroexpand-all-environment'." (setq form (macroexp--compiler-macro handler newform)) (if (eq newform form) newform - (macroexp--expand-all newform))) + (macroexp--expand-all form))) (macroexp--expand-all newform)))))) - (_ form)))) - (pop byte-compile-form-stack))) - -;; 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))) + (_ form)))))) ;;;###autoload (defun macroexpand-all (form &optional environment) @@ -526,11 +543,17 @@ definitions to shadow the loaded ones for use in file byte-compilation." (defun macroexp-parse-body (body) "Parse a function BODY into (DECLARATIONS . EXPS)." (let ((decls ())) - (while (and (cdr body) - (let ((e (car body))) - (or (stringp e) - (memq (car-safe e) - '(:documentation declare interactive cl-declare))))) + (while + (and body + (let ((e (car body))) + (or (and (stringp e) + ;; If there is only a string literal with + ;; nothing following, we consider this to be + ;; part of the body (the return value) rather + ;; than a declaration at this point. + (cdr body)) + (memq (car-safe e) + '(:documentation declare interactive cl-declare))))) (push (pop body) decls)) (cons (nreverse decls) body))) @@ -787,40 +810,38 @@ test of free variables in the following ways: (defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. - (let ((symbols-with-pos-enabled t) - (print-symbols-bare t)) - (cond - ;; Don't repeat the same warning for every top-level element. - ((eq 'skip (car macroexp--pending-eager-loads)) form) - ;; If we detect a cycle, skip macro-expansion for now, and output a warning - ;; with a trimmed backtrace. - ((and load-file-name (member load-file-name macroexp--pending-eager-loads)) - (let* ((bt (delq nil - (mapcar #'macroexp--trim-backtrace-frame - (macroexp--backtrace)))) - (elem `(load ,(file-name-nondirectory load-file-name))) - (tail (member elem (cdr (member elem bt))))) - (if tail (setcdr tail (list '…))) - (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) - (if macroexp--debug-eager - (debug 'eager-macroexp-cycle) - (error "Eager macro-expansion skipped due to cycle:\n %s" - (mapconcat #'prin1-to-string (nreverse bt) " => "))) - (push 'skip macroexp--pending-eager-loads) - form)) - (t - (condition-case err - (let ((macroexp--pending-eager-loads - (cons load-file-name macroexp--pending-eager-loads))) - (if full-p - (macroexpand--all-toplevel form) - (macroexpand form))) - (error - ;; Hopefully this shouldn't happen thanks to the cycle detection, - ;; but in case it does happen, let's catch the error and give the - ;; code a chance to macro-expand later. - (error "Eager macro-expansion failure: %S" err) - form)))))) + (cond + ;; Don't repeat the same warning for every top-level element. + ((eq 'skip (car macroexp--pending-eager-loads)) form) + ;; If we detect a cycle, skip macro-expansion for now, and output a warning + ;; with a trimmed backtrace. + ((and load-file-name (member load-file-name macroexp--pending-eager-loads)) + (let* ((bt (delq nil + (mapcar #'macroexp--trim-backtrace-frame + (macroexp--backtrace)))) + (elem `(load ,(file-name-nondirectory load-file-name))) + (tail (member elem (cdr (member elem bt))))) + (if tail (setcdr tail (list '…))) + (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) + (if macroexp--debug-eager + (debug 'eager-macroexp-cycle) + (error "Eager macro-expansion skipped due to cycle:\n %s" + (mapconcat #'prin1-to-string (nreverse bt) " => "))) + (push 'skip macroexp--pending-eager-loads) + form)) + (t + (condition-case err + (let ((macroexp--pending-eager-loads + (cons load-file-name macroexp--pending-eager-loads))) + (if full-p + (macroexpand--all-toplevel form) + (macroexpand form))) + ((debug error) + ;; Hopefully this shouldn't happen thanks to the cycle detection, + ;; but in case it does happen, let's catch the error and give the + ;; code a chance to macro-expand later. + (error "Eager macro-expansion failure: %S" err) + form))))) ;; ¡¡¡ Big Ugly Hack !!! ;; src/bootstrap-emacs is mostly used to compile .el files, so it needs diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index cb1cc88e78f..fffb199e2ea 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -168,16 +168,14 @@ The function's value is the number of actions taken." (key-description (vector help-char))) (if minibuffer-auto-raise (raise-frame (window-frame (minibuffer-window)))) - (while (progn - (setq char (read-event)) - ;; If we get -1, from end of keyboard - ;; macro, try again. - (equal char -1))) + (setq char (read-event)) ;; Show the answer to the question. (message "%s(y, n, !, ., q, %sor %s) %s" prompt user-keys (key-description (vector help-char)) - (single-key-description char))) + (if (equal char -1) + "[end-of-keyboard-macro]" + (single-key-description char)))) (setq def (lookup-key map (vector char)))) (cond ((eq def 'exit) (setq next (lambda () nil))) diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 7a48ba47434..b46c74343c0 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -8,6 +8,9 @@ ;; Version: 3.3.1 ;; Package-Requires: ((emacs "26")) +;; This is a GNU ELPA :core package. Avoid functionality that is not +;; compatible with the version of Emacs recorded above. + ;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify @@ -50,18 +53,20 @@ 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 with the KEY. +Each element of ARGS can be of the form (KEY PAT [DEFAULT]), +which looks up KEY in the map and matches the associated value +against `pcase' pattern PAT. DEFAULT specifies the fallback +value to use when KEY is not present in the map. If omitted, it +defaults to nil. Both KEY and DEFAULT are evaluated. Each element can also be a SYMBOL, which is an abbreviation of a (KEY PAT) tuple of the form (\\='SYMBOL SYMBOL). When SYMBOL is a keyword, it is an abbreviation of the form (:SYMBOL SYMBOL), useful for binding plist values. -Keys in ARGS not found in the map are ignored, and the match doesn't -fail." +An element of ARGS fails to match if PAT does not match the +associated value or the default value. The overall pattern fails +to match if any element of ARGS fails to match." `(and (pred mapp) ,@(map--make-pcase-bindings args))) @@ -71,12 +76,13 @@ fail." KEYS can be a list of symbols, in which case each element will be 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. +KEYS can also be a list of (KEY VARNAME [DEFAULT]) sublists, in +which case KEY and DEFAULT are unquoted forms. MAP can be an alist, plist, hash-table, or array." (declare (indent 2) - (debug ((&rest &or symbolp ([form symbolp])) form body))) + (debug ((&rest &or symbolp ([form symbolp &optional form])) + form body))) `(pcase-let ((,(map--make-pcase-patterns keys) ,map)) ,@body)) @@ -595,11 +601,21 @@ Example: (map-into \\='((1 . 3)) \\='(hash-table :test eql))" (map--into-hash map (cdr type))) +(defmacro map--pcase-map-elt (key default map) + "A macro to make MAP the last argument to `map-elt'. + +This allows using default values for `map-elt', which can't be +done using `pcase--flip'. + +KEY is the key sought in the map. DEFAULT is the default value." + `(map-elt ,map ,key ,default)) + (defun map--make-pcase-bindings (args) "Return a list of pcase bindings from ARGS to the elements of a map." (mapcar (lambda (elt) (cond ((consp elt) - `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt))) + `(app (map--pcase-map-elt ,(car elt) ,(caddr elt)) + ,(cadr elt))) ((keywordp elt) (let ((var (intern (substring (symbol-name elt) 1)))) `(app (pcase--flip map-elt ,elt) ,var))) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 85934d9ed0a..9f2b42f5765 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -165,6 +165,8 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") (buffer-string)) usage)))) +;; FIXME: How about renaming this to just `eval-interactive-spec'? +;; It's not specific to the advice system. (defun advice-eval-interactive-spec (spec) "Evaluate the interactive spec SPEC." (cond @@ -174,24 +176,44 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") ;; FIXME: Despite appearances, this is not faithful: SPEC and ;; (advice-eval-interactive-spec SPEC) will behave subtly differently w.r.t ;; command-history (and maybe a few other details). - (call-interactively `(lambda (&rest args) (interactive ,spec) args))) + (call-interactively + ;; Sadly (lambda (&rest args) (interactive spec) args) doesn't work :-( + (cconv--interactive-helper (lambda (&rest args) args) spec))) ;; ((functionp spec) (funcall spec)) (t (eval spec)))) +(defun advice--interactive-form-1 (function) + "Like `interactive-form' but preserves the static context if needed." + (let ((if (interactive-form function))) + (if (or (null if) (not (eq 'closure (car-safe function)))) + if + (cl-assert (eq 'interactive (car if))) + (let ((form (cadr if))) + (if (macroexp-const-p form) + if + ;; The interactive is expected to be run in the static context + ;; that the function captured. + (let ((ctx (nth 1 function))) + `(interactive + ,(let* ((f (if (eq 'function (car-safe form)) (cadr form) form))) + ;; If the form jut returns a function, preserve the fact that + ;; it just returns a function, which is an info we use in + ;; `advice--make-interactive-form'. + (if (eq 'lambda (car-safe f)) + `',(eval form ctx) + `(eval ',form ',ctx)))))))))) + (defun advice--interactive-form (function) "Like `interactive-form' but tries to avoid autoloading functions." (if (not (and (symbolp function) (autoloadp (indirect-function function)))) - (interactive-form function) + (advice--interactive-form-1 function) (when (commandp function) `(interactive (advice-eval-interactive-spec - (cadr (interactive-form ',function))))))) + (cadr (advice--interactive-form-1 ',function))))))) (defun advice--make-interactive-form (iff ifm) - ;; TODO: make it so that interactive spec can be a constant which - ;; dynamically checks the advice--car/cdr to do its job. - ;; For that, advice-eval-interactive-spec needs to be more faithful. (let* ((fspec (cadr iff))) - (when (eq 'function (car-safe fspec)) ;; Macroexpanded lambda? + (when (memq (car-safe fspec) '(function quote)) ;; Macroexpanded lambda? (setq fspec (eval fspec t))) (if (functionp fspec) `(funcall ',fspec ',(cadr ifm)) @@ -270,14 +292,13 @@ HOW is a symbol to select an entry in `advice--how-alist'." (equal function (cdr (assq 'name props)))) (list (advice--remove-function rest function))))))) -(defvar advice--buffer-local-function-sample nil - "Keeps an example of the special \"run the default value\" functions. -These functions play the same role as t in buffer-local hooks, and to recognize -them, we keep a sample here against which to compare. Each instance is -different, but `function-equal' will hopefully ignore those differences.") +(oclosure-define (advice--forward + (:predicate advice--forward-p)) + "Redirect to the global value of a var. +These functions act like the t special value in buffer-local hooks.") (defun advice--set-buffer-local (var val) - (if (function-equal val advice--buffer-local-function-sample) + (if (advice--forward-p val) (kill-local-variable var) (set (make-local-variable var) val))) @@ -286,11 +307,10 @@ different, but `function-equal' will hopefully ignore those differences.") "Buffer-local value of VAR, presumed to contain a function." (declare (gv-setter advice--set-buffer-local)) (if (local-variable-p var) (symbol-value var) - (setq advice--buffer-local-function-sample - ;; This function acts like the t special value in buffer-local hooks. - ;; FIXME: Provide an `advice-bottom' function that's like - ;; `advice-cd*r' but also follows through this proxy. - (lambda (&rest args) (apply (default-value var) args))))) + ;; FIXME: Provide an `advice-bottom' function that's like + ;; `advice--cd*r' but also follows through this proxy. + (oclosure-lambda (advice--forward) (&rest args) + (apply (default-value var) args)))) (eval-and-compile (defun advice--normalize-place (place) @@ -369,26 +389,8 @@ is also interactive. There are 3 cases: `(advice--add-function ,how (gv-ref ,(advice--normalize-place place)) ,function ,props)) -(declare-function comp-subr-trampoline-install "comp") - ;;;###autoload (defun advice--add-function (how 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 @@ -507,8 +509,6 @@ HOW can be one of: <<>>" ;; TODO: ;; - record the advice location, to display in describe-function. - ;; - change all defadvice in lisp/**/*.el. - ;; - obsolete advice.el. (let* ((f (symbol-function symbol)) (nf (advice--normalize symbol f))) (unless (eq f nf) (fset symbol nf)) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 0b87115e2a9..c23dd5a36da 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -51,7 +51,7 @@ ;; - coercion wrappers, as in "Threesomes, with and without blame" ;; https://dl.acm.org/doi/10.1145/1706299.1706342, or ;; "On the Runtime Complexity of Type-Directed Unboxing" -;; http://sv.c.titech.ac.jp/minamide/papers.html +;; https://sv.c.titech.ac.jp/minamide/papers.html ;; - An efficient `negate' operation such that ;; (negate (negate f)) returns just `f' and (negate #'<) returns #'>=. ;; - Autoloads (tho currently our bytecode functions (and hence OClosures) @@ -350,6 +350,7 @@ MUTABLE is a list of symbols indicating which of the BINDINGS should be mutable. No checking is performed." (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body))) + (cl-assert lexical-binding) ;Can't work in dynbind dialect. ;; FIXME: Fundamentally `oclosure-lambda' should be a special form. ;; We define it here as a macro which expands to something that ;; looks like "normal code" in order to avoid backward compatibility @@ -569,7 +570,7 @@ This has 2 uses: (defun cconv--interactive-helper (fun if) "Add interactive \"form\" IF to FUN. Returns a new command that otherwise behaves like FUN. -IF should actually not be a form but a function of no arguments." +IF can be an ELisp form to be interpreted or a function of no arguments." (oclosure-lambda (cconv--interactive-helper (fun fun) (if if)) (&rest args) (apply (if (called-interactively-p 'any) diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index c6625bf0ff8..b3e3f450f1d 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -62,6 +62,18 @@ (defconst package-vc--elpa-packages-version 1 "Version number of the package specification format understood by package-vc.") +(defconst package-vc--backend-type + `(choice :convert-widget + ,(lambda (widget) + (let (opts) + (dolist (be vc-handled-backends) + (when (or (vc-find-backend-function be 'clone) + (alist-get 'clone (get be 'vc-functions))) + (push (widget-convert (list 'const be)) opts))) + (widget-put widget :args opts)) + widget)) + "The type of VC backends that support cloning package VCS repositories.") + (defcustom package-vc-heuristic-alist `((,(rx bos "http" (? "s") "://" (or (: (? "www.") "github.com" @@ -94,24 +106,34 @@ (+ (or alnum "-" "." "_")) (? "/"))) eos) . Bzr)) - "Heuristic mapping URL regular expressions to VC backends." + "Alist mapping repository URLs to VC backends. +`package-vc-install' consults this alist to determine the VC +backend from the repository URL when you call it without +specifying a backend. Each element of the alist has the form +\(URL-REGEXP . BACKEND). `package-vc-install' will use BACKEND of +the first association for which the URL of the repository matches +the URL-REGEXP of the association. If no match is found, +`package-vc-install' uses `package-vc-default-backend' instead." :type `(alist :key-type (regexp :tag "Regular expression matching URLs") - :value-type (choice :tag "VC Backend" - ,@(mapcar (lambda (b) `(const ,b)) - vc-handled-backends))) + :value-type ,package-vc--backend-type) :version "29.1") (defcustom package-vc-default-backend 'Git - "Default VC backend used when cloning a package repository. -If no repository type was specified or could be guessed by -`package-vc-heuristic-alist', this is the default VC backend -used as fallback. The value must be a member of -`vc-handled-backends' and the named backend must implement -the `clone' function." - :type `(choice ,@(mapcar (lambda (b) (list 'const b)) - vc-handled-backends)) + "Default VC backend to use for cloning package repositories. +`package-vc-install' uses this backend when you specify neither +the backend nor a repository URL that's recognized via +`package-vc-heuristic-alist'. + +The value must be a member of `vc-handled-backends' that supports +the `clone' VC function." + :type package-vc--backend-type :version "29.1") +(defcustom package-vc-register-as-project t + "Non-nil means that packages should be registered as projects." + :type 'boolean + :version "30.1") + (defvar package-vc-selected-packages) ; pacify byte-compiler ;;;###autoload @@ -135,20 +157,21 @@ the `clone' function." (package-desc-create :name name :kind 'vc)) spec))))))) -(defcustom package-vc-selected-packages '() - "List of packages that must be installed. -Each member of the list is of the form (NAME . SPEC), where NAME -is a symbol designating the package and SPEC is one of: + +(defcustom package-vc-selected-packages nil + "List of packages to install from their VCS repositories. +Each element is of the form (NAME . SPEC), where NAME is a symbol +designating the package and SPEC is one of: - nil, if any package version can be installed; - a version string, if that specific revision is to be installed; -- a property list, describing a package specification. For more - details, please consult the subsection \"Specifying Package - Sources\" in the Info node `(emacs)Fetching Package Sources'. +- a property list, describing a package specification. For possible + values, see the subsection \"Specifying Package Sources\" in the + Info node `(emacs)Fetching Package Sources'. -This user option will be automatically updated to store package -specifications for packages that are not specified in any -archive." +The command `package-vc-install' updates the value of this user +option to store package specifications for packages that are not +specified in any archive." :type '(alist :tag "List of packages you want to be installed" :key-type (symbol :tag "Package") :value-type @@ -339,6 +362,47 @@ asynchronously." "\n") nil pkg-file nil 'silent)))) +(defcustom package-vc-allow-build-commands nil + "Whether to run extra build commands when installing VC packages. + +Some packages specify \"make\" targets or other shell commands +that should run prior to building the package, by including the +:make or :shell-command keywords in their specification. By +default, Emacs ignores these keywords when installing and +upgrading VC packages, but if the value is a list of package +names (symbols), the build commands will be run for those +packages. If the value is t, always respect :make and +:shell-command keywords. + +It may be necessary to run :make and :shell-command arguments in +order to initialize a package or build its documentation, but +please be careful when changing this option, as installing and +updating a package can run potentially harmful code. + +This applies to package specifications that come from your +configured package archives, as well as from entries in +`package-vc-selected-packages' and specifications that you give +to `package-vc-install' directly." + :type '(choice (const :tag "Run for all packages" t) + (repeat :tag "Run only for selected packages" (symbol :tag "Package name")) + (const :tag "Never run" nil)) + :version "30.1") + +(defun package-vc--make (pkg-spec pkg-desc) + "Process :make and :shell-command in PKG-SPEC. +PKG-DESC is the package descriptor for the package that is being +prepared." + (let ((target (plist-get pkg-spec :make)) + (cmd (plist-get pkg-spec :shell-command)) + (buf (format " *package-vc make %s*" (package-desc-name pkg-desc)))) + (when (or cmd target) + (with-current-buffer (get-buffer-create buf) + (erase-buffer) + (when (and cmd (/= 0 (call-process shell-file-name nil t nil shell-command-switch cmd))) + (warn "Failed to run %s, see buffer %S" cmd (buffer-name))) + (when (and target (/= 0 (apply #'call-process "make" nil t nil (if (consp target) target (list target))))) + (warn "Failed to make %s, see buffer %S" target (buffer-name))))))) + (declare-function org-export-to-file "ox" (backend file)) (defun package-vc--build-documentation (pkg-desc file) @@ -349,42 +413,48 @@ otherwise it's assumed to be an Info file." (default-directory (package-desc-dir pkg-desc)) (docs-directory (file-name-directory (expand-file-name file))) (output (expand-file-name (format "%s.info" pkg-name))) + (log-buffer (get-buffer-create (format " *package-vc doc: %s*" pkg-name))) clean-up) - (when (string-match-p "\\.org\\'" file) - (require 'ox) - (require 'ox-texinfo) - (with-temp-buffer - (insert-file-contents file) - (setq file (make-temp-file "ox-texinfo-")) - (let ((default-directory docs-directory)) - (org-export-to-file 'texinfo file)) - (setq clean-up t))) - (with-current-buffer (get-buffer-create " *package-vc doc*") - (erase-buffer) - (cond - ((/= 0 (call-process "makeinfo" nil t nil - "-I" docs-directory - "--no-split" file - "-o" output)) - (message "Failed to build manual %s, see buffer %S" - file (buffer-name))) - ((/= 0 (call-process "install-info" nil t nil - output (expand-file-name "dir"))) - (message "Failed to install manual %s, see buffer %S" - output (buffer-name))) - ((kill-buffer)))) + (with-current-buffer log-buffer + (erase-buffer)) + (condition-case err + (progn + (when (string-match-p "\\.org\\'" file) + (require 'ox) + (require 'ox-texinfo) + (with-temp-buffer + (insert-file-contents file) + (setq file (make-temp-file "ox-texinfo-")) + (let ((default-directory docs-directory)) + (org-export-to-file 'texinfo file)) + (setq clean-up t))) + (cond + ((/= 0 (call-process "makeinfo" nil log-buffer nil + "-I" docs-directory + "--no-split" file + "-o" output)) + (message "Failed to build manual %s, see buffer %S" + file (buffer-name))) + ((/= 0 (call-process "install-info" nil log-buffer nil + output (expand-file-name "dir"))) + (message "Failed to install manual %s, see buffer %S" + output (buffer-name))) + ((kill-buffer log-buffer)))) + (error (with-current-buffer log-buffer + (insert (error-message-string err))) + (message "Failed to export org manual for %s, see buffer %S" pkg-name log-buffer))) (when clean-up (delete-file file)))) -(defun package-vc-install-dependencies (requirements) - "Install missing dependencies, and return missing ones. -The return value will be nil if everything was found, or a list -of (NAME VERSION) pairs of all packages that couldn't be found. +(defun package-vc-install-dependencies (deps) + "Install missing dependencies according to DEPS. -REQUIREMENTS should be a list of additional requirements; each -element in this list should have the form (PACKAGE VERSION-LIST), -where PACKAGE is a package name and VERSION-LIST is the required -version of that package." +DEPS is a list of elements (PACKAGE VERSION-LIST), where +PACKAGE is a package name and VERSION-LIST is the required +version of that package. + +Return a list of dependencies that couldn't be met (or nil, when +this function successfully installs all given dependencies)." (let ((to-install '()) (missing '())) (cl-labels ((search (pkg) "Attempt to find all dependencies for PKG." @@ -418,7 +488,7 @@ version of that package." (let ((desc-a (package-desc-name a)) (desc-b (package-desc-name b))) (depends-on-p desc-a desc-b)))) - (mapc #'search requirements) + (mapc #'search deps) (cl-callf sort to-install #'version-order) (cl-callf seq-uniq to-install #'duplicate-p) (cl-callf sort to-install #'dependent-order)) @@ -431,26 +501,35 @@ This includes downloading missing dependencies, generating autoloads, generating a package description file (used to identify a package as a VC package later on), building documentation and marking the package as installed." - (let (missing) - ;; Remove any previous instance of PKG-DESC from `package-alist' - (let ((pkgs (assq (package-desc-name pkg-desc) package-alist))) - (when pkgs - (setf (cdr pkgs) (seq-remove #'package-vc-p (cdr pkgs))))) + (let ((pkg-spec (package-vc--desc->spec pkg-desc)) + missing) ;; In case the package was installed directly from source, the ;; dependency list wasn't know beforehand, and they might have ;; to be installed explicitly. - (let ((deps '())) + (let ((ignored-files + (if (plist-get pkg-spec :ignored-files) + (mapconcat + (lambda (ignore) + (wildcard-to-regexp + (if (string-match-p "\\`/" ignore) + (concat pkg-dir ignore) + (concat "*/" ignore)))) + (plist-get pkg-spec :ignored-files) + "\\|") + regexp-unmatchable)) + (deps '())) (dolist (file (directory-files pkg-dir t "\\.el\\'" t)) - (with-temp-buffer - (insert-file-contents file) - (when-let* ((require-lines (lm-header-multiline "package-requires"))) - (thread-last - (mapconcat #'identity require-lines " ") - package-read-from-string - package--prepare-dependencies - (nconc deps) - (setq deps))))) + (unless (string-match-p ignored-files file) + (with-temp-buffer + (insert-file-contents file) + (when-let* ((require-lines (lm-header-multiline "package-requires"))) + (thread-last + (mapconcat #'identity require-lines " ") + package-read-from-string + lm--prepare-package-dependencies + (nconc deps) + (setq deps)))))) (dolist (dep deps) (cl-callf version-to-list (cadr dep))) (setf missing (package-vc-install-dependencies (delete-dups deps))) @@ -459,8 +538,7 @@ documentation and marking the package as installed." missing))) (let ((default-directory (file-name-as-directory pkg-dir)) - (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir)) - (pkg-spec (package-vc--desc->spec pkg-desc))) + (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir))) ;; Generate autoloads (let* ((name (package-desc-name pkg-desc)) (auto-name (format "%s-autoloads.el" name)) @@ -483,11 +561,22 @@ documentation and marking the package as installed." ;; Generate package file (package-vc--generate-description-file pkg-desc pkg-file) + ;; Process :make and :shell-command arguments before building documentation + (when (or (eq package-vc-allow-build-commands t) + (memq (package-desc-name pkg-desc) + package-vc-allow-build-commands)) + (package-vc--make pkg-spec pkg-desc)) + ;; Detect a manual (when (executable-find "install-info") (dolist (doc-file (ensure-list (plist-get pkg-spec :doc))) (package-vc--build-documentation pkg-desc doc-file)))) + ;; Remove any previous instance of PKG-DESC from `package-alist' + (let ((pkgs (assq (package-desc-name pkg-desc) package-alist))) + (when pkgs + (setf (cdr pkgs) (seq-remove #'package-vc-p (cdr pkgs))))) + ;; Update package-alist. (let ((new-desc (package-load-descriptor pkg-dir))) ;; Activation has to be done before compilation, so that if we're @@ -538,6 +627,8 @@ and return nil if it cannot reasonably guess." (and url (alist-get url package-vc-heuristic-alist nil nil #'string-match-p))) +(declare-function project-remember-projects-under "project" (dir &optional recursive)) + (defun package-vc--clone (pkg-desc pkg-spec dir rev) "Clone the package PKG-DESC whose spec is PKG-SPEC into the directory DIR. REV specifies a specific revision to checkout. This overrides the `:branch' @@ -559,6 +650,11 @@ attribute in PKG-SPEC." (or (and (not (eq rev :last-release)) rev) branch)) (error "Failed to clone %s from %s" name url)))) + (when package-vc-register-as-project + (let ((default-directory dir)) + (require 'project) + (project-remember-projects-under dir))) + ;; Check out the latest release if requested (when (eq rev :last-release) (if-let ((release-rev (package-vc--release-rev pkg-desc))) @@ -666,7 +762,10 @@ installed package." ;;;###autoload (defun package-vc-upgrade-all () - "Attempt to upgrade all installed VC packages." + "Upgrade all installed VC packages. + +This may fail if the local VCS state of one of the packages +conflicts with its remote repository state." (interactive) (dolist (package package-alist) (dolist (pkg-desc (cdr package)) @@ -676,7 +775,10 @@ installed package." ;;;###autoload (defun package-vc-upgrade (pkg-desc) - "Attempt to upgrade the package PKG-DESC." + "Upgrade the package described by PKG-DESC from package's VC repository. + +This may fail if the local VCS state of the package conflicts +with the remote repository state." (interactive (list (package-vc--read-package-desc "Upgrade VC package: " t))) ;; HACK: To run `package-vc--unpack-1' after checking out the new ;; revision, we insert a hook into `vc-post-command-functions', and @@ -739,34 +841,45 @@ If no such revision can be found, return nil." ;;;###autoload (defun package-vc-install (package &optional rev backend name) - "Fetch a PACKAGE and set it up for using with Emacs. - -If PACKAGE is a string containing an URL, download the package -from the repository at that URL; the function will try to guess -the name of the package from the URL. This can be overridden by -passing the optional argument NAME. If PACKAGE is a cons-cell, -it should have the form (NAME . SPEC), where NAME is a symbol -indicating the package name and SPEC is a plist as described in -`package-vc-selected-packages'. Otherwise PACKAGE should be a -symbol whose name is the package name, and the URL for the -package will be taken from the package's metadata. + "Fetch a package described by PACKAGE and set it up for use with Emacs. + +PACKAGE specifies which package to install, where to find its +source repository and how to build it. + +If PACKAGE is a symbol, install the package with that name +according to metadata that package archives provide for it. This +is the simplest way to call this function, but it only works if +the package you want to install is listed in a package archive +you have configured. + +If PACKAGE is a string, it specifies the URL of the package +repository. In this case, optional argument BACKEND specifies +the VC backend to use for cloning the repository; if it's nil, +this function tries to infer which backend to use according to +the value of `package-vc-heuristic-alist' and if that fails it +uses `package-vc-default-backend'. Optional argument NAME +specifies the package name in this case; if it's nil, this +package uses `file-name-base' on the URL to obtain the package +name, otherwise NAME is the package name as a symbol. + +PACKAGE can also be a cons cell (PNAME . SPEC) where PNAME is the +package name as a symbol, and SPEC is a plist that specifies how +to fetch and build the package. For possible values, see the +subsection \"Specifying Package Sources\" in the Info +node `(emacs)Fetching Package Sources'. By default, this function installs the last revision of the package available from its repository. If REV is a string, it -describes the revision to install, as interpreted by the VC -backend. The special value `:last-release' (interactively, the -prefix argument), will use the commit of the latest release, if -it exists. The last release is the latest revision which changed -the \"Version:\" header of the package's main Lisp file. - -Optional argument BACKEND specifies the VC backend to use for cloning -the package's repository; this is only possible if NAME-OR-URL is a URL, -a string. If BACKEND is omitted or nil, the function -uses `package-vc-heuristic-alist' to guess the backend. -Note that by default, a VC package will be prioritized over a -regular package, but it will not remove a VC package. - -\(fn PACKAGE &optional REV BACKEND)" +describes the revision to install, as interpreted by the relevant +VC backend. The special value `:last-release' (interactively, +the prefix argument), says to use the commit of the latest +release, if it exists. The last release is the latest revision +which changed the \"Version:\" header of the package's main Lisp +file. + +If you use this function to install a package that you also have +installed from a package archive, the version this function +installs takes precedence." (interactive (progn ;; Initialize the package system to get the list of package @@ -829,7 +942,6 @@ for the last released version of the package." (lambda (dir) (or (not (file-exists-p dir)) (directory-empty-p dir)))) (and current-prefix-arg :last-release)))) - (setf directory (expand-file-name directory)) (package-vc--archives-initialize) (let ((pkg-spec (or (package-vc--desc->spec pkg-desc) (and-let* ((extras (package-desc-extras pkg-desc)) @@ -842,18 +954,19 @@ for the last released version of the package." (find-file directory))) ;;;###autoload -(defun package-vc-install-from-checkout (dir name) - "Set up the package NAME in DIR by linking it into the ELPA directory. +(defun package-vc-install-from-checkout (dir &optional name) + "Install the package NAME from its source directory DIR. +NAME defaults to the base name of DIR. Interactively, prompt the user for DIR, which should be a directory under version control, typically one created by `package-vc-checkout'. If invoked interactively with a prefix argument, prompt the user -for the NAME of the package to set up. Otherwise infer the package -name from the base name of DIR." - (interactive (let ((dir (read-directory-name "Directory: "))) - (list dir - (if current-prefix-arg - (read-string "Package name: ") - (file-name-base (directory-file-name dir)))))) +for the NAME of the package to set up." + (interactive (let* ((dir (read-directory-name "Directory: ")) + (base (file-name-base (directory-file-name dir)))) + (list dir (and current-prefix-arg + (read-string + (format-prompt "Package name" base) + nil nil base))))) (unless (vc-responsible-backend dir) (user-error "Directory %S is not under version control" dir)) (package-vc--archives-initialize) @@ -885,13 +998,17 @@ prompt for the name of the package to rebuild." ;;;###autoload (defun package-vc-prepare-patch (pkg-desc subject revisions) - "Send patch for REVISIONS to maintainer of the package PKG using SUBJECT. -The function uses `vc-prepare-patch', passing SUBJECT and -REVISIONS directly. PKG-DESC must be a package description. + "Email patches for REVISIONS to maintainer of package PKG-DESC using SUBJECT. + +PKG-DESC is a package descriptor and SUBJECT is the subject of +the message. + Interactively, prompt for PKG-DESC, SUBJECT, and REVISIONS. When invoked with a numerical prefix argument, use the last N revisions. When invoked interactively in a Log View buffer with -marked revisions, use those." +marked revisions, use those. + +See also `vc-prepare-patch'." (interactive (list (package-vc--read-package-desc "Package to prepare a patch for: " t) (and (not vc-prepare-patches-separately) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 5fe018700a4..fa9903e13e3 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -378,10 +378,8 @@ If so, and variable `package-check-signature' is `allow-unsigned', return `allow-unsigned', otherwise return the value of variable `package-check-signature'." (if (eq package-check-signature 'allow-unsigned) - (progn - (require 'epg-config) - (and (epg-find-configuration 'OpenPGP) - 'allow-unsigned)) + (and (epg-find-configuration 'OpenPGP) + 'allow-unsigned) package-check-signature)) (defcustom package-unsigned-archives nil @@ -611,7 +609,7 @@ package." (package-archive-priority (package-desc-archive pkg-desc))) (defun package--parse-elpaignore (pkg-desc) - "Return the of regular expression to match files ignored by PKG-DESC." + "Return a list of regular expressions to match files ignored by PKG-DESC." (let* ((pkg-dir (file-name-as-directory (package-desc-dir pkg-desc))) (ignore (expand-file-name ".elpaignore" pkg-dir)) files) @@ -903,13 +901,7 @@ correspond to previously loaded files." (when reload (package--reload-previously-loaded pkg-desc)) (with-demoted-errors "Error loading autoloads: %s" - (load (package--autoloads-file-name pkg-desc) nil t)) - ;; FIXME: Since 2013 (commit 4fac34cee97a), the autoload files take - ;; care of changing the `load-path', so maybe it's time to - ;; remove this fallback code? - (unless (or (member (file-name-as-directory pkg-dir) load-path) - (member (directory-file-name pkg-dir) load-path)) - (add-to-list 'load-path pkg-dir))) + (load (package--autoloads-file-name pkg-desc) nil t))) ;; Add info node. (when (file-exists-p (expand-file-name "dir" pkg-dir)) ;; FIXME: not the friendliest, but simple. @@ -970,7 +962,6 @@ Newer versions are always activated, regardless of FORCE." "Untar the current buffer. This uses `tar-untar-buffer' from Tar mode. All files should untar into a directory named DIR; otherwise, signal an error." - (require 'tar-mode) (tar-mode) ;; Make sure everything extracts into DIR. (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/")) @@ -1158,27 +1149,8 @@ Signal an error if the entire string was not used." (error "Can't read whole string")) (end-of-file expr)))) -(defun package--prepare-dependencies (deps) - "Turn DEPS into an acceptable list of dependencies. - -Any parts missing a version string get a default version string -of \"0\" (meaning any version) and an appropriate level of lists -is wrapped around any parts requiring it." - (cond - ((not (listp deps)) - (error "Invalid requirement specifier: %S" deps)) - (t (mapcar (lambda (dep) - (cond - ((symbolp dep) `(,dep "0")) - ((stringp dep) - (error "Invalid requirement specifier: %S" dep)) - ((and (listp dep) (null (cdr dep))) - (list (car dep) "0")) - (t dep))) - deps)))) - (declare-function lm-header "lisp-mnt" (header)) -(declare-function lm-header-multiline "lisp-mnt" (header)) +(declare-function lm-package-requires "lisp-mnt" (&optional file)) (declare-function lm-website "lisp-mnt" (&optional file)) (declare-function lm-keywords-list "lisp-mnt" (&optional file)) (declare-function lm-maintainers "lisp-mnt" (&optional file)) @@ -1200,9 +1172,15 @@ boundaries." ;; the earliest in version 31.1. The idea is to phase out the ;; requirement for a "footer line" without unduly impacting users ;; on earlier Emacs versions. See Bug#26490 for more details. - (unless (search-forward (concat ";;; " file-name ".el ends here")) - (lwarn '(package package-format) :warning - "Package lacks a terminating comment")) + (unless (search-forward (concat ";;; " file-name ".el ends here") nil 'move) + ;; Starting in Emacs 30.1, avoid warning if the minimum Emacs + ;; version is specified as 30.1 or later. + (let ((min-emacs (cadar (seq-filter (lambda (x) (eq (car x) 'emacs)) + (lm-package-requires))))) + (when (or (null min-emacs) + (version< min-emacs "30.1")) + (lwarn '(package package-format) :warning + "Package lacks a terminating comment")))) ;; Try to include a trailing newline. (forward-line) (narrow-to-region start (point)) @@ -1221,15 +1199,13 @@ boundaries." (error "Package lacks a \"Version\" or \"Package-Version\" header"))) (package-desc-from-define file-name pkg-version desc - (and-let* ((require-lines (lm-header-multiline "package-requires"))) - (package--prepare-dependencies - (package-read-from-string (mapconcat #'identity require-lines " ")))) + (lm-package-requires) :kind 'single :url website :keywords keywords :maintainer - ;; For backward compatibility, use a single string if there's only - ;; one maintainer (the most common case). + ;; For backward compatibility, use a single cons-cell if + ;; there's only one maintainer (the most common case). (let ((maints (lm-maintainers))) (if (cdr maints) maints (car maints))) :authors (lm-authors))))) @@ -1237,15 +1213,14 @@ boundaries." "Read a `define-package' form in current buffer. Return the pkg-desc, with desc-kind set to KIND." (goto-char (point-min)) - (unwind-protect - (let* ((pkg-def-parsed (read (current-buffer))) - (pkg-desc - (when (eq (car pkg-def-parsed) 'define-package) - (apply #'package-desc-from-define - (append (cdr pkg-def-parsed)))))) - (when pkg-desc - (setf (package-desc-kind pkg-desc) kind) - pkg-desc)))) + (let* ((pkg-def-parsed (read (current-buffer))) + (pkg-desc + (when (eq (car pkg-def-parsed) 'define-package) + (apply #'package-desc-from-define + (append (cdr pkg-def-parsed)))))) + (when pkg-desc + (setf (package-desc-kind pkg-desc) kind) + pkg-desc))) (declare-function tar-get-file-descriptor "tar-mode" (file)) (declare-function tar--extract "tar-mode" (descriptor)) @@ -1730,18 +1705,26 @@ The variable `package-load-list' controls which packages to load." package-quickstart-file)))) ;; The quickstart file presumes that it has a blank slate, ;; so don't use it if we already activated some packages. - (if (and qs (not (bound-and-true-p package-activated-list))) - ;; Skip load-source-file-function which would slow us down by a factor - ;; 2 when loading the .el file (this assumes we were careful to - ;; save this file so it doesn't need any decoding). - (let ((load-source-file-function nil)) - (unless (boundp 'package-activated-list) - (setq package-activated-list nil)) - (load qs nil 'nomessage)) - (require 'package) - (package--activate-all))))) + (or (and qs (not (bound-and-true-p package-activated-list)) + ;; Skip `load-source-file-function' which would slow us down by + ;; a factor 2 when loading the .el file (this assumes we were + ;; careful to save this file so it doesn't need any decoding). + (with-demoted-errors "Error during quickstart: %S" + (let ((load-source-file-function nil)) + (unless (boundp 'package-activated-list) + (setq package-activated-list nil)) + (load qs nil 'nomessage) + t))) + (progn + (require 'package) + ;; Silence the "unknown function" warning when this is compiled + ;; inside `loaddefs.el'. + ;; FIXME: We use `with-no-warnings' because the effect of + ;; `declare-function' is currently not scoped, so if we use + ;; it here, we end up with a redefinition warning instead :-) + (with-no-warnings + (package--activate-all))))))) -;;;###autoload (defun package--activate-all () (dolist (elt (package--alist)) (condition-case err @@ -1992,8 +1975,11 @@ Used to populate `package-selected-packages'." (defun package--save-selected-packages (&optional value) "Set and save `package-selected-packages' to VALUE." - (when value - (setq package-selected-packages value)) + (when (or value after-init-time) + ;; It is valid to set it to nil, for example when the last package + ;; is uninstalled. But it shouldn't be done at init time, to + ;; avoid overwriting configurations that haven't yet been loaded. + (setq package-selected-packages (sort value #'string<))) (if after-init-time (customize-save-variable 'package-selected-packages package-selected-packages) (add-hook 'after-init-hook #'package--save-selected-packages))) @@ -2268,25 +2254,26 @@ had been enabled." ;;;###autoload (defun package-upgrade (name) - "Upgrade package NAME if a newer version exists. - -Currently, packages which are part of the Emacs distribution -cannot be upgraded that way. To enable upgrades of such a -package using this command, first upgrade the package to a -newer version from ELPA by using `\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'." + "Upgrade package NAME if a newer version exists." (interactive (list (completing-read - "Upgrade package: " (package--upgradeable-packages) nil t))) + "Upgrade package: " (package--upgradeable-packages t) nil t))) (let* ((package (if (symbolp name) name (intern name))) - (pkg-desc (cadr (assq package package-alist)))) - (if (package-vc-p pkg-desc) + (pkg-desc (cadr (assq package package-alist))) + (package-install-upgrade-built-in (not pkg-desc))) + ;; `pkg-desc' will be nil when the package is an "active built-in". + (if (and pkg-desc (package-vc-p pkg-desc)) (package-vc-upgrade pkg-desc) - (package-delete pkg-desc 'force 'dont-unselect) - (package-install package 'dont-select)))) - -(defun package--upgradeable-packages () + (when pkg-desc + (package-delete pkg-desc 'force 'dont-unselect)) + (package-install package + ;; An active built-in has never been "selected" + ;; before. Mark it as installed explicitly. + (and pkg-desc 'dont-select))))) + +(defun package--upgradeable-packages (&optional include-builtins) ;; Initialize the package system to get the list of package ;; symbols for completion. (package--archives-initialize) @@ -2297,11 +2284,21 @@ newer version from ELPA by using `\\<package-menu-mode-map>\\[package-menu-mark- (or (let ((available (assq (car elt) package-archive-contents))) (and available - (version-list-< - (package-desc-version (cadr elt)) - (package-desc-version (cadr available))))) - (package-vc-p (cadr (assq (car elt) package-alist))))) - package-alist))) + (or (and + include-builtins + (not (package-desc-version (cadr elt)))) + (version-list-< + (package-desc-version (cadr elt)) + (package-desc-version (cadr available)))))) + (package-vc-p (cadr elt)))) + (if include-builtins + (append package-alist + (mapcan + (lambda (elt) + (when (not (assq (car elt) package-alist)) + (list (list (car elt) (package--from-builtin elt))))) + package--builtins)) + package-alist)))) ;;;###autoload (defun package-upgrade-all (&optional query) @@ -2311,8 +2308,9 @@ interactively, QUERY is always true. Currently, packages which are part of the Emacs distribution are not upgraded by this command. To enable upgrading such a package -using this command, first upgrade the package to a newer version -from ELPA by using `\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'." +using this command, first upgrade the package to a newer version +from ELPA by either using `\\[package-upgrade]' or +`\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'." (interactive (list (not noninteractive))) (package-refresh-contents) (let ((upgradeable (package--upgradeable-packages))) @@ -2328,12 +2326,25 @@ from ELPA by using `\\<package-menu-mode-map>\\[package-menu-mark-install]' afte (mapc #'package-upgrade upgradeable)))) (defun package--dependencies (pkg) - "Return a list of all dependencies PKG has. -This is done recursively." - ;; Can we have circular dependencies? Assume "nope". - (when-let* ((desc (cadr (assq pkg package-archive-contents))) - (deps (mapcar #'car (package-desc-reqs desc)))) - (delete-dups (apply #'nconc deps (mapcar #'package--dependencies deps))))) + "Return a list of all transitive dependencies of PKG. +If PKG is a package descriptor, the return value is a list of +package descriptors. If PKG is a symbol designating a package, +the return value is a list of symbols designating packages." + (when-let* ((desc (if (package-desc-p pkg) pkg + (cadr (assq pkg package-archive-contents))))) + ;; Can we have circular dependencies? Assume "nope". + (let ((all (named-let more ((pkg-desc desc)) + (let (deps) + (dolist (req (package-desc-reqs pkg-desc)) + (setq deps (nconc + (catch 'found + (dolist (p (apply #'append (mapcar #'cdr (package--alist)))) + (when (and (string= (car req) (package-desc-name p)) + (version-list-<= (cadr req) (package-desc-version p))) + (throw 'found (more p))))) + deps))) + (delete-dups (cons pkg-desc deps)))))) + (remq pkg (mapcar (if (package-desc-p pkg) #'identity #'package-desc-name) all))))) (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. @@ -2469,7 +2480,9 @@ 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\\'") + for file in (directory-files-recursively dir + ;; Exclude lockfiles + (rx bos (or (and "." (not "#")) (not ".")) (* nonl) ".el" eos)) do (comp-clean-up-stale-eln (comp-el-to-eln-filename file)))) (if (file-symlink-p (directory-file-name dir)) (delete-file (directory-file-name dir)) @@ -2501,8 +2514,12 @@ If NOSAVE is non-nil, the package is not removed from nil t))) (list (cdr (assoc package-name package-table)) current-prefix-arg nil)))) - (let ((dir (package-desc-dir pkg-desc)) - (name (package-desc-name pkg-desc)) + (let* ((dir (package-desc-dir pkg-desc)) + (name (package-desc-name pkg-desc)) + (new-package-alist (let ((pkgs (assq name package-alist))) + (if (null (remove pkg-desc (cdr pkgs))) + (remq pkgs package-alist) + package-alist))) pkg-used-elsewhere-by) ;; If the user is trying to delete this package, they definitely ;; don't want it marked as selected, so we remove it from @@ -2521,7 +2538,8 @@ If NOSAVE is non-nil, the package is not removed from (package-desc-full-name pkg-desc))) ((and (null force) (setq pkg-used-elsewhere-by - (package--used-elsewhere-p pkg-desc))) + (let ((package-alist new-package-alist)) + (package--used-elsewhere-p pkg-desc)))) ;See bug#65475 ;; Don't delete packages used as dependency elsewhere. (error "Package `%s' is used by `%s' as dependency, not deleting" (package-desc-full-name pkg-desc) @@ -2542,10 +2560,7 @@ If NOSAVE is non-nil, the package is not removed from (when (file-exists-p file) (delete-file file)))) ;; Update package-alist. - (let ((pkgs (assq name package-alist))) - (delete pkg-desc pkgs) - (unless (cdr pkgs) - (setq package-alist (delq pkgs package-alist)))) + (setq package-alist new-package-alist) (package--quickstart-maybe-refresh) (message "Package `%s' deleted." (package-desc-full-name pkg-desc)))))) @@ -2623,6 +2638,57 @@ will be deleted." removable)) (message "Nothing to autoremove"))))) +(defun package-isolate (packages &optional temp-init) + "Start an uncustomised Emacs and only load a set of PACKAGES. +If TEMP-INIT is non-nil, or when invoked with a prefix argument, +the Emacs user directory is set to a temporary directory." + (interactive + (cl-loop for p in (cl-loop for p in (package--alist) append (cdr p)) + unless (package-built-in-p p) + collect (cons (package-desc-full-name p) p) into table + finally return + (list (cl-loop for c in (completing-read-multiple + "Isolate packages: " table + nil t) + collect (alist-get c table nil nil #'string=)) + current-prefix-arg))) + (let* ((name (concat "package-isolate-" + (mapconcat #'package-desc-full-name packages ","))) + (all-packages (delete-consecutive-dups + (sort (append packages (mapcan #'package--dependencies packages)) + (lambda (p0 p1) + (string< (package-desc-name p0) (package-desc-name p1)))))) + initial-scratch-message package-load-list) + (with-temp-buffer + (insert ";; This is an isolated testing environment, with these packages enabled:\n\n") + (dolist (package all-packages) + (push (list (package-desc-name package) + (package-version-join (package-desc-version package))) + package-load-list) + (insert ";; - " (package-desc-full-name package)) + (unless (memq package packages) + (insert " (dependency)")) + (insert "\n")) + (insert "\n") + (setq initial-scratch-message (buffer-string))) + (apply #'start-process (concat "*" name "*") nil + (list (expand-file-name invocation-name invocation-directory) + "--quick" "--debug-init" + "--init-directory" (if temp-init + (make-temp-file name t) + user-emacs-directory) + (format "--eval=%S" + `(progn + (setq initial-scratch-message ,initial-scratch-message) + + (require 'package) + ,@(mapcar + (lambda (dir) + `(add-to-list 'package-directory-list ,dir)) + (cons package-user-dir package-directory-list)) + (setq package-load-list ',package-load-list) + (package-initialize))))))) + ;;;; Package description buffer. @@ -2738,7 +2804,8 @@ Helper function for `describe-package'." (status (if desc (package-desc-status desc) "orphan")) (incompatible-reason (package--incompatible-p desc)) (signed (if desc (package-desc-signed desc))) - (maintainer (cdr (assoc :maintainer extras))) + (maintainers (or (cdr (assoc :maintainers extras)) + (list (cdr (assoc :maintainer extras))))) (authors (cdr (assoc :authors extras))) (news (and-let* (pkg-dir ((not built-in)) @@ -2873,19 +2940,21 @@ Helper function for `describe-package'." 'action 'package-keyword-button-action) (insert " ")) (insert "\n")) - (when maintainer - (package--print-help-section "Maintainer") - (package--print-email-button maintainer)) - (when authors + (when maintainers + (unless (proper-list-p maintainers) + (setq maintainers (list maintainers))) (package--print-help-section - (if (= (length authors) 1) - "Author" - "Authors")) - (package--print-email-button (pop authors)) - ;; If there's more than one author, indent the rest correctly. - (dolist (name authors) - (insert (make-string 13 ?\s)) - (package--print-email-button name))) + (if (cdr maintainers) "Maintainers" "Maintainer")) + (dolist (maintainer maintainers) + (when (bolp) + (insert (make-string 13 ?\s))) + (package--print-email-button maintainer))) + (when authors + (package--print-help-section (if (cdr authors) "Authors" "Author")) + (dolist (author authors) + (when (bolp) + (insert (make-string 13 ?\s))) + (package--print-email-button author))) (let* ((all-pkgs (append (cdr (assq name package-alist)) (cdr (assq name package-archive-contents)) (let ((bi (assq name package--builtins))) @@ -3146,8 +3215,7 @@ The most useful commands here are: `[("Package" ,package-name-column-width package-menu--name-predicate) ("Version" ,package-version-column-width package-menu--version-predicate) ("Status" ,package-status-column-width package-menu--status-predicate) - ,@(if (cdr package-archives) - `(("Archive" ,package-archive-column-width package-menu--archive-predicate))) + ("Archive" ,package-archive-column-width package-menu--archive-predicate) ("Description" 0 package-menu--description-predicate)]) (setq tabulated-list-padding 2) (setq tabulated-list-sort-key (cons "Status" nil)) @@ -3587,9 +3655,8 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." (package-desc-version pkg))) 'font-lock-face face) ,(propertize status 'font-lock-face face) - ,@(if (cdr package-archives) - (list (propertize (or (package-desc-archive pkg) "") - 'font-lock-face face))) + ,(propertize (or (package-desc-archive pkg) "") + 'font-lock-face face) ,(propertize (package-desc-summary pkg) 'font-lock-face 'package-description)]))) @@ -4538,8 +4605,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-true-file-name " pfile ")\ -\(load-file-name " pfile "))\n") + (insert "(let* ((load-file-name " pfile ")\ +\(load-true-file-name load-file-name))\n") (insert-file-contents file) ;; Fixup the special #$ reader form and throw away comments. (while (re-search-forward "#\\$\\|^;\\(.*\n\\)" nil 'move) @@ -4645,6 +4712,7 @@ will be signaled in that case." (package--print-email-button maint) (string-trim (substring-no-properties (buffer-string)))))))) +;;;###autoload (defun package-report-bug (desc) "Prepare a message to send to the maintainers of a package. DESC must be a `package-desc' object." diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 810b13f61d6..d5f7249e527 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -609,6 +609,16 @@ recording whether the var has been referenced by earlier parts of the match." (symbolp . byte-code-function-p) (symbolp . compiled-function-p) (symbolp . recordp) + (null . integerp) + (null . numberp) + (null . numberp) + (null . consp) + (null . arrayp) + (null . vectorp) + (null . stringp) + (null . byte-code-function-p) + (null . compiled-function-p) + (null . recordp) (integerp . consp) (integerp . arrayp) (integerp . vectorp) @@ -947,7 +957,7 @@ Otherwise, it defers to REST which is a list of branches of the form (let ((code (pcase--u1 matches code vars rest))) (if (eq upat '_) code (macroexp-warn-and-return - "Pattern t is deprecated. Use `_' instead" + (format-message "Pattern t is deprecated. Use `_' instead") code nil nil upat)))) ((eq upat 'pcase--dontcare) :pcase--dontcare) ((memq (car-safe upat) '(guard pred)) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index e6e3cd6c6f4..a93e634c685 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -25,7 +25,6 @@ ;;; Code: (require 'cl-lib) -(defvar font-lock-verbose) (defgroup pp nil "Pretty printer for Emacs Lisp." @@ -52,53 +51,239 @@ Note that this could slow down `pp' considerably when formatting large lists." :type 'boolean :version "29.1") +(make-obsolete-variable 'pp-use-max-width 'pp-default-function "30.1") + +(defcustom pp-default-function #'pp-fill + ;; FIXME: The best pretty printer to use depends on the use-case + ;; so maybe we should allow callers to specify what they want (maybe with + ;; options like `fast', `compact', `code', `data', ...) and these + ;; can then be mapped to actual pretty-printing algorithms. + ;; Then again, callers can just directly call the corresponding function. + "Function that `pp' should dispatch to for pretty printing. +That function can be called in one of two ways: +- with a single argument, which it should insert and pretty-print at point. +- with two arguments which delimit a region containing Lisp sexps + which should be pretty-printed. +In both cases, the function can presume that the buffer is setup for +Lisp syntax." + :type '(choice + (const :tag "Fit within `fill-column'" pp-fill) + (const :tag "Emacs<29 algorithm, fast and good enough" pp-28) + (const :tag "Work hard for code (slow on large inputs)" + pp-emacs-lisp-code) + (const :tag "`pp-emacs-lisp-code' if `pp-use-max-width' else `pp-28'" + pp-29) + function) + :version "30.1") (defvar pp--inhibit-function-formatting nil) +;; There are basically two APIs for a pretty-printing function: +;; +;; - either the function takes an object (and prints it in addition to +;; prettifying it). +;; - or the function takes a region containing an already printed object +;; and prettifies its content. +;; +;; `pp--object' and `pp--region' are helper functions to convert one +;; API to the other. + + +(defun pp--object (object region-function) + "Pretty-print OBJECT at point. +The prettifying is done by REGION-FUNCTION which is +called with two positions as arguments and should fold lines +within that region. Returns the result as a string." + (let ((print-escape-newlines pp-escape-newlines) + (print-quoted t) + (beg (point))) + ;; FIXME: In many cases it would be preferable to use `cl-prin1' here. + (prin1 object (current-buffer)) + (funcall region-function beg (point)))) + +(defun pp--region (beg end object-function) + "Pretty-print the object(s) contained within BEG..END. +OBJECT-FUNCTION is called with a single object as argument +and should pretty print it at point into the current buffer." + (save-excursion + (with-restriction beg end + (goto-char (point-min)) + (while + (progn + ;; We'll throw away all the comments within objects, but let's + ;; try at least to preserve the comments between objects. + (forward-comment (point-max)) + (let ((beg (point)) + (object (ignore-error end-of-buffer + (list (read (current-buffer)))))) + (when (consp object) + (delete-region beg (point)) + (funcall object-function (car object)) + t))))))) + +(defun pp-29 (beg-or-sexp &optional end) ;FIXME: Better name? + "Prettify the current region with printed representation of a Lisp object. +Uses the pretty-printing algorithm that was standard in Emacs-29, +which, depending on `pp-use-max-width', will either use `pp-28' +or `pp-emacs-lisp-code'." + (if pp-use-max-width + (let ((pp--inhibit-function-formatting t)) ;FIXME: Why? + (pp-emacs-lisp-code beg-or-sexp end)) + (pp-28 beg-or-sexp end))) + ;;;###autoload -(defun pp-to-string (object) +(defun pp-to-string (object &optional pp-function) "Return a string containing the pretty-printed representation of OBJECT. OBJECT can be any Lisp object. Quoting characters are used as needed -to make output that `read' can handle, whenever this is possible." - (if pp-use-max-width - (let ((pp--inhibit-function-formatting t)) - (with-temp-buffer - (pp-emacs-lisp-code object) - (buffer-string))) - (with-temp-buffer - (lisp-mode-variables nil) - (set-syntax-table emacs-lisp-mode-syntax-table) - (let ((print-escape-newlines pp-escape-newlines) - (print-quoted t)) - (prin1 object (current-buffer))) - (pp-buffer) - (buffer-string)))) +to make output that `read' can handle, whenever this is possible. +Optional argument PP-FUNCTION overrides `pp-default-function'." + (with-temp-buffer + (lisp-mode-variables nil) + (set-syntax-table emacs-lisp-mode-syntax-table) + (funcall (or pp-function pp-default-function) object) + ;; Preserve old behavior of (usually) finishing with a newline. + (unless (bolp) (insert "\n")) + (buffer-string))) + +(defun pp--within-fill-column-p () + "Return non-nil if point is within `fill-column'." + ;; Try and make it O(fill-column) rather than O(current-column), + ;; so as to avoid major slowdowns on long lines. + ;; FIXME: This doesn't account for invisible text or `display' properties :-( + (and (save-excursion + (re-search-backward + "^\\|\n" (max (point-min) (- (point) fill-column)) t)) + (<= (current-column) fill-column))) + +(defun pp-fill (beg &optional end) + "Break lines in Lisp code between BEG and END so it fits within `fill-column'. +Presumes the current buffer has syntax and indentation properly +configured for that. +Designed under the assumption that the region occupies a single line, +tho it should also work if that's not the case. +Can also be called with a single argument, in which case +it inserts and pretty-prints that arg at point." + (interactive "r") + (if (null end) (pp--object beg #'pp-fill) + (goto-char beg) + (let ((end (copy-marker end t)) + (newline (lambda () + (skip-chars-forward ")]}") + (unless (save-excursion (skip-chars-forward " \t") (eolp)) + (insert "\n") + (indent-according-to-mode))))) + (while (progn (forward-comment (point-max)) + (< (point) end)) + (let ((beg (point)) + ;; Whether we're in front of an element with paired delimiters. + ;; Can be something funky like #'(lambda ..) or ,'#s(...) + ;; Or also #^[..]. + (paired (when (looking-at "['`,#]*[[:alpha:]^]*\\([({[\"]\\)") + (match-beginning 1)))) + ;; Go to the end of the sexp. + (goto-char (or (scan-sexps (or paired (point)) 1) end)) + (unless + (and + ;; The sexp is all on a single line. + (save-excursion (not (search-backward "\n" beg t))) + ;; And its end is within `fill-column'. + (or (pp--within-fill-column-p) + ;; If the end of the sexp is beyond `fill-column', + ;; try to move the sexp to its own line. + (and + (save-excursion + (goto-char beg) + (if (save-excursion (skip-chars-backward " \t({[',") + (bolp)) + ;; The sexp was already on its own line. + nil + (skip-chars-backward " \t") + (setq beg (copy-marker beg t)) + (if paired (setq paired (copy-marker paired t))) + ;; We could try to undo this insertion if it + ;; doesn't reduce the indentation depth, but I'm + ;; not sure it's worth the trouble. + (insert "\n") (indent-according-to-mode) + t)) + ;; Check again if we moved the whole exp to a new line. + (pp--within-fill-column-p)))) + ;; The sexp is spread over several lines, and/or its end is + ;; (still) beyond `fill-column'. + (when (and paired (not (eq ?\" (char-after paired)))) + ;; The sexp has sub-parts, so let's try and spread + ;; them over several lines. + (save-excursion + (goto-char beg) + (when (looking-at "(\\([^][()\" \t\n;']+\\)") + ;; Inside an expression of the form (SYM ARG1 + ;; ARG2 ... ARGn) where SYM has a `lisp-indent-function' + ;; property that's a number, insert a newline after + ;; the corresponding ARGi, because it tends to lead to + ;; more natural and less indented code. + (let* ((sym (intern-soft (match-string 1))) + (lif (and sym (get sym 'lisp-indent-function)))) + (if (eq lif 'defun) (setq lif 2)) + (when (natnump lif) + (goto-char (match-end 0)) + ;; Do nothing if there aren't enough args. + (ignore-error scan-error + (forward-sexp lif) + (funcall newline)))))) + (save-excursion + (pp-fill (1+ paired) (1- (point))))) + ;; Now the sexp either ends beyond `fill-column' or is + ;; spread over several lines (or both). Either way, the + ;; rest of the line should be moved to its own line. + (funcall newline))))))) ;;;###autoload (defun pp-buffer () "Prettify the current buffer with printed representation of a Lisp object." (interactive) - (goto-char (point-min)) - (while (not (eobp)) - (cond - ((ignore-errors (down-list 1) t) - (save-excursion - (backward-char 1) - (skip-chars-backward "'`#^") - (when (and (not (bobp)) (memq (char-before) '(?\s ?\t ?\n))) + ;; The old code used `indent-sexp' which mostly works "anywhere", + ;; so let's make sure we also work right in buffers that aren't + ;; setup specifically for Lisp. + (if (and (eq (syntax-table) emacs-lisp-mode-syntax-table) + (eq indent-line-function #'lisp-indent-line)) + (funcall pp-default-function (point-min) (point-max)) + (with-syntax-table emacs-lisp-mode-syntax-table + (let ((indent-line-function #'lisp-indent-line)) + (funcall pp-default-function (point-min) (point-max))))) + ;; Preserve old behavior of (usually) finishing with a newline and + ;; with point at BOB. + (goto-char (point-max)) + (unless (bolp) (insert "\n")) + (goto-char (point-min))) + +(defun pp-28 (beg &optional end) ;FIXME: Better name? + "Prettify the current region with printed representation of a Lisp object. +Uses the pretty-printing algorithm that was standard before Emacs-30. +Non-interactively can also be called with a single argument, in which +case that argument will be inserted pretty-printed at point." + (interactive "r") + (if (null end) (pp--object beg #'pp-29) + (with-restriction beg end + (goto-char (point-min)) + (while (not (eobp)) + (cond + ((ignore-errors (down-list 1) t) + (save-excursion + (backward-char 1) + (skip-chars-backward "'`#^") + (when (and (not (bobp)) (memq (char-before) '(?\s ?\t ?\n))) + (delete-region + (point) + (progn (skip-chars-backward " \t\n") (point))) + (insert "\n")))) + ((ignore-errors (up-list 1) t) + (skip-syntax-forward ")") (delete-region (point) - (progn (skip-chars-backward " \t\n") (point))) - (insert "\n")))) - ((ignore-errors (up-list 1) t) - (skip-syntax-forward ")") - (delete-region - (point) - (progn (skip-chars-forward " \t\n") (point))) - (insert ?\n)) - (t (goto-char (point-max))))) - (goto-char (point-min)) - (indent-sexp)) + (progn (skip-chars-forward " \t\n") (point))) + (insert ?\n)) + (t (goto-char (point-max))))) + (goto-char (point-min)) + (indent-sexp)))) ;;;###autoload (defun pp (object &optional stream) @@ -106,14 +291,20 @@ to make output that `read' can handle, whenever this is possible." Quoting characters are printed as needed to make output that `read' can handle, whenever this is possible. -This function does not apply special formatting rules for Emacs -Lisp code. See `pp-emacs-lisp-code' instead. - -By default, this function won't limit the line length of lists -and vectors. Bind `pp-use-max-width' to a non-nil value to do so. +Uses the pretty-printing code specified in `pp-default-function'. Output stream is STREAM, or value of `standard-output' (which see)." - (princ (pp-to-string object) (or stream standard-output))) + (cond + ((and (eq (or stream standard-output) (current-buffer)) + ;; Make sure the current buffer is setup sanely. + (eq (syntax-table) emacs-lisp-mode-syntax-table) + (eq indent-line-function #'lisp-indent-line)) + ;; Skip the buffer->string->buffer middle man. + (funcall pp-default-function object) + ;; Preserve old behavior of (usually) finishing with a newline. + (unless (bolp) (insert "\n"))) + (t + (princ (pp-to-string object) (or stream standard-output))))) ;;;###autoload (defun pp-display-expression (expression out-buffer-name &optional lisp) @@ -220,21 +411,24 @@ Ignores leading comment characters." (pp-macroexpand-expression (pp-last-sexp)))) ;;;###autoload -(defun pp-emacs-lisp-code (sexp) +(defun pp-emacs-lisp-code (sexp &optional end) "Insert SEXP into the current buffer, formatted as Emacs Lisp code. Use the `pp-max-width' variable to control the desired line length. -Note that this could be slow for large SEXPs." +Note that this could be slow for large SEXPs. +Can also be called with two arguments, in which case they're taken to be +the bounds of a region containing Lisp code to pretty-print." (require 'edebug) - (let ((obuf (current-buffer))) - (with-temp-buffer - (emacs-lisp-mode) - (pp--insert-lisp sexp) - (insert "\n") - (goto-char (point-min)) - (indent-sexp) - (while (re-search-forward " +$" nil t) - (replace-match "")) - (insert-into-buffer obuf)))) + (if end (pp--region sexp end #'pp-emacs-lisp-code) + (let ((obuf (current-buffer))) + (with-temp-buffer + (emacs-lisp-mode) + (pp--insert-lisp sexp) + (insert "\n") + (goto-char (point-min)) + (indent-sexp) + (while (re-search-forward " +$" nil t) + (replace-match "")) + (insert-into-buffer obuf))))) (defun pp--insert-lisp (sexp) (cl-case (type-of sexp) diff --git a/lisp/emacs-lisp/range.el b/lisp/emacs-lisp/range.el index 1165fcbbd7d..f441c240a27 100644 --- a/lisp/emacs-lisp/range.el +++ b/lisp/emacs-lisp/range.el @@ -194,7 +194,7 @@ these ranges." (nreverse result))))) (defun range-add-list (ranges list) - "Return a list of ranges that has all articles from both RANGES and LIST. + "Return a list of ranges that has all numbers from both RANGES and LIST. Note: LIST has to be sorted over `<'." (if (not ranges) (range-compress-list list) @@ -249,9 +249,9 @@ Note: LIST has to be sorted over `<'." out))) (defun range-remove (range1 range2) - "Return a range that has all articles from RANGE2 removed from RANGE1. + "Return a range that has all numbers from RANGE2 removed from RANGE1. The returned range is always a list. RANGE2 can also be a unsorted -list of articles. RANGE1 is modified by side effects, RANGE2 is not +list of numbers. RANGE1 is modified by side effects, RANGE2 is not modified." (if (or (null range1) (null range2)) range1 @@ -345,7 +345,7 @@ modified." (defun range-list-intersection (list ranges) "Return a list of numbers in LIST that are members of RANGES. -oLIST is a sorted list." +LIST is a sorted list." (setq ranges (range-normalize ranges)) (let (number result) (while (setq number (pop list)) diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index e64a3dcea1e..39325a3c35e 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -130,6 +130,7 @@ usually more efficient than that of a simplified version: (concat (car parens) (mapconcat \\='regexp-quote strings \"\\\\|\") (cdr parens))))" + (declare (pure t) (side-effect-free t)) (save-match-data ;; Recurse on the sorted list. (let* ((max-lisp-eval-depth 10000) @@ -153,6 +154,7 @@ usually more efficient than that of a simplified version: "Return the depth of REGEXP. This means the number of non-shy regexp grouping constructs \(parenthesized expressions) in REGEXP." + (declare (pure t) (side-effect-free t)) (save-match-data ;; Hack to signal an error if REGEXP does not have balanced parentheses. (string-match regexp "") @@ -269,6 +271,7 @@ Merges keywords to avoid backtracking in Emacs's regexp matcher." CHARS should be a list of characters. If CHARS is the empty list, the return value is a regexp that never matches anything." + (declare (pure t) (side-effect-free t)) ;; The basic idea is to find character ranges. Also we take care in the ;; position of character set meta characters in the character set regexp. ;; diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el index bfd7434be9a..45e2bbf3831 100644 --- a/lisp/emacs-lisp/rmc.el +++ b/lisp/emacs-lisp/rmc.el @@ -126,7 +126,8 @@ (defun read-multiple-choice (prompt choices &optional help-string show-help long-form) "Ask user to select an entry from CHOICES, prompting with PROMPT. -This function allows to ask the user a multiple-choice question. +This function is used to ask the user a question with multiple +choices. CHOICES should be a list of the form (KEY NAME [DESCRIPTION]). KEY is a character the user should type to select the entry. diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 30195cbae32..afc9826eefa 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -26,7 +26,7 @@ ;; The translation to string regexp is done by a macro and does not ;; incur any extra processing during run time. Example: ;; -;; (rx bos (or (not (any "^")) +;; (rx bos (or (not "^") ;; (seq "^" (or " *" "[")))) ;; ;; => "\\`\\(?:[^^]\\|\\^\\(?: \\*\\|\\[\\)\\)" @@ -35,8 +35,43 @@ ;; Olin Shivers's SRE, with concessions to Emacs regexp peculiarities, ;; and the older Emacs package Sregex. +;;; Legacy syntax still accepted by rx: +;; +;; These are constructs from earlier rx and sregex implementations +;; that were mistakes, accidents or just not very good ideas in hindsight. + +;; Obsolete: accepted but not documented +;; +;; Obsolete Preferred +;; -------------------------------------------------------- +;; (not word-boundary) not-word-boundary +;; (not-syntax X) (not (syntax X)) +;; not-wordchar (not wordchar) +;; (not-char ...) (not (any ...)) +;; any nonl, not-newline +;; (repeat N FORM) (= N FORM) +;; (syntax CHARACTER) (syntax NAME) +;; (syntax CHAR-SYM) [1] (syntax NAME) +;; (category chinse-two-byte) (category chinese-two-byte) +;; unibyte ascii +;; multibyte nonascii +;; -------------------------------------------------------- +;; [1] where CHAR-SYM is a symbol with single-character name + +;; Obsolescent: accepted and documented but discouraged +;; +;; Obsolescent Preferred +;; -------------------------------------------------------- +;; (and ...) (seq ...), (: ...), (sequence ...) +;; anything anychar +;; minimal-match, maximal-match lazy ops: ??, *?, +? + +;; FIXME: Prepare a phase-out by emitting compile-time warnings about +;; at least some of the legacy constructs above. + ;;; Code: + ;; The `rx--translate...' functions below return (REGEXP . PRECEDENCE), ;; where REGEXP is a list of string expressions that will be ;; concatenated into a regexp, and PRECEDENCE is one of @@ -126,27 +161,23 @@ Each entry is: (or (cdr (assq name rx--local-definitions)) (get name 'rx-definition))) -(defun rx--expand-def (form) - "FORM expanded (once) if a user-defined construct; otherwise nil." - (cond ((symbolp form) - (let ((def (rx--lookup-def form))) - (and def - (if (cdr def) - (error "Not an `rx' symbol definition: %s" form) - (car def))))) - ((and (consp form) (symbolp (car form))) - (let* ((op (car form)) - (def (rx--lookup-def op))) +(defun rx--expand-def-form (form) + "List FORM expanded (once) if a user-defined construct; otherwise nil." + (let ((op (car form))) + (and (symbolp op) + (let ((def (rx--lookup-def op))) (and def (if (cdr def) - (rx--expand-template - op (cdr form) (nth 0 def) (nth 1 def)) + (rx--expand-template op (cdr form) (nth 0 def) (nth 1 def)) (error "Not an `rx' form definition: %s" op))))))) -;; TODO: Additions to consider: -;; - A construct like `or' but without the match order guarantee, -;; maybe `unordered-or'. Useful for composition or generation of -;; alternatives; permits more effective use of regexp-opt. +(defun rx--expand-def-symbol (symbol) + "SYM expanded (once) if a user-defined name; otherwise nil." + (let ((def (rx--lookup-def symbol))) + (and def + (if (cdr def) + (error "Not an `rx' symbol definition: %s" symbol) + (car def))))) (defun rx--translate-symbol (sym) "Translate an rx symbol. Return (REGEXP . PRECEDENCE)." @@ -167,28 +198,19 @@ Each entry is: ('not-word-boundary (cons (list "\\B") t)) ('symbol-start (cons (list "\\_<") t)) ('symbol-end (cons (list "\\_>") t)) - ('not-wordchar (cons (list "\\W") t)) + ('not-wordchar (rx--translate '(not wordchar))) (_ (cond ((let ((class (cdr (assq sym rx--char-classes)))) (and class (cons (list (concat "[[:" (symbol-name class) ":]]")) t)))) - ((let ((expanded (rx--expand-def sym))) + ((let ((expanded (rx--expand-def-symbol sym))) (and expanded (rx--translate expanded)))) ;; For compatibility with old rx. ((let ((entry (assq sym rx-constituents))) - (and (progn - (while (and entry (not (stringp (cdr entry)))) - (setq entry - (if (symbolp (cdr entry)) - ;; Alias for another entry. - (assq (cdr entry) rx-constituents) - ;; Wrong type, try further down the list. - (assq (car entry) - (cdr (memq entry rx-constituents)))))) - entry) - (cons (list (cdr entry)) nil)))) + (and entry (rx--translate-compat-symbol-entry entry)))) + (t (error "Unknown rx symbol `%s'" sym)))))) (defun rx--enclose (left-str rexp right-str) @@ -254,83 +276,225 @@ Left-fold the list L, starting with X, by the binary function F." (setq l (cdr l))) x) -(defun rx--normalise-or-arg (form) - "Normalize the `or' argument FORM. -Characters become strings, user-definitions and `eval' forms are expanded, -and `or' forms are normalized recursively." - (cond ((characterp form) +;; FIXME: flatten nested `or' patterns when performing char-pattern combining. +;; The only reason for not flattening is to ensure regexp-opt processing +;; (which we do for entire `or' patterns, not subsequences), but we +;; obviously want to translate +;; (or "a" space (or "b" (+ nonl) word) "c") +;; -> (or (in "ab" space) (+ nonl) (in "c" word)) + +;; FIXME: normalise `seq', both the construct and implicit sequences, +;; so that they are flattened, adjacent strings concatenated, and +;; empty strings removed. That would give more opportunities for regexp-opt: +;; (or "a" (seq "ab" (seq "c" "d") "")) -> (or "a" "abcd") + +;; FIXME: Since `rx--normalise-char-pattern' recurses through `or', `not' and +;; `intersection', we may end up normalising subtrees multiple times +;; which wastes time (but should be idempotent). +;; One way to avoid this is to aggressively normalise the entire tree +;; before translating anything at all, but we must then recurse through +;; all constructs and probably copy them. +;; Such normalisation could normalise synonyms, eliminate `minimal-match' +;; and `maximal-match' and convert affected `1+' to either `+' or `+?' etc. +;; We would also consolidate the user-def lookup, both modern and legacy, +;; in one place. + +(defun rx--normalise-char-pattern (form) + "Normalize FORM as a pattern matching a single-character. +Characters become strings, `any' forms and character classes become +`rx--char-alt' forms, user-definitions and `eval' forms are expanded, +and `or', `not' and `intersection' forms are normalized recursively. + +A `rx--char-alt' form is shaped (rx--char-alt INTERVALS . CLASSES) +where INTERVALS is a sorted list of disjoint nonadjacent intervals, +each a cons of characters, and CLASSES an unordered list of unique +name-normalised character classes." + (defvar rx--builtin-forms) + (defvar rx--builtin-symbols) + (cond ((consp form) + (let ((op (car form)) + (body (cdr form))) + (cond ((memq op '(or |)) + ;; Normalise the constructor to `or' and the args recursively. + (cons 'or (mapcar #'rx--normalise-char-pattern body))) + ;; Convert `any' forms and char classes now so that we + ;; don't need to do it later on. + ((memq op '(any in char)) + (cons 'rx--char-alt (rx--parse-any body))) + ((memq op '(not intersection)) + (cons op (mapcar #'rx--normalise-char-pattern body))) + ((eq op 'eval) + (rx--normalise-char-pattern (rx--expand-eval body))) + ((memq op rx--builtin-forms) form) + ((let ((expanded (rx--expand-def-form form))) + (and expanded + (rx--normalise-char-pattern expanded)))) + (t form)))) + ;; FIXME: Should we expand legacy definitions from + ;; `rx-constituents' here as well? + ((symbolp form) + (cond ((let ((class (assq form rx--char-classes))) + (and class + `(rx--char-alt nil . (,(cdr class)))))) + ((memq form rx--builtin-symbols) form) + ((let ((expanded (rx--expand-def-symbol form))) + (and expanded + (rx--normalise-char-pattern expanded)))) + (t form))) + ((characterp form) (char-to-string form)) - ((and (consp form) (memq (car form) '(or |))) - (cons (car form) (mapcar #'rx--normalise-or-arg (cdr form)))) - ((and (consp form) (eq (car form) 'eval)) - (rx--normalise-or-arg (rx--expand-eval (cdr form)))) - (t - (let ((expanded (rx--expand-def form))) - (if expanded - (rx--normalise-or-arg expanded) - form))))) - -(defun rx--all-string-or-args (body) - "If BODY only consists of strings or such `or' forms, return all the strings. -Otherwise throw `rx--nonstring'." + (t form))) + +(defun rx--char-alt-union (a b) + "Union of the (INTERVALS . CLASSES) pairs A and B." + (let* ((a-cl (cdr a)) + (b-cl (cdr b)) + (classes (if (and a-cl b-cl) + (let ((acc a-cl)) + (dolist (c b-cl) + (unless (memq c a-cl) + (push c acc))) + acc) + (or a-cl b-cl)))) + (cons (rx--interval-set-union (car a) (car b)) classes))) + +(defun rx--intersection-intervals (forms) + "Intersection of the normalised FORMS, as an interval set." + (rx--foldl #'rx--interval-set-intersection '((0 . #x3fffff)) + (mapcar (lambda (x) + (let ((char (rx--reduce-to-char-alt x))) + (if (and char (null (cdr char))) + (car char) + (error "Cannot be used in rx intersection: %S" + (rx--human-readable x))))) + forms))) + +(defun rx--reduce-to-char-alt (form) + "Transform FORM into (INTERVALS . CLASSES) or nil if not possible. +Process `or', `intersection' and `not'. +FORM must be normalised (from `rx--normalise-char-pattern')." + (cond + ((stringp form) + (and (= (length form) 1) + (let ((c (aref form 0))) + (list (list (cons c c)))))) + ((consp form) + (let ((head (car form))) + (cond + ;; FIXME: Transform `digit', `xdigit', `cntrl', `ascii', `nonascii' + ;; to ranges? That would allow them to be negated and intersected. + ((eq head 'rx--char-alt) (cdr form)) + ((eq head 'not) + (unless (= (length form) 2) + (error "rx `not' form takes exactly one argument")) + (let ((arg (rx--reduce-to-char-alt (cadr form)))) + ;; Only interval sets without classes are closed under complement. + (and arg (null (cdr arg)) + (list (rx--interval-set-complement (car arg)))))) + ((eq head 'or) + (let ((args (cdr form))) + (let ((acc '(nil))) ; union identity + (while (and args + (let ((char (rx--reduce-to-char-alt (car args)))) + (setq acc (and char (rx--char-alt-union acc char))))) + (setq args (cdr args))) + acc))) + ((eq head 'intersection) + (list (rx--intersection-intervals (cdr form)))) + ))) + ((memq form '(nonl not-newline any)) + '(((0 . 9) (11 . #x3fffff)))) + ((memq form '(anychar anything)) + '(((0 . #x3fffff)))) + ;; FIXME: A better handling of `unmatchable' would be: + ;; * (seq ... unmatchable ...) -> unmatchable + ;; * any or-pattern branch that is `unmatchable' is deleted + ;; * (REPEAT unmatchable) -> "", if REPEAT accepts 0 repetitions + ;; * (REPEAT unmatchable) -> unmatchable, otherwise + ;; if it's worth the trouble (probably not). + ((eq form 'unmatchable) + '(nil)) + )) + +(defun rx--optimise-or-args (args) + "Optimise `or' arguments. Return a new rx form. +Each element of ARGS should have been normalised using +`rx--normalise-char-pattern'." + (if (null args) + ;; No arguments. + '(rx--char-alt nil . nil) ; FIXME: not `unmatchable'? + ;; Join consecutive single-char branches into a char alt where possible. + ;; Ideally we should collect all single-char branches but that might + ;; alter matching order in some cases. + (let ((branches nil) + (prev-char nil)) + (while args + (let* ((item (car args)) + (item-char (rx--reduce-to-char-alt item))) + (if item-char + (setq prev-char (if prev-char + (rx--char-alt-union prev-char item-char) + item-char)) + (when prev-char + (push (cons 'rx--char-alt prev-char) branches) + (setq prev-char nil)) + (push item branches))) + (setq args (cdr args))) + (when prev-char + (push (cons 'rx--char-alt prev-char) branches)) + (if (cdr branches) + (cons 'or (nreverse branches)) + (car branches))))) + +(defun rx--all-string-branches-p (forms) + "Whether FORMS are all strings or `or' forms with the same property." + (rx--every (lambda (x) (or (stringp x) + (and (eq (car-safe x) 'or) + (rx--all-string-branches-p (cdr x))))) + forms)) + +(defun rx--collect-or-strings (forms) + "All strings from FORMS, which are strings or `or' forms." (mapcan (lambda (form) - (cond ((stringp form) (list form)) - ((and (consp form) (memq (car form) '(or |))) - (rx--all-string-or-args (cdr form))) - (t (throw 'rx--nonstring nil)))) - body)) + (if (stringp form) + (list form) + ;; must be an `or' form + (rx--collect-or-strings (cdr form)))) + forms)) + +;; TODO: Write a more general rx-level factoriser to replace +;; `regexp-opt' for our purposes. It would handle non-literals: +;; +;; (or "ab" (: "a" space) "bc" (: "b" (+ digit))) +;; -> (or (: "a" (in "b" space)) (: "b" (or "c" (+ digit)))) +;; +;; As a minor side benefit we would get less useless bracketing. +;; The main problem is how to deal with matching order, which `regexp-opt' +;; alters in its own way. (defun rx--translate-or (body) "Translate an or-pattern of zero or more rx items. Return (REGEXP . PRECEDENCE)." - ;; FIXME: Possible improvements: - ;; - ;; - Flatten sub-patterns first: (or (or A B) (or C D)) -> (or A B C D) - ;; Then call regexp-opt on runs of string arguments. Example: - ;; (or (+ digit) "CHARLIE" "CHAN" (+ blank)) - ;; -> (or (+ digit) (or "CHARLIE" "CHAN") (+ blank)) - ;; - ;; - Optimize single-character alternatives better: - ;; * classes: space, alpha, ... - ;; * (syntax S), for some S (whitespace, word) - ;; so that (or "@" "%" digit (any "A-Z" space) (syntax word)) - ;; -> (any "@" "%" digit "A-Z" space word) - ;; -> "[A-Z@%[:digit:][:space:][:word:]]" (cond ((null body) ; No items: a never-matching regexp. (rx--empty)) ((null (cdr body)) ; Single item. (rx--translate (car body))) (t - (let* ((args (mapcar #'rx--normalise-or-arg body)) - (all-strings (catch 'rx--nonstring (rx--all-string-or-args args)))) - (cond - (all-strings ; Only strings. - (cons (list (regexp-opt all-strings nil)) - t)) - ((rx--every #'rx--charset-p args) ; All charsets. - (rx--translate-union nil args)) - (t - (cons (append (car (rx--translate (car args))) - (mapcan (lambda (item) - (cons "\\|" (car (rx--translate item)))) - (cdr args))) - nil))))))) - -(defun rx--charset-p (form) - "Whether FORM looks like a charset, only consisting of character intervals -and set operations." - (or (and (consp form) - (or (and (memq (car form) '(any in char)) - (rx--every (lambda (x) (not (symbolp x))) (cdr form))) - (and (memq (car form) '(not or | intersection)) - (rx--every #'rx--charset-p (cdr form))))) - (characterp form) - (and (stringp form) (= (length form) 1)) - (and (or (symbolp form) (consp form)) - (let ((expanded (rx--expand-def form))) - (and expanded - (rx--charset-p expanded)))))) + (let ((args (mapcar #'rx--normalise-char-pattern body))) + (if (rx--all-string-branches-p args) + ;; All branches are strings: use `regexp-opt'. + (cons (list (regexp-opt (rx--collect-or-strings args) nil)) + t) + (let ((form (rx--optimise-or-args args))) + (if (eq (car-safe form) 'or) + (let ((branches (cdr form))) + (cons (append (car (rx--translate (car branches))) + (mapcan (lambda (item) + (cons "\\|" (car (rx--translate item)))) + (cdr branches))) + nil)) + (rx--translate form)))))))) (defun rx--string-to-intervals (str) "Decode STR as intervals: A-Z becomes (?A . ?Z), and the single @@ -385,7 +549,7 @@ INTERVALS is a list of (START . END) with START ≤ END, sorted by START." (defun rx--parse-any (body) "Parse arguments of an (any ...) construct. Return (INTERVALS . CLASSES), where INTERVALS is a sorted list of -disjoint intervals (each a cons of chars), and CLASSES +disjoint nonadjacent intervals (each a cons of chars), and CLASSES a list of named character classes in the order they occur in BODY." (let ((classes nil) (strings nil) @@ -412,112 +576,131 @@ a list of named character classes in the order they occur in BODY." (sort (append conses (mapcan #'rx--string-to-intervals strings)) #'car-less-than-car)) - (reverse classes)))) + (nreverse classes)))) (defun rx--generate-alt (negated intervals classes) "Generate a character alternative. Return (REGEXP . PRECEDENCE). If NEGATED is non-nil, negate the result; INTERVALS is a sorted list of disjoint intervals and CLASSES a list of named character classes." - (let ((items (append intervals classes))) - ;; Move lone ] and range ]-x to the start. - (let ((rbrac-l (assq ?\] items))) - (when rbrac-l - (setq items (cons rbrac-l (delq rbrac-l items))))) - - ;; Split x-] and move the lone ] to the start. - (let ((rbrac-r (rassq ?\] items))) - (when (and rbrac-r (not (eq (car rbrac-r) ?\]))) - (setcdr rbrac-r ?\\) - (setq items (cons '(?\] . ?\]) items)))) - - ;; Split ,-- (which would end up as ,- otherwise). - (let ((dash-r (rassq ?- items))) - (when (eq (car dash-r) ?,) - (setcdr dash-r ?,) - (setq items (nconc items '((?- . ?-)))))) - - ;; Remove - (lone or at start of interval) - (let ((dash-l (assq ?- items))) - (when dash-l - (if (eq (cdr dash-l) ?-) - (setq items (delq dash-l items)) ; Remove lone - - (setcar dash-l ?.)) ; Reduce --x to .-x - (setq items (nconc items '((?- . ?-)))))) - - ;; Deal with leading ^ and range ^-x in non-negated set. - (when (and (eq (car-safe (car items)) ?^) - (not negated)) - (if (eq (cdar items) ?^) - ;; single leading ^ - (when (cdr items) - ;; Move the ^ to second place. - (setq items (cons (cadr items) - (cons (car items) (cddr items))))) - ;; Split ^-x to _-x^ - (setq items (cons (cons ?_ (cdar items)) - (cons '(?^ . ?^) - (cdr items)))))) - - (cond - ;; Empty set: if negated, any char, otherwise match-nothing. - ((null items) + ;; No, this is not pretty code. You try doing it in a way that is both + ;; elegant and efficient. Or just one of the two. I dare you. + + ;; Detect whether the interval set is better described in + ;; complemented form. This is not just a matter of aesthetics: any + ;; range that straddles the char-raw boundary will be mutilated by the + ;; regexp engine. Ranges from ASCII to raw bytes will exclude the + ;; all non-ASCII non-raw bytes, and ranges from non-ASCII Unicode + ;; to raw bytes are ignored. + (unless (or classes + ;; Any interval set covering #x3fff7f should be negated. + (rx--every (lambda (iv) (not (<= (car iv) #x3fff7f (cdr iv)))) + intervals)) + (setq negated (not negated)) + (setq intervals (rx--interval-set-complement intervals))) + (cond + ;; Single character. + ((and intervals (eq (caar intervals) (cdar intervals)) + (null (cdr intervals)) + (null classes)) + (let ((ch (caar intervals))) (if negated - (rx--translate-symbol 'anything) - (rx--empty))) - ;; Single non-negated character. - ((and (null (cdr items)) - (consp (car items)) - (eq (caar items) (cdar items)) - (not negated)) - (cons (list (regexp-quote (char-to-string (caar items)))) - t)) - ;; Negated newline. - ((and (equal items '((?\n . ?\n))) - negated) - (rx--translate-symbol 'nonl)) - ;; At least one character or class, possibly negated. - (t + (if (eq ch ?\n) + ;; Single negated newline. + (rx--translate-symbol 'nonl) + ;; Single negated character (other than newline). + (cons (list (string ?\[ ?^ ch ?\])) t)) + ;; Single literal character. + (cons (list (regexp-quote (char-to-string ch))) t)))) + + ;; Empty set (or any char). + ((and (null intervals) (null classes)) + (if negated + (rx--translate-symbol 'anychar) + (rx--empty))) + + ;; More than one character, or at least one class. + (t + (let ((dash nil) (caret nil)) + ;; Move ] and range ]-x to the start. + (let ((rbrac-l (assq ?\] intervals))) + (when rbrac-l + (setq intervals (cons rbrac-l (remq rbrac-l intervals))))) + + ;; Split x-] and move the lone ] to the start. + (let ((rbrac-r (rassq ?\] intervals))) + (when (and rbrac-r (not (eq (car rbrac-r) ?\]))) + (setcdr rbrac-r ?\\) + (setq intervals (cons '(?\] . ?\]) intervals)))) + + ;; Split ,-- (which would end up as ,- otherwise). + (let ((dash-r (rassq ?- intervals))) + (when (eq (car dash-r) ?,) + (setcdr dash-r ?,) + (setq dash "-"))) + + ;; Remove - (lone or at start of interval) + (let ((dash-l (assq ?- intervals))) + (when dash-l + (if (eq (cdr dash-l) ?-) + (setq intervals (remq dash-l intervals)) ; Remove lone - + (setcar dash-l ?.)) ; Reduce --x to .-x + (setq dash "-"))) + + ;; Deal with leading ^ and range ^-x in non-negated set. + (when (and (eq (caar intervals) ?^) + (not negated)) + (if (eq (cdar intervals) ?^) + ;; single leading ^ + (if (or (cdr intervals) classes) + ;; something else to put before the ^ + (progn + (setq intervals (cdr intervals)) ; remove lone ^ + (setq caret "^")) ; put ^ (almost) last + ;; nothing else but a lone - + (setq intervals (cons '(?- . ?-) intervals)) ; move - first + (setq dash nil)) + ;; split ^-x to _-x^ + (setq intervals `((?_ . ,(cdar intervals)) (?^ . ?^) + . ,(cdr intervals))))) + (cons (list (concat "[" (and negated "^") - (mapconcat (lambda (item) - (cond ((symbolp item) - (format "[:%s:]" item)) - ((eq (car item) (cdr item)) - (char-to-string (car item))) - ((eq (1+ (car item)) (cdr item)) - (string (car item) (cdr item))) + (mapconcat (lambda (iv) + (cond ((eq (car iv) (cdr iv)) + (char-to-string (car iv))) + ((eq (1+ (car iv)) (cdr iv)) + (string (car iv) (cdr iv))) + ;; Ranges that go between normal chars and raw bytes + ;; must be split to avoid being mutilated + ;; by Emacs's regexp parser. + ((<= (car iv) #x3fff7f (cdr iv)) + (string (car iv) ?- #x3fff7f + #x3fff80 ?- (cdr iv))) (t - (string (car item) ?- (cdr item))))) - items nil) + (string (car iv) ?- (cdr iv))))) + intervals) + (mapconcat (lambda (cls) (format "[:%s:]" cls)) classes) + caret ; ^ or nothing + dash ; - or nothing "]")) t))))) +(defun rx--translate-char-alt (negated body) + "Translate a (rx--char-alt ...) construct. Return (REGEXP . PRECEDENCE). +If NEGATED, negate the sense." + (rx--generate-alt negated (car body) (cdr body))) + (defun rx--translate-any (negated body) "Translate an (any ...) construct. Return (REGEXP . PRECEDENCE). If NEGATED, negate the sense." (let ((parsed (rx--parse-any body))) (rx--generate-alt negated (car parsed) (cdr parsed)))) -(defun rx--intervals-to-alt (negated intervals) - "Generate a character alternative from an interval set. -Return (REGEXP . PRECEDENCE). -INTERVALS is a sorted list of disjoint intervals. -If NEGATED, negate the sense." - ;; Detect whether the interval set is better described in - ;; complemented form. This is not just a matter of aesthetics: any - ;; range from ASCII to raw bytes will automatically exclude the - ;; entire non-ASCII Unicode range by the regexp engine. - (if (rx--every (lambda (iv) (not (<= (car iv) #x3ffeff (cdr iv)))) - intervals) - (rx--generate-alt negated intervals nil) - (rx--generate-alt - (not negated) (rx--complement-intervals intervals) nil))) - -;; FIXME: Consider turning `not' into a variadic operator, following SRE: +;; TODO: Consider turning `not' into a variadic operator, following SRE: ;; (not A B) = (not (or A B)) = (intersection (not A) (not B)), and ;; (not) = anychar. ;; Maybe allow singleton characters as arguments. @@ -527,43 +710,27 @@ If NEGATED, negate the sense." If NEGATED, negate the sense (thus making it positive)." (unless (and body (null (cdr body))) (error "rx `not' form takes exactly one argument")) - (let ((arg (car body))) - (cond - ((and (consp arg) - (pcase (car arg) - ((or 'any 'in 'char) - (rx--translate-any (not negated) (cdr arg))) - ('syntax - (rx--translate-syntax (not negated) (cdr arg))) - ('category - (rx--translate-category (not negated) (cdr arg))) - ('not - (rx--translate-not (not negated) (cdr arg))) - ((or 'or '|) - (rx--translate-union (not negated) (cdr arg))) - ('intersection - (rx--translate-intersection (not negated) (cdr arg)))))) - ((let ((class (cdr (assq arg rx--char-classes)))) - (and class - (rx--generate-alt (not negated) nil (list class))))) - ((eq arg 'word-boundary) - (rx--translate-symbol - (if negated 'word-boundary 'not-word-boundary))) - ((characterp arg) - (rx--generate-alt (not negated) (list (cons arg arg)) nil)) - ((and (stringp arg) (= (length arg) 1)) - (let ((char (string-to-char arg))) - (rx--generate-alt (not negated) (list (cons char char)) nil))) - ((let ((expanded (rx--expand-def arg))) - (and expanded - (rx--translate-not negated (list expanded))))) - (t (error "Illegal argument to rx `not': %S" arg))))) - -(defun rx--complement-intervals (intervals) - "Complement of the interval list INTERVALS." + (let ((arg (rx--normalise-char-pattern (car body)))) + (pcase arg + (`(not . ,args) + (rx--translate-not (not negated) args)) + (`(syntax . ,args) + (rx--translate-syntax (not negated) args)) + (`(category . ,args) + (rx--translate-category (not negated) args)) + ('word-boundary ; legacy syntax + (rx--translate-symbol (if negated 'word-boundary 'not-word-boundary))) + (_ (let ((char (rx--reduce-to-char-alt arg))) + (if char + (rx--generate-alt (not negated) (car char) (cdr char)) + (error "Illegal argument to rx `not': %S" + (rx--human-readable arg)))))))) + +(defun rx--interval-set-complement (ivs) + "Complement of the interval set IVS." (let ((compl nil) (c 0)) - (dolist (iv intervals) + (dolist (iv ivs) (when (< c (car iv)) (push (cons c (1- (car iv))) compl)) (setq c (1+ (cdr iv)))) @@ -571,8 +738,8 @@ If NEGATED, negate the sense (thus making it positive)." (push (cons c (max-char)) compl)) (nreverse compl))) -(defun rx--intersect-intervals (ivs-a ivs-b) - "Intersection of the interval lists IVS-A and IVS-B." +(defun rx--interval-set-intersection (ivs-a ivs-b) + "Intersection of the interval sets IVS-A and IVS-B." (let ((isect nil)) (while (and ivs-a ivs-b) (let ((a (car ivs-a)) @@ -594,60 +761,91 @@ If NEGATED, negate the sense (thus making it positive)." ivs-a))))))) (nreverse isect))) -(defun rx--union-intervals (ivs-a ivs-b) - "Union of the interval lists IVS-A and IVS-B." - (rx--complement-intervals - (rx--intersect-intervals - (rx--complement-intervals ivs-a) - (rx--complement-intervals ivs-b)))) - -(defun rx--charset-intervals (charset) - "Return a sorted list of non-adjacent disjoint intervals from CHARSET. -CHARSET is any expression allowed in a character set expression: -characters, single-char strings, `any' forms (no classes permitted), -or `not', `or' or `intersection' forms whose arguments are charsets." - (pcase charset - (`(,(or 'any 'in 'char) . ,body) - (let ((parsed (rx--parse-any body))) - (when (cdr parsed) - (error - "Character class not permitted in set operations: %S" - (cadr parsed))) - (car parsed))) - (`(not ,x) (rx--complement-intervals (rx--charset-intervals x))) - (`(,(or 'or '|) . ,body) (rx--charset-union body)) - (`(intersection . ,body) (rx--charset-intersection body)) - ((pred characterp) - (list (cons charset charset))) - ((guard (and (stringp charset) (= (length charset) 1))) - (let ((char (string-to-char charset))) - (list (cons char char)))) - (_ (let ((expanded (rx--expand-def charset))) - (if expanded - (rx--charset-intervals expanded) - (error "Bad character set: %S" charset)))))) - -(defun rx--charset-union (charsets) - "Union of CHARSETS, as a set of intervals." - (rx--foldl #'rx--union-intervals nil - (mapcar #'rx--charset-intervals charsets))) - -(defconst rx--charset-all (list (cons 0 (max-char)))) - -(defun rx--charset-intersection (charsets) - "Intersection of CHARSETS, as a set of intervals." - (rx--foldl #'rx--intersect-intervals rx--charset-all - (mapcar #'rx--charset-intervals charsets))) - -(defun rx--translate-union (negated body) - "Translate an (or ...) construct of charsets. Return (REGEXP . PRECEDENCE). -If NEGATED, negate the sense." - (rx--intervals-to-alt negated (rx--charset-union body))) +(defun rx--interval-set-union (ivs-a ivs-b) + "Union of the interval sets IVS-A and IVS-B." + (let ((union nil)) + (while (and ivs-a ivs-b) + (let ((a (car ivs-a)) + (b (car ivs-b))) + (cond + ((< (1+ (cdr a)) (car b)) ; a before b, not adacent + (push a union) + (setq ivs-a (cdr ivs-a))) + ((< (1+ (cdr b)) (car a)) ; b before a, not adacent + (push b union) + (setq ivs-b (cdr ivs-b))) + (t ; a and b adjacent or overlap + (setq ivs-a (cdr ivs-a)) + (setq ivs-b (cdr ivs-b)) + (if (< (cdr a) (cdr b)) + (push (cons (min (car a) (car b)) + (cdr b)) + ivs-b) + (push (cons (min (car a) (car b)) + (cdr a)) + ivs-a)))))) + (nconc (nreverse union) (or ivs-a ivs-b)))) + +(defun rx--human-readable (form) + "Turn FORM into something that is more human-readable, for error messages." + ;; FIXME: Should we produce a string instead? + ;; That way we wouldn't have problems with ? and ??, and we could escape + ;; single chars. + ;; We could steal `xr--rx-to-string' and just file off the serials. + (let ((recurse (lambda (op skip) + (cons op (append (take skip (cdr form)) + (mapcar #'rx--human-readable + (nthcdr skip (cdr form)))))))) + (pcase form + ;; strings are more readable than numbers for single chars + ((pred characterp) (char-to-string form)) + ;; resugar `rx--char-alt' + (`(rx--char-alt ((,c . ,c)) . nil) + (char-to-string form)) + (`(rx--char-alt nil . (,class)) + class) + ;; TODO: render in complemented form if more readable that way? + (`(rx--char-alt ,ivs . ,classes) + (let ((strings (mapcan (lambda (iv) + (let ((beg (car iv)) + (end (cdr iv))) + (cond + ;; single char + ((eq beg end) + (list (string beg))) + ;; two chars + ((eq end (1+ beg)) + (list (string beg) (string end))) + ;; first char is hyphen + ((eq beg ?-) + (cons (string "-") + (if (eq end (+ ?- 2)) + (list (string (1+ ?-) end)) + (list (string (1+ ?-) ?- end))))) + ;; other range + (t (list (string beg ?- end)))))) + ivs))) + `(any ,@strings ,@classes))) + ;; avoid numbers as ops + (`(? . ,_) (funcall recurse '\? 0)) + (`(?? . ,_) (funcall recurse '\?? 0)) + ;; recurse on arguments + (`(repeat ,_ ,_) (funcall recurse (car form) 1)) + (`(,(or '** 'repeat) . ,_) (funcall recurse (car form) 2)) + (`(,(or '= '>= 'group-n 'submatch-n) . ,_) (funcall recurse (car form) 1)) + (`(,(or 'backref 'syntax 'not-syntax 'category + 'eval 'regex 'regexp 'literal) + . ,_) + form) + (`(,_ . ,_) (funcall recurse (car form) 0)) + (_ form)))) (defun rx--translate-intersection (negated body) "Translate an (intersection ...) construct. Return (REGEXP . PRECEDENCE). If NEGATED, negate the sense." - (rx--intervals-to-alt negated (rx--charset-intersection body))) + (rx--generate-alt negated (rx--intersection-intervals + (mapcar #'rx--normalise-char-pattern body)) + nil)) (defun rx--atomic-regexp (item) "ITEM is (REGEXP . PRECEDENCE); return a regexp of precedence t." @@ -783,7 +981,10 @@ Return (REGEXP . PRECEDENCE)." (setq syntax char))))))) (unless syntax (error "Unknown rx syntax name `%s'" sym))) - (cons (list (string ?\\ (if negated ?S ?s) syntax)) + ;; Produce \w and \W instead of \sw and \Sw, for smaller size. + (cons (list (if (eq syntax ?w) + (string ?\\ (if negated ?W ?w)) + (string ?\\ (if negated ?S ?s) syntax))) t))) (defconst rx--categories @@ -894,15 +1095,15 @@ Return (REGEXP . PRECEDENCE)." (opt "^") (opt "]") (* (or (seq "[:" (+ (any "a-z")) ":]") - (not (any "]")))) + (not "]"))) "]") (not (any "*+?^$[\\")) (seq "\\" - (or anything - (seq (any "sScC_") anything) + (or anychar + (seq (any "sScC_") anychar) (seq "(" - (* (or (not (any "\\")) - (seq "\\" (not (any ")"))))) + (* (or (not "\\") + (seq "\\" (not ")")))) "\\)")))) eos) t))) @@ -934,6 +1135,36 @@ DEF is the definition tuple. Return (REGEXP . PRECEDENCE)." (error "The `%s' form did not expand to a string" (car form))) (cons (list regexp) nil)))) +(defun rx--translate-compat-symbol-entry (entry) + "Translate a compatibility symbol definition for ENTRY. +Return (REGEXP . PRECEDENCE) or nil if none." + (and (progn + (while (and entry (not (stringp (cdr entry)))) + (setq entry + (if (symbolp (cdr entry)) + ;; Alias for another entry. + (assq (cdr entry) rx-constituents) + ;; Wrong type, try further down the list. + (assq (car entry) + (cdr (memq entry rx-constituents)))))) + entry) + (cons (list (cdr entry)) nil))) + +(defun rx--translate-compat-form-entry (orig-form entry) + "Translate a compatibility ORIG-FORM definition for ENTRY. +Return (REGEXP . PRECEDENCE) or nil if none." + (and (progn + (while (and entry (not (consp (cdr entry)))) + (setq entry + (if (symbolp (cdr entry)) + ;; Alias for another entry. + (assq (cdr entry) rx-constituents) + ;; Wrong type, try further down the list. + (assq (car entry) + (cdr (memq entry rx-constituents)))))) + entry) + (rx--translate-compat-form (cdr entry) orig-form))) + (defun rx--substitute (bindings form) "Substitute BINDINGS in FORM. BINDINGS is an alist of (NAME . VALUES) where VALUES is a list to splice into FORM wherever NAME occurs. @@ -1029,6 +1260,7 @@ can expand to any number of values." ((or 'seq : 'and 'sequence) (rx--translate-seq body)) ((or 'or '|) (rx--translate-or body)) ((or 'any 'in 'char) (rx--translate-any nil body)) + ('rx--char-alt (rx--translate-char-alt nil body)) ('not-char (rx--translate-any t body)) ('not (rx--translate-not nil body)) ('intersection (rx--translate-intersection nil body)) @@ -1069,23 +1301,13 @@ can expand to any number of values." (cond ((not (symbolp op)) (error "Bad rx operator `%S'" op)) - ((let ((expanded (rx--expand-def form))) + ((let ((expanded (rx--expand-def-form form))) (and expanded (rx--translate expanded)))) ;; For compatibility with old rx. ((let ((entry (assq op rx-constituents))) - (and (progn - (while (and entry (not (consp (cdr entry)))) - (setq entry - (if (symbolp (cdr entry)) - ;; Alias for another entry. - (assq (cdr entry) rx-constituents) - ;; Wrong type, try further down the list. - (assq (car entry) - (cdr (memq entry rx-constituents)))))) - entry) - (rx--translate-compat-form (cdr entry) form)))) + (and entry (rx--translate-compat-form-entry form entry)))) (t (error "Unknown rx form `%s'" op))))))) @@ -1150,6 +1372,7 @@ If NO-GROUP is non-nil, don't bracket the result in a non-capturing group. For extending the `rx' notation in FORM, use `rx-define' or `rx-let-eval'." + (declare (important-return-value t)) (let* ((item (rx--translate form)) (exprs (if no-group (car item) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index ed127e0a790..346250c1d35 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -38,9 +38,6 @@ ;; the sequence as their second argument. All other functions take ;; the sequence as their first argument. ;; -;; While seq.el version 1.8 is in GNU ELPA for convenience, seq.el -;; version 2.0 requires Emacs>=25.1. -;; ;; seq.el can be extended to support new type of sequences. Here are ;; the generic functions that must be implemented by new seq types: ;; - `seq-elt' @@ -51,11 +48,17 @@ ;; - `seq-into-sequence' ;; - `seq-copy' ;; - `seq-into' -;; -;; All functions are tested in test/lisp/emacs-lisp/seq-tests.el ;;; Code: +;; Note regarding the `seq' package on GNU ELPA: +;; +;; It was decided not to bother upgrading seq beyond 2.24 on GNU ELPA. +;; The main purpose of the GNU ELPA package was to encourage adoption +;; and accommodate changes more easily, but it's mature enough that +;; changes are fairly slow. Thus, we can now rely on "the usual" +;; solutions to deal with compatibility issues. (Bug#60990) + (eval-when-compile (require 'cl-generic)) ;; We used to use some sequence functions from cl-lib, but this diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index e7c38d996b9..1fa798beae1 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -137,11 +137,11 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (assoc-string "foo" '(("foo" . "bar") ("zot" "baz")))) "Manipulating Alists" (assoc-delete-all - :eval (assoc-delete-all "foo" '(("foo" . "bar") ("zot" . "baz")) #'equal)) + :eval (assoc-delete-all "b" (list '("a" . a) '("b" . b) '("b" . c)))) (assq-delete-all - :eval (assq-delete-all 'foo '((foo . bar) (zot . baz)))) + :eval (assq-delete-all 2 (list '(1 . a) '(2 . b) '(2 . c)))) (rassq-delete-all - :eval (rassq-delete-all 'bar '((foo . bar) (zot . baz)))) + :eval (rassq-delete-all 'b (list '(1 . a) '(2 . b) '(2 . c)))) (alist-get :eval (let ((foo '((bar . baz)))) (setf (alist-get 'bar foo) 'zot) @@ -153,14 +153,14 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (let* ((old '((foo . bar))) (new (copy-alist old))) (eq old new))) - ;; FIXME: Outputs "\.rose" for the symbol `.rose'. - ;; (let-alist - ;; :eval (let ((colors '((rose . red) - ;; (lily . white)))) - ;; (let-alist colors - ;; (if (eq .rose 'red) - ;; .lily)))) - ) + ;; FIXME: Outputs "\.rose" for the symbol `.rose'. It would be + ;; better if that could be cleaned up. + (let-alist + :eval (let ((colors '((rose . red) + (lily . white)))) + (let-alist colors + (if (eq .rose 'red) + .lily))))) (define-short-documentation-group string "Making Strings" @@ -642,6 +642,8 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (delete :eval (delete 2 (list 1 2 3 4)) :eval (delete "a" (list "a" "b" "c" "d"))) + (remq + :eval (remq 'b '(a b c))) (remove :eval (remove 2 '(1 2 3 4)) :eval (remove "a" '("a" "b" "c" "d"))) @@ -686,8 +688,6 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (member :eval (member 2 '(1 2 3)) :eval (member "b" '("a" "b" "c"))) - (remq - :eval (remq 'b '(a b c))) (member-ignore-case :eval (member-ignore-case "foo" '("bar" "Foo" "zot"))) "Association Lists" @@ -707,10 +707,12 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (assoc-default 2 '((1 . a) (2 . b) #'=))) (copy-alist :eval (copy-alist '((1 . a) (2 . b)))) - (assq-delete-all - :eval (assq-delete-all 2 (list '(1 . a) '(2 . b) '(2 . c)))) (assoc-delete-all :eval (assoc-delete-all "b" (list '("a" . a) '("b" . b) '("b" . c)))) + (assq-delete-all + :eval (assq-delete-all 2 (list '(1 . a) '(2 . b) '(2 . c)))) + (rassq-delete-all + :eval (rassq-delete-all 'b (list '(1 . a) '(2 . b) '(2 . c)))) "Property Lists" (plist-get :eval (plist-get '(a 1 b 2 c 3) 'b)) @@ -835,6 +837,8 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (seq-subseq :eval (seq-subseq [1 2 3 4 5] 1 3) :eval (seq-subseq [1 2 3 4 5] 1)) + (copy-tree + :eval (copy-tree [1 (2 3) [4 5]] t)) "Mapping Over Vectors" (mapcar :eval (mapcar #'identity [1 2 3])) @@ -1446,45 +1450,52 @@ If SAME-WINDOW, don't pop to a new window." (setq group (intern group))) (unless (assq group shortdoc--groups) (error "No such documentation group %s" group)) - (funcall (if same-window - #'pop-to-buffer-same-window - #'pop-to-buffer) - (format "*Shortdoc %s*" group)) - (let ((inhibit-read-only t) - (prev nil)) - (erase-buffer) - (shortdoc-mode) - (button-mode) - (mapc - (lambda (data) - (cond - ((stringp data) - (setq prev nil) - (unless (bobp) - (insert "\n")) - (insert (propertize - (substitute-command-keys data) - 'face 'shortdoc-heading - 'shortdoc-section t - 'outline-level 1)) - (insert (propertize - "\n\n" - 'face 'shortdoc-heading - 'shortdoc-section t))) - ;; There may be functions not yet defined in the data. - ((fboundp (car data)) - (when prev - (insert (make-separator-line) - ;; This helps with hidden outlines (bug#53981) - (propertize "\n" 'face '(:height 0)))) - (setq prev t) - (shortdoc--display-function data)))) - (cdr (assq group shortdoc--groups)))) + (let ((buf (get-buffer-create (format "*Shortdoc %s*" group)))) + (shortdoc--insert-group-in-buffer group buf) + (funcall (if same-window + #'pop-to-buffer-same-window + #'pop-to-buffer) + buf)) (goto-char (point-min)) (when function (text-property-search-forward 'shortdoc-function function t) (beginning-of-line))) +(defun shortdoc--insert-group-in-buffer (group &optional buf) + "Insert a short documentation summary for functions in GROUP in buffer BUF. +BUF defaults to the current buffer if nil or omitted." + (with-current-buffer (or buf (current-buffer)) + (let ((inhibit-read-only t) + (prev nil)) + (erase-buffer) + (shortdoc-mode) + (button-mode) + (mapc + (lambda (data) + (cond + ((stringp data) + (setq prev nil) + (unless (bobp) + (insert "\n")) + (insert (propertize + (substitute-command-keys data) + 'face 'shortdoc-heading + 'shortdoc-section t + 'outline-level 1)) + (insert (propertize + "\n\n" + 'face 'shortdoc-heading + 'shortdoc-section t))) + ;; There may be functions not yet defined in the data. + ((fboundp (car data)) + (when prev + (insert (make-separator-line) + ;; This helps with hidden outlines (bug#53981) + (propertize "\n" 'face '(:height 0)))) + (setq prev t) + (shortdoc--display-function data)))) + (cdr (assq group shortdoc--groups)))))) + ;;;###autoload (defalias 'shortdoc #'shortdoc-display-group) @@ -1524,7 +1535,8 @@ function's documentation in the Info manual")) "=>")) (single-arrow (if (char-displayable-p ?→) "→" - "->"))) + "->")) + (start-example (point))) (cl-loop for (type value) on data by #'cddr do (cl-case type @@ -1575,7 +1587,8 @@ function's documentation in the Info manual")) (:eg-result-string (insert " e.g. " double-arrow " ") (princ value (current-buffer)) - (insert "\n"))))) + (insert "\n")))) + (add-text-properties start-example (point) `(shortdoc-example ,function))) ;; Insert the arglist after doing the evals, in case that's pulled ;; in the function definition. (save-excursion @@ -1585,6 +1598,73 @@ function's documentation in the Info manual")) (insert " " (symbol-name param))) (add-face-text-property arglist-start (point) 'shortdoc-section t)))) +(defun shortdoc-function-examples (function) + "Return all shortdoc examples for FUNCTION. +The result is an alist with items of the form (GROUP . EXAMPLES), +where GROUP is a shortdoc group where FUNCTION appears, and +EXAMPLES is a string with the usage examples of FUNCTION defined +in GROUP. Return nil if FUNCTION is not a function or if it +doesn't has any shortdoc information." + (let ((groups (and (symbolp function) + (shortdoc-function-groups function))) + (examples nil)) + (mapc + (lambda (group) + (with-temp-buffer + (shortdoc--insert-group-in-buffer group) + (goto-char (point-min)) + (let ((match (text-property-search-forward + 'shortdoc-example function t))) + (push `(,group . ,(string-trim + (buffer-substring-no-properties + (prop-match-beginning match) + (prop-match-end match)))) + examples)))) + groups) + examples)) + +(defun shortdoc-help-fns-examples-function (function) + "Insert Emacs Lisp examples for FUNCTION into the current buffer. +You can add this function to the `help-fns-describe-function-functions' +hook to show examples of using FUNCTION in *Help* buffers produced +by \\[describe-function]." + (let* ((examples (shortdoc-function-examples function)) + (num-examples (length examples)) + (times 0)) + (dolist (example examples) + (when (zerop times) + (if (> num-examples 1) + (insert "\n Examples:\n\n") + ;; Some functions have more than one example per group. + ;; Count the number of arrows to know if we need to + ;; pluralize "Example". + (let* ((text (cdr example)) + (count 0) + (pos 0) + (end (length text)) + (double-arrow (if (char-displayable-p ?⇒) + " ⇒" + " =>")) + (double-arrow-example (if (char-displayable-p ?⇒) + " e.g. ⇒" + " e.g. =>")) + (single-arrow (if (char-displayable-p ?→) + " →" + " ->"))) + (while (and (< pos end) + (or (string-match double-arrow text pos) + (string-match double-arrow-example text pos) + (string-match single-arrow text pos))) + (setq count (1+ count) + pos (match-end 0))) + (if (> count 1) + (insert "\n Examples:\n\n") + (insert "\n Example:\n\n"))))) + (setq times (1+ times)) + (insert " ") + (insert (cdr example)) + (insert "\n\n")))) + (defun shortdoc-function-groups (function) "Return all shortdoc groups FUNCTION appears in." (cl-loop for group in shortdoc--groups diff --git a/lisp/emacs-lisp/shorthands.el b/lisp/emacs-lisp/shorthands.el index 82200ab88e9..b0665a55695 100644 --- a/lisp/emacs-lisp/shorthands.el +++ b/lisp/emacs-lisp/shorthands.el @@ -53,11 +53,16 @@ :group 'font-lock-faces) (defun shorthands--mismatch-from-end (str1 str2) + "Tell index of first mismatch in STR1 and STR2, from end. +The index is a valid 0-based index on STR1. Returns nil if STR1 +equals STR2. Return 0 if STR1 is a suffix of STR2." (cl-loop with l1 = (length str1) with l2 = (length str2) for i from 1 for i1 = (- l1 i) for i2 = (- l2 i) - while (and (>= i1 0) (>= i2 0) (eq (aref str1 i1) (aref str2 i2))) - finally (return (1- i)))) + while (eq (aref str1 i1) (aref str2 i2)) + if (zerop i2) return (if (zerop i1) nil i1) + if (zerop i1) return 0 + finally (return i1))) (defun shorthands-font-lock-shorthands (limit) (when read-symbol-shorthands @@ -69,10 +74,16 @@ font-lock-string-face))) (intern-soft (match-string 1)))) (sname (and probe (symbol-name probe))) - (mm (and sname (shorthands--mismatch-from-end - (match-string 1) sname)))) - (unless (or (null mm) (= mm (length sname))) - (add-face-text-property (match-beginning 1) (1+ (- (match-end 1) mm)) + (mismatch (and sname (shorthands--mismatch-from-end + (match-string 1) sname))) + (guess (and mismatch (1+ mismatch)))) + (when guess + (when (and (< guess (1- (length (match-string 1)))) + ;; In bug#67390 we allow other separators + (eq (char-syntax (aref (match-string 1) guess)) ?_)) + (setq guess (1+ guess))) + (add-face-text-property (match-beginning 1) + (+ (match-beginning 1) guess) 'elisp-shorthand-font-lock-face)))))) (font-lock-add-keywords 'emacs-lisp-mode '((shorthands-font-lock-shorthands)) t) diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 19a0c22027a..2bc7674b8bf 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -56,8 +56,8 @@ ;; which includes a kind of tutorial to get started with SMIE: ;; ;; SMIE: Weakness is Power! Auto-indentation with incomplete information -;; Stefan Monnier, <Programming> Journal 2020, volume 5, issue 1. -;; doi: 10.22152/programming-journal.org/2021/5/1 +;; Stefan Monnier, <Programming> Journal 2021, volume 5, issue 1. +;; doi: https://doi.org/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 diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 88ac59fd168..fec0a0301a7 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -81,18 +81,22 @@ Note how the single `-' got converted into a list before threading." (declare (indent 0) (debug thread-first)) `(internal--thread-argument nil ,@forms)) + (defsubst hash-table-empty-p (hash-table) "Check whether HASH-TABLE is empty (has 0 elements)." + (declare (side-effect-free t)) (zerop (hash-table-count hash-table))) (defsubst hash-table-keys (hash-table) "Return a list of keys in HASH-TABLE." + (declare (side-effect-free t)) (let ((keys nil)) (maphash (lambda (k _) (push k keys)) hash-table) keys)) (defsubst hash-table-values (hash-table) "Return a list of values in HASH-TABLE." + (declare (side-effect-free t)) (let ((values nil)) (maphash (lambda (_ v) (push v values)) hash-table) values)) @@ -102,6 +106,7 @@ threading." "Join all STRINGS using SEPARATOR. Optional argument SEPARATOR must be a string, a vector, or a list of characters; nil stands for the empty string." + (declare (pure t) (side-effect-free t)) (mapconcat #'identity strings separator)) (define-obsolete-function-alias 'string-reverse 'reverse "25.1") @@ -112,6 +117,7 @@ characters; nil stands for the empty string." When truncating, \"...\" is always prepended to the string, so the resulting string may be longer than the original if LENGTH is 3 or smaller." + (declare (pure t) (side-effect-free t)) (let ((strlen (length string))) (if (<= strlen length) string @@ -124,16 +130,19 @@ the resulting string may be longer than the original if LENGTH is "Check whether STRING is either empty or only whitespace. The following characters count as whitespace here: space, tab, newline and carriage return." + (declare (pure t) (side-effect-free t)) (string-match-p "\\`[ \t\n\r]*\\'" string)) (defsubst string-remove-prefix (prefix string) "Remove PREFIX from STRING if present." + (declare (pure t) (side-effect-free t)) (if (string-prefix-p prefix string) (substring string (length prefix)) string)) (defsubst string-remove-suffix (suffix string) "Remove SUFFIX from STRING if present." + (declare (pure t) (side-effect-free t)) (if (string-suffix-p suffix string) (substring string 0 (- (length string) (length suffix))) string)) @@ -144,6 +153,7 @@ carriage return." All sequences of whitespaces in STRING are collapsed into a single space character, and leading/trailing whitespace is removed." + (declare (important-return-value t)) (let ((blank "[[:blank:]\r\n]+")) (string-trim (replace-regexp-in-string blank " " string t t) blank blank))) @@ -153,6 +163,7 @@ removed." Wrapping is done where there is whitespace. If there are individual words in STRING that are longer than LENGTH, the result will have lines that are longer than LENGTH." + (declare (important-return-value t)) (with-temp-buffer (insert string) (goto-char (point-min)) @@ -184,6 +195,7 @@ coding system that doesn't specify a BOM, like `utf-16le' or `utf-16be'. When shortening strings for display purposes, `truncate-string-to-width' is almost always a better alternative than this function." + (declare (important-return-value t)) (unless (natnump length) (signal 'wrong-type-argument (list 'natnump length))) (if coding-system @@ -252,6 +264,7 @@ is done. If START is nil (or not present), the padding is done to the end of the string, and if non-nil, padding is done to the start of the string." + (declare (pure t) (side-effect-free t)) (unless (natnump length) (signal 'wrong-type-argument (list 'natnump length))) (let ((pad-length (- length (length string)))) @@ -261,6 +274,7 @@ the string." (defun string-chop-newline (string) "Remove the final newline (if any) from STRING." + (declare (pure t) (side-effect-free t)) (string-remove-suffix "\n" string)) (defun replace-region-contents (beg end replace-fn @@ -298,9 +312,13 @@ it makes no sense to convert it to a string using Like `let', bind variables in BINDINGS and then evaluate BODY, but with the twist that BODY can evaluate itself recursively by calling NAME, where the arguments passed to NAME are used -as the new values of the bound variables in the recursive invocation." +as the new values of the bound variables in the recursive invocation. + +This construct can only be used with lexical binding." (declare (indent 2) (debug (symbolp (&rest (symbolp form)) body))) (require 'cl-lib) + (unless lexical-binding + (error "`named-let' requires lexical binding")) (let ((fargs (mapcar (lambda (b) (if (consp b) (car b) b)) bindings)) (aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings))) ;; According to the Scheme semantics of named let, `name' is not in scope @@ -317,6 +335,7 @@ as the new values of the bound variables in the recursive invocation." ;;;###autoload (defun string-pixel-width (string) "Return the width of STRING in pixels." + (declare (important-return-value t)) (if (zerop (length string)) 0 ;; Keeping a work buffer around is more efficient than creating a @@ -339,6 +358,7 @@ This takes into account combining characters and grapheme clusters: if compositions are enabled, each sequence of characters composed on display into a single grapheme cluster is treated as a single indivisible unit." + (declare (side-effect-free t)) (let ((result nil) (start 0) comp) diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index e35992298a6..ba0c91d68c4 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -248,12 +248,14 @@ some parts of the text or may be applied several times to other parts. Note: There may be at most nine back-references in the REGEXPs of all RULES in total." - (declare (debug (&rest &or symbolp ;FIXME: edebug this eval step. - (form &rest - (numberp - [&or stringp ;FIXME: Use &wrap - ("prog1" [&or stringp def-form] def-body) - def-form]))))) + (declare + (debug (&rest &or symbolp ;FIXME: edebug this eval step. + (def-form ;; `def-' needed to debug during macroexpansion. + &rest (numberp + [&or stringp ;FIXME: Use &wrap + ;; `def-' because this is the body of a function. + ("prog1" [&or stringp def-form] def-body) + def-form]))))) (let ((newrules nil)) (while rules (if (symbolp (car rules)) @@ -615,150 +617,150 @@ running the hook." (syntax-propertize pos) ;; (with-syntax-table (or syntax-ppss-table (syntax-table)) - (let* ((cell (syntax-ppss--data)) - (ppss-last (car cell)) - (ppss-cache (cdr cell)) - (old-ppss (cdr ppss-last)) - (old-pos (car ppss-last)) - (ppss nil) - (pt-min (point-min))) - (if (and old-pos (> old-pos pos)) (setq old-pos nil)) - ;; Use the OLD-POS if usable and close. Don't update the `last' cache. - (condition-case nil - (if (and old-pos (< (- pos old-pos) - ;; The time to use syntax-begin-function and - ;; find PPSS is assumed to be about 2 * distance. - (let ((pair (aref syntax-ppss-stats 5))) - (/ (* 2 (cdr pair)) (car pair))))) - (progn - (syntax-ppss--update-stats 0 old-pos pos) - (parse-partial-sexp old-pos pos nil nil old-ppss)) - - (cond - ;; Use OLD-PPSS if possible and close enough. - ((and (not old-pos) old-ppss - ;; If `pt-min' is too far from `pos', we could try to use - ;; other positions in (nth 9 old-ppss), but that doesn't - ;; seem to happen in practice and it would complicate this - ;; code (and the before-change-function code even more). - ;; But maybe it would be useful in "degenerate" cases such - ;; as when the whole file is wrapped in a set - ;; of parentheses. - (setq pt-min (or (syntax-ppss-toplevel-pos old-ppss) - (nth 2 old-ppss))) - (<= pt-min pos) (< (- pos pt-min) syntax-ppss-max-span)) - (syntax-ppss--update-stats 1 pt-min pos) - (setq ppss (parse-partial-sexp pt-min pos))) - ;; The OLD-* data can't be used. Consult the cache. - (t - (let ((cache-pred nil) - (cache ppss-cache) - (pt-min (point-min)) - ;; I differentiate between PT-MIN and PT-BEST because - ;; I feel like it might be important to ensure that the - ;; cache is only filled with 100% sure data (whereas - ;; syntax-begin-function might return incorrect data). - ;; Maybe that's just stupid. - (pt-best (point-min)) - (ppss-best nil)) - ;; look for a usable cache entry. - (while (and cache (< pos (caar cache))) - (setq cache-pred cache) - (setq cache (cdr cache))) - (if cache (setq pt-min (caar cache) ppss (cdar cache))) - - ;; Setup the before-change function if necessary. - (unless (or ppss-cache ppss-last) - ;; Note: combine-change-calls-1 needs to be kept in sync - ;; with this! - (add-hook 'before-change-functions - #'syntax-ppss-flush-cache - ;; We should be either the very last function on - ;; before-change-functions or the very first on - ;; after-change-functions. - 99 t)) - - ;; Use the best of OLD-POS and CACHE. - (if (or (not old-pos) (< old-pos pt-min)) - (setq pt-best pt-min ppss-best ppss) - (syntax-ppss--update-stats 4 old-pos pos) - (setq pt-best old-pos ppss-best old-ppss)) - - ;; Use the `syntax-begin-function' if available. - ;; We could try using that function earlier, but: - ;; - The result might not be 100% reliable, so it's better to use - ;; the cache if available. - ;; - The function might be slow. - ;; - If this function almost always finds a safe nearby spot, - ;; the cache won't be populated, so consulting it is cheap. - (when (and syntax-begin-function - (progn (goto-char pos) - (funcall syntax-begin-function) - ;; Make sure it's better. - (> (point) pt-best)) - ;; Simple sanity checks. - (< (point) pos) ; backward-paragraph can fail here. - (not (memq (get-text-property (point) 'face) - '(font-lock-string-face font-lock-doc-face - font-lock-comment-face)))) - (syntax-ppss--update-stats 5 (point) pos) - (setq pt-best (point) ppss-best nil)) - - (cond - ;; Quick case when we found a nearby pos. - ((< (- pos pt-best) syntax-ppss-max-span) - (syntax-ppss--update-stats 2 pt-best pos) - (setq ppss (parse-partial-sexp pt-best pos nil nil ppss-best))) - ;; Slow case: compute the state from some known position and - ;; populate the cache so we won't need to do it again soon. - (t - (syntax-ppss--update-stats 3 pt-min pos) - (setq syntax-ppss--updated-cache t) - - ;; If `pt-min' is too far, add a few intermediate entries. - (while (> (- pos pt-min) (* 2 syntax-ppss-max-span)) - (setq ppss (parse-partial-sexp - pt-min (setq pt-min (/ (+ pt-min pos) 2)) - nil nil ppss)) - (push (cons pt-min ppss) - (if cache-pred (cdr cache-pred) ppss-cache))) - - ;; Compute the actual return value. - (setq ppss (parse-partial-sexp pt-min pos nil nil ppss)) - - ;; Debugging check. - ;; (let ((real-ppss (parse-partial-sexp (point-min) pos))) - ;; (setcar (last ppss 4) 0) - ;; (setcar (last real-ppss 4) 0) - ;; (setcar (last ppss 8) nil) - ;; (setcar (last real-ppss 8) nil) - ;; (unless (equal ppss real-ppss) - ;; (message "!!Syntax: %s != %s" ppss real-ppss) - ;; (setq ppss real-ppss))) - - ;; Store it in the cache. - (let ((pair (cons pos ppss))) - (if cache-pred - (if (> (- (caar cache-pred) pos) syntax-ppss-max-span) - (push pair (cdr cache-pred)) - (setcar cache-pred pair)) - (if (or (null ppss-cache) - (> (- (caar ppss-cache) pos) - syntax-ppss-max-span)) - (push pair ppss-cache) - (setcar ppss-cache pair))))))))) - - (setq syntax-ppss--updated-cache t) - (setq ppss-last (cons pos ppss)) - (setcar cell ppss-last) - (setcdr cell ppss-cache) - ppss) - (args-out-of-range - ;; If the buffer is more narrowed than when we built the cache, - ;; we may end up calling parse-partial-sexp with a position before - ;; point-min. In that case, just parse from point-min assuming - ;; a nil state. - (parse-partial-sexp (point-min) pos)))))) + (let* ((cell (syntax-ppss--data)) + (ppss-last (car cell)) + (ppss-cache (cdr cell)) + (old-ppss (cdr ppss-last)) + (old-pos (car ppss-last)) + (ppss nil) + (pt-min (point-min))) + (if (and old-pos (> old-pos pos)) (setq old-pos nil)) + ;; Use the OLD-POS if usable and close. Don't update the `last' cache. + (condition-case nil + (if (and old-pos (< (- pos old-pos) + ;; The time to use syntax-begin-function and + ;; find PPSS is assumed to be about 2 * distance. + (let ((pair (aref syntax-ppss-stats 5))) + (/ (* 2 (cdr pair)) (car pair))))) + (progn + (syntax-ppss--update-stats 0 old-pos pos) + (parse-partial-sexp old-pos pos nil nil old-ppss)) + + (cond + ;; Use OLD-PPSS if possible and close enough. + ((and (not old-pos) old-ppss + ;; If `pt-min' is too far from `pos', we could try to use + ;; other positions in (nth 9 old-ppss), but that doesn't + ;; seem to happen in practice and it would complicate this + ;; code (and the before-change-function code even more). + ;; But maybe it would be useful in "degenerate" cases such + ;; as when the whole file is wrapped in a set + ;; of parentheses. + (setq pt-min (or (syntax-ppss-toplevel-pos old-ppss) + (nth 2 old-ppss))) + (<= pt-min pos) (< (- pos pt-min) syntax-ppss-max-span)) + (syntax-ppss--update-stats 1 pt-min pos) + (setq ppss (parse-partial-sexp pt-min pos))) + ;; The OLD-* data can't be used. Consult the cache. + (t + (let ((cache-pred nil) + (cache ppss-cache) + (pt-min (point-min)) + ;; I differentiate between PT-MIN and PT-BEST because + ;; I feel like it might be important to ensure that the + ;; cache is only filled with 100% sure data (whereas + ;; syntax-begin-function might return incorrect data). + ;; Maybe that's just stupid. + (pt-best (point-min)) + (ppss-best nil)) + ;; look for a usable cache entry. + (while (and cache (< pos (caar cache))) + (setq cache-pred cache) + (setq cache (cdr cache))) + (if cache (setq pt-min (caar cache) ppss (cdar cache))) + + ;; Setup the before-change function if necessary. + (unless (or ppss-cache ppss-last) + ;; Note: combine-change-calls-1 needs to be kept in sync + ;; with this! + (add-hook 'before-change-functions + #'syntax-ppss-flush-cache + ;; We should be either the very last function on + ;; before-change-functions or the very first on + ;; after-change-functions. + 99 t)) + + ;; Use the best of OLD-POS and CACHE. + (if (or (not old-pos) (< old-pos pt-min)) + (setq pt-best pt-min ppss-best ppss) + (syntax-ppss--update-stats 4 old-pos pos) + (setq pt-best old-pos ppss-best old-ppss)) + + ;; Use the `syntax-begin-function' if available. + ;; We could try using that function earlier, but: + ;; - The result might not be 100% reliable, so it's better to use + ;; the cache if available. + ;; - The function might be slow. + ;; - If this function almost always finds a safe nearby spot, + ;; the cache won't be populated, so consulting it is cheap. + (when (and syntax-begin-function + (progn (goto-char pos) + (funcall syntax-begin-function) + ;; Make sure it's better. + (> (point) pt-best)) + ;; Simple sanity checks. + (< (point) pos) ; backward-paragraph can fail here. + (not (memq (get-text-property (point) 'face) + '(font-lock-string-face font-lock-doc-face + font-lock-comment-face)))) + (syntax-ppss--update-stats 5 (point) pos) + (setq pt-best (point) ppss-best nil)) + + (cond + ;; Quick case when we found a nearby pos. + ((< (- pos pt-best) syntax-ppss-max-span) + (syntax-ppss--update-stats 2 pt-best pos) + (setq ppss (parse-partial-sexp pt-best pos nil nil ppss-best))) + ;; Slow case: compute the state from some known position and + ;; populate the cache so we won't need to do it again soon. + (t + (syntax-ppss--update-stats 3 pt-min pos) + (setq syntax-ppss--updated-cache t) + + ;; If `pt-min' is too far, add a few intermediate entries. + (while (> (- pos pt-min) (* 2 syntax-ppss-max-span)) + (setq ppss (parse-partial-sexp + pt-min (setq pt-min (/ (+ pt-min pos) 2)) + nil nil ppss)) + (push (cons pt-min ppss) + (if cache-pred (cdr cache-pred) ppss-cache))) + + ;; Compute the actual return value. + (setq ppss (parse-partial-sexp pt-min pos nil nil ppss)) + + ;; Debugging check. + ;; (let ((real-ppss (parse-partial-sexp (point-min) pos))) + ;; (setcar (last ppss 4) 0) + ;; (setcar (last real-ppss 4) 0) + ;; (setcar (last ppss 8) nil) + ;; (setcar (last real-ppss 8) nil) + ;; (unless (equal ppss real-ppss) + ;; (message "!!Syntax: %s != %s" ppss real-ppss) + ;; (setq ppss real-ppss))) + + ;; Store it in the cache. + (let ((pair (cons pos ppss))) + (if cache-pred + (if (> (- (caar cache-pred) pos) syntax-ppss-max-span) + (push pair (cdr cache-pred)) + (setcar cache-pred pair)) + (if (or (null ppss-cache) + (> (- (caar ppss-cache) pos) + syntax-ppss-max-span)) + (push pair ppss-cache) + (setcar ppss-cache pair))))))))) + + (setq syntax-ppss--updated-cache t) + (setq ppss-last (cons pos ppss)) + (setcar cell ppss-last) + (setcdr cell ppss-cache) + ppss) + (args-out-of-range + ;; If the buffer is more narrowed than when we built the cache, + ;; we may end up calling parse-partial-sexp with a position before + ;; point-min. In that case, just parse from point-min assuming + ;; a nil state. + (parse-partial-sexp (point-min) pos)))))) ;; Debugging functions diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 7544279d8aa..468c46519fd 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -1,6 +1,6 @@ ;;; timer.el --- run a function with args at some time in future -*- lexical-binding: t -*- -;; Copyright (C) 1996, 2001-2023 Free Software Foundation, Inc. +;; Copyright (C) 1996-2023 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Package: emacs @@ -226,8 +226,6 @@ the time of the current timer. That's because the activated timer will fire right away." (timer--activate timer (not dont-wait) reuse-cell 'idle)) -(defalias 'disable-timeout #'cancel-timer) - (defun cancel-timer (timer) "Remove TIMER from the list of active timers." (timer--check timer) @@ -348,7 +346,6 @@ This function is called, by name, directly by the C code." (memq timer timer-list)) (setf (timer--triggered timer) nil)))))) -;; This function is incompatible with the one in levents.el. (defun timeout-event-p (event) "Non-nil if EVENT is a timeout event." (and (listp event) (eq (car event) 'timer-event))) @@ -448,6 +445,7 @@ If REPEAT is non-nil, repeat the timer every REPEAT seconds. This function returns a timer object which you can use in `cancel-timer'. This function is for compatibility; see also `run-with-timer'." + (declare (obsolete run-with-timer "30.1")) (run-with-timer secs repeat function object)) (defun run-with-idle-timer (secs repeat function &rest args) @@ -580,6 +578,9 @@ If the user does not answer after SECONDS seconds, return DEFAULT-VALUE." (dolist (timer timer-idle-list) (if (timerp timer) ;; FIXME: Why test? (setf (timer--triggered timer) nil)))) + +(define-obsolete-function-alias 'disable-timeout #'cancel-timer "30.1") + (provide 'timer) diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index d802648d8ab..3881fe66eb4 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -128,6 +128,8 @@ ;;; Code: +(require 'cl-print) + (defgroup trace nil "Tracing facility for Emacs Lisp functions." :prefix "trace-" @@ -168,13 +170,13 @@ and CONTEXT is a string describing the dynamic context (e.g. values of some global variables)." (let ((print-circle t) (print-escape-newlines t)) - (format "%s%s%d -> %S%s\n" + (format "%s%s%d -> %s%s\n" (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 ;; definition and/or untrace it. - (cons function args) + (cl-prin1-to-string (cons function args)) context))) (defun trace-exit-message (function level value context) @@ -184,13 +186,13 @@ and CONTEXT is a string describing the dynamic context (e.g. values of some global variables)." (let ((print-circle t) (print-escape-newlines t)) - (format "%s%s%d <- %s: %S%s\n" + (format "%s%s%d <- %s: %s%s\n" (mapconcat 'char-to-string (make-string (1- level) ?|) " ") (if (> level 1) " " "") level function ;; Do this so we'll see strings: - value + (cl-prin1-to-string value) context))) (defvar trace--timer nil) diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index 1d3cde69392..e722cbc52dd 100644 --- a/lisp/emacs-lisp/unsafep.el +++ b/lisp/emacs-lisp/unsafep.el @@ -237,7 +237,7 @@ Otherwise result is a reason code." ((eq (car-safe fun) 'lambda) (unsafep fun unsafep-vars)) ((not (and (symbolp fun) - (or (get fun 'side-effect-free) + (or (function-get fun 'side-effect-free) (eq (get fun 'safe-function) t) (eq safe-functions t) (memq fun safe-functions)))) diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 0551053df8e..61670ea69ca 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -240,13 +240,14 @@ See info node `(vtable)Top' for vtable documentation." (defun vtable-beginning-of-table () "Go to the start of the current table." - (if (text-property-search-backward 'vtable (vtable-current-table)) + (if (or (text-property-search-backward 'vtable (vtable-current-table) #'eq) + (get-text-property (point) 'vtable)) (point) (goto-char (point-min)))) (defun vtable-end-of-table () "Go to the end of the current table." - (if (text-property-search-forward 'vtable (vtable-current-table)) + (if (text-property-search-forward 'vtable (vtable-current-table) #'eq) (point) (goto-char (point-max)))) diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 31b840d6c83..b99b1d2ae29 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -106,6 +106,7 @@ so only the element (FOO) will match it." :type '(repeat (repeat symbol)) :version "22.1") +;;;###autoload (defcustom warning-suppress-types nil "List of warning types not to display immediately. If any element of this list matches the TYPE argument to `display-warning', |