diff options
Diffstat (limited to 'lisp/emacs-lisp')
37 files changed, 3476 insertions, 2002 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 56f0ae2212c..3265809f592 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -3131,6 +3131,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..c7d8531a870 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) @@ -215,21 +224,17 @@ for speeding up processing.") (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 optimise 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)) @@ -484,30 +482,22 @@ for speeding up processing.") (cons fn (mapcar #'byte-optimize-form exps))) (`(,(pred (not symbolp)) . ,_) - (byte-compile-warn-x fn "`%s' is a malformed function" fn) + (byte-compile-warn-x form "`%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))) @@ -755,7 +745,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 +786,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) @@ -878,7 +880,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 +979,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) + "Optimise 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 optimiser 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 +1032,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. @@ -1027,7 +1081,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 +1130,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 +1190,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 +1366,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 +1419,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 +1448,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 +1522,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 +1586,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 +1596,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 +1612,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 +1625,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 +1674,241 @@ 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 + 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 equal equal-including-properties + 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 +1933,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,6 +2139,7 @@ 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-cons byte-list1 byte-list2 byte-list3 byte-list4 byte-listN @@ -1967,574 +2203,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 +3004,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..a377ec395e1 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 @@ -649,11 +657,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 +684,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 5df1205869c..5b1d958e6c2 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -295,7 +295,8 @@ The information is logged to `byte-compile-log-buffer'." '(redefine callargs free-vars unresolved obsolete noruntime interactive-only make-local mapcar constants suspicious lexical lexical-dynamic - docstrings docstrings-non-ascii-quotes not-unused) + docstrings docstrings-non-ascii-quotes not-unused + empty-body) "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). @@ -316,7 +317,9 @@ Elements of the list may be: 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. + ignored-return-value + function called without using the return value where this + is likely to be a mistake 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 @@ -326,9 +329,12 @@ Elements of the list may be: docstrings-non-ascii-quotes docstrings that have non-ASCII quotes. This depends on the `docstrings' warning type. suspicious constructs that usually don't do what the coder wanted. + empty-body body argument to a special form or macro is empty. + mutate-constant + code that mutates program constants such as quoted lists 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'. @@ -493,6 +499,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) @@ -528,11 +570,12 @@ Return the compile-time value of 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) + (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 +584,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 +1128,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,24 +1617,23 @@ 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)). +(defun byte-compile--defcustom-type-quoted (type) + "Whether defcustom TYPE contains an accidentally quoted value." + ;; Detect mistakes such as (const 'abc). ;; 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))) + (and (consp type) + (proper-list-p type) + (if (memq (car type) '(const other)) + (assq 'quote type) + (let ((elts (cdr type))) + (while (and elts (not (byte-compile--defcustom-type-quoted + (car elts)))) + (setq elts (cdr elts))) + elts)))) ;; Warn if a custom definition fails to specify :group, or :type. (defun byte-compile-nogroup-warn (form) @@ -1600,10 +1647,10 @@ extra args." (byte-compile-warn-x (cadr name) "defcustom for `%s' fails to specify type" (cadr name))) - ((byte-compile--suspicious-defcustom-choice type) + ((byte-compile--defcustom-type-quoted type) (byte-compile-warn-x (cadr name) - "defcustom for `%s' has syntactically odd type `%s'" + "defcustom for `%s' may have accidentally quoted value in type `%s'" (cadr name) type))))) (if (and (memq (car form) '(custom-declare-face custom-declare-variable)) byte-compile-current-group) @@ -1766,10 +1813,16 @@ It is too wide if it has any lines longer than the largest of kind name 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 "%s%sdocstring has wrong usage of unescaped single quotes" + " (use \\=%c or different quoting such as %c...%c)") + kind name ?' ?` ?')) ;; 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) @@ -3030,6 +3083,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))))) @@ -3405,7 +3466,7 @@ lambda-expression." (let* ((fn (car form)) (handler (get fn 'byte-compile)) (interactive-only - (or (get fn '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 @@ -3413,8 +3474,9 @@ lambda-expression." run-hook-with-args-until-failure)) (pcase (cdr form) (`(',var . ,_) - (when (memq var byte-compile-lexical-variables) - (byte-compile-report-error + (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)) @@ -3432,15 +3494,66 @@ lambda-expression." (format "; %s" (substitute-command-keys interactive-only))) - ((and (symbolp '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 "`%s' defined after use in %S (missing `require' of a library file?)" + (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 optimiser, + ;; 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) @@ -3453,17 +3566,139 @@ lambda-expression." ((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))) +(let ((important-return-value-fns + '( + ;; These functions are side-effect-free except for the + ;; behaviour 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))) @@ -3474,11 +3709,7 @@ lambda-expression." (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 +3967,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 +4046,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 +4115,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 optimisations. + (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 +4283,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 optimisation. + (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 +4306,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 +4316,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 +4370,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 +4492,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 +4754,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 +5019,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 +5248,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 @@ -5487,6 +5683,105 @@ 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))))) + (provide 'byte-compile) (provide 'bytecomp) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 5f37db3fe9b..3e75020a013 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 @@ -463,7 +463,7 @@ places where they originally did not directly appear." ; 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. + ;; Running byte-optimize-form earlier would resolve this. `(funcall ,(cconv-convert `(function ,fun) env extend) ,@(mapcar (lambda (form) @@ -477,24 +477,45 @@ places where they originally did not directly appear." branch)) cond-forms))) - (`(function (lambda ,args . ,body) . ,_) + (`(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) (_ nil))) (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))) + (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 ,cif)))) + `(cconv--interactive-helper + ,cf ,(if wrapped cif `(list 'quote ,cif)))))) (`(internal-make-closure . ,_) (byte-compile-report-error @@ -661,11 +682,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 +758,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 +846,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 +890,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/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index de5eb9c2d92..a89bbc3a748 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)) @@ -566,6 +567,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 diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 152a1fe9434..7fee780a735 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -201,7 +201,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) @@ -459,6 +459,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)) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 43207ce7026..0a3181561bd 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -243,6 +243,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 +360,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) @@ -2052,7 +2076,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 +2782,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 @@ -2887,45 +2915,15 @@ The function's arguments should be treated as immutable. ,(format "compiler-macro for inlining `%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 +3015,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) @@ -3120,19 +3119,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) @@ -3175,8 +3179,9 @@ To see the documentation for a defined struct type, use (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 +3189,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,19 +3244,8 @@ 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)) @@ -3272,7 +3267,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,6 +3283,7 @@ To see the documentation for a defined struct type, use ;;; Add cl-struct support to pcase +;;In use by comp.el (defun cl--struct-all-parents (class) (when (cl--struct-class-p class) (let ((res ()) @@ -3684,14 +3683,53 @@ macro that returns its `&whole' argument." ;;; 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 + ;; behaviour 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..f410270d340 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -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) diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 61586526ca1..71929caabb8 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) @@ -176,6 +176,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. @@ -230,26 +233,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 +248,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,6 +258,9 @@ 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! + (cl-defmethod cl-print-object ((object string) stream) (unless stream (setq stream standard-output)) (let* ((has-properties (or (text-properties-at 0 object) @@ -278,7 +271,7 @@ into a button whose action shows the function's disassembly.") 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 +287,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 @@ -328,35 +329,13 @@ into a button whose action shows the function's disassembly.") (min (+ start print-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 +346,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 +423,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 +489,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 +504,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)))) @@ -516,22 +539,25 @@ characters with appropriate settings of `print-level' and 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. +`print-length' bound to nil, and it can also be t in which case +PRINT-FUNCTION will be called with the current values of `print-level' +and `print-length'. 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 + ((null limit) nil) + ((eq limit t) print-length) + (t (min limit 50)))) + (print-level (cond + ((null limit) nil) + ((eq limit t) print-level) + (t (min 8 (truncate (log limit)))))) + (delta-length (when (natnump limit) (max 1 (truncate (/ print-length print-level)))))) (with-temp-buffer (catch 'done @@ -541,7 +567,7 @@ 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)))) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 787232067a1..7e3ca1f3bae 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-macs) (defconst comp--typeof-builtin-types (mapcar (lambda (x) (append x '(t))) @@ -86,7 +87,41 @@ 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." + `(,@(mapcar #'cl--struct-class-name (cl--struct-all-parents + (cl--struct-get-class x))) + 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 +142,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)) @@ -230,7 +274,7 @@ Return them as multiple value." (cl-loop named outer with found = nil - for l in comp--typeof-builtin-types + for l in (comp-cstr-ctxt-typeof-types comp-ctxt) do (cl-loop for x in l for i from (length l) downto 0 @@ -273,7 +317,7 @@ Return them as multiple value." (cl-loop with types = (apply #'append typesets) with res = '() - for lane in comp--typeof-builtin-types + for lane in (comp-cstr-ctxt-typeof-types comp-ctxt) do (cl-loop with last = nil for x in lane @@ -867,6 +911,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 +1182,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 +1237,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.el b/lisp/emacs-lisp/comp.el index 322df0e86a1..b35e1b97e9d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -186,8 +186,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. @@ -276,10 +277,10 @@ 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: + ;; 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)) @@ -306,7 +307,8 @@ Useful to hook into pass checkers.") (bignump (function (t) boolean)) (bobp (function () boolean)) (bolp (function () boolean)) - (bool-vector-count-consecutive (function (bool-vector boolean integer) fixnum)) + (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)) @@ -316,10 +318,12 @@ Useful to hook into pass checkers.") (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-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)) + (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))) @@ -339,17 +343,27 @@ Useful to hook into pass checkers.") (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))) + (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)) + (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)) + (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)) @@ -362,7 +376,7 @@ Useful to hook into pass checkers.") (current-time-zone (function (&optional (or number list) (or symbol string cons integer)) cons)) - (custom-variable-p (function (symbol) boolean)) + (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) @@ -371,7 +385,8 @@ Useful to hook into pass checkers.") (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))) + (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))) @@ -384,18 +399,18 @@ Useful to hook into pass checkers.") (error-message-string (function (list) string)) (eventp (function (t) boolean)) (exp (function (number) float)) - (expt (function (number 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) 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) boolean)) + (file-symlink-p (function (string) (or boolean string))) (file-writable-p (function (string) boolean)) (fixnump (function (t) boolean)) (float (function (number) float)) @@ -410,13 +425,15 @@ Useful to hook into pass checkers.") (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)) + (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-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))) @@ -461,7 +478,10 @@ Useful to hook into pass checkers.") (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-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)) @@ -479,7 +499,9 @@ Useful to hook into pass checkers.") (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 *)))) + (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)) @@ -505,7 +527,7 @@ Useful to hook into pass checkers.") (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)) + (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)) @@ -543,7 +565,8 @@ Useful to hook into pass checkers.") (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))) + (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)) @@ -640,11 +663,14 @@ Useful to hook into pass checkers.") (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) "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) @@ -1107,7 +1133,8 @@ with `message'. Otherwise, log with `comp-log-to-buffer'." (log-buffer (or (get-buffer comp-log-buffer-name) (with-current-buffer (get-buffer-create comp-log-buffer-name) - (setf buffer-read-only t) + (unless (derived-mode-p 'compilation-mode) + (emacs-lisp-compilation-mode)) (current-buffer)))) (log-window (get-buffer-window log-buffer)) (inhibit-read-only t) @@ -1241,7 +1268,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,33 +1301,45 @@ clashes." (make-temp-file (comp-c-func-name function-name "freefn-") nil ".eln"))) (let* ((f (symbol-function function-name)) + (byte-code (byte-compile 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)))) + (func + (if (comp-lex-byte-func-p byte-code) + (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)) + (make-comp-func-d :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))))) (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))) + '("can't native compile an already byte-compiled function"))) + (setf (comp-func-byte-func func) byte-code) (let ((lap (byte-to-native-lambda-lap (gethash (aref (comp-func-byte-func func) 1) byte-to-native-lambdas-h)))) (cl-assert lap) (comp-log lap 2 t) - (let ((arg-list (aref (comp-func-byte-func func) 0))) - (setf (comp-func-l-args func) - (comp-decrypt-arg-list arg-list function-name) - (comp-func-lap func) - lap - (comp-func-frame-size func) - (comp-byte-frame-size (comp-func-byte-func func)))) - (setf (comp-ctxt-top-level-forms comp-ctxt) + (if (comp-func-l-p func) + (let ((arg-list (aref (comp-func-byte-func func) 0))) + (setf (comp-func-l-args func) + (comp-decrypt-arg-list arg-list function-name))) + (setf (comp-func-d-lambda-list func) (cadr f))) + (setf (comp-func-lap func) + lap + (comp-func-frame-size func) + (comp-byte-frame-size (comp-func-byte-func func)) + (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)))) @@ -1309,7 +1348,7 @@ clashes." "Byte-compile FORM, spilling data from the byte compiler." (unless (eq (car-safe form) 'lambda) (signal 'native-compiler-error - "Cannot native-compile, form is not a lambda")) + '("Cannot native-compile, form is not a lambda"))) (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) (make-temp-file "comp-lambda-" nil ".eln"))) @@ -1390,7 +1429,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 @@ -1427,11 +1466,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. @@ -1539,7 +1580,7 @@ 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 @@ -1547,6 +1588,8 @@ STACK-OFF is the index of the first slot frame involved." (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) @@ -1711,14 +1754,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." @@ -1761,7 +1805,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. @@ -2535,6 +2579,19 @@ 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)) + (push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag))) + (comp-block-insns (comp-add-cond-cstrs-target-block b bb2))) + (push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag) :neg t)) + (comp-block-insns (comp-add-cond-cstrs-target-block b bb1)))) (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp-call-op-p) ,(and (or (pred comp-equality-fun-p) @@ -2849,7 +2906,7 @@ blocks." (first-processed (l) (if-let ((p (cl-find-if (lambda (p) (comp-block-idom p)) 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)) @@ -3190,7 +3247,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." @@ -3749,7 +3810,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)))))))) @@ -4037,7 +4098,8 @@ display a message." :buffer (with-current-buffer (get-buffer-create comp-async-buffer-name) - (setf buffer-read-only t) + (unless (derived-mode-p 'compilation-mode) + (emacs-lisp-compilation-mode)) (current-buffer)) :command (list (expand-file-name invocation-name @@ -4071,6 +4133,8 @@ display a message." (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")))) @@ -4178,6 +4242,7 @@ LOAD and SELECTOR work as described in `native--compile-async'." (string-match-p re file)) native-comp-jit-compilation-deny-list)))) +;;;###autoload (defun native--compile-async (files &optional recursively load selector) ;; BEWARE, this function is also called directly from C. "Compile FILES asynchronously. @@ -4231,8 +4296,9 @@ bytecode definition was not changed in the meantime)." ;; 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=)) + (setf comp-files-queue + (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)) @@ -4409,6 +4475,27 @@ of (commands) to run simultaneously." (delete-directory subdir)))))) (message "Cache cleared")) +;;;###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 (gethash function comp-known-func-cstr-h))) + (setf type-spec (comp-cstr-to-type-spec res))) + (let ((f (symbol-function function))) + (when (and (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) ;; LocalWords: limplified limplification limplify Limple LIMPLE libgccjit elc eln diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 9dd08d00920..dd59a2e02e1 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") diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 98c211325ab..20681374ee3 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -250,7 +250,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 +418,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)) @@ -693,6 +696,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 +737,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)) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 2f7d03e9d79..9a06807bcdc 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 @@ -2851,81 +2853,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.el b/lisp/emacs-lisp/eieio.el index 064a55f2727..9a1f5b9db0f 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))) diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index a175edcc671..18d3eb37af3 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.14.0 ;; Package-Requires: ((emacs "26.3")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -296,13 +296,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)) @@ -321,6 +317,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)) @@ -388,7 +391,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. @@ -435,7 +437,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 @@ -446,6 +448,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) @@ -469,8 +482,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. @@ -488,46 +499,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'." @@ -613,15 +648,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)))))) @@ -642,38 +677,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))) @@ -778,7 +820,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 @@ -798,8 +840,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. @@ -836,9 +881,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 @@ -848,7 +894,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 @@ -856,7 +902,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)) @@ -868,19 +914,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 iself 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; 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/gv.el b/lisp/emacs-lisp/gv.el index 6adba6c342f..a5e29dd5e3b 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -417,9 +417,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) @@ -639,6 +639,13 @@ REF must have been previously obtained with `gv-ref'." ;;; Generalized variables. +;; You'd think noone 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 diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index d44c9d6e23d..3bf9a2f10db 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -134,7 +134,7 @@ (purecopy (concat "^\\s-*(" (regexp-opt '(;; Elisp - "defconst" "defcustom" + "defconst" "defcustom" "defvar-keymap" ;; CL "defconstant" "defparameter" "define-symbol-macro") @@ -361,7 +361,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 +876,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 +1453,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 17d58b1e3c6..a4aa79c171e 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -529,6 +529,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/macroexp.el b/lisp/emacs-lisp/macroexp.el index 168de1bf180..083a7f58f36 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -227,84 +227,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. @@ -338,14 +333,19 @@ Assumes the caller has bound `macroexpand-all-environment'." (`(cond . ,clauses) (macroexp--cons fn (macroexp--all-clauses clauses) 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 +367,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 +397,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 +431,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,24 +472,11 @@ 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))) - ;;;###autoload (defun macroexpand-all (form &optional environment) "Return result of expanding macros at all levels in FORM. diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 7a48ba47434..b55eb431668 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -50,18 +50,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 +73,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 +598,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..cd80df2c41d 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)) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index f5a150ac4ae..466822e0e06 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -50,7 +50,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) @@ -568,7 +568,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 b4c911015b5..db8b41aee6a 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -112,6 +112,11 @@ the `clone' function." vc-handled-backends)) :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 @@ -339,6 +344,40 @@ asynchronously." "\n") nil pkg-file nil 'silent)))) +(defcustom package-vc-allow-side-effects nil + "Whether to process :make and :shell-command spec arguments. + +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. + +When set to a list of symbols (packages), run commands for only +packages in the list. When nil, never run commands. Otherwise +when non-nil, run commands for any package with :make or +:shell-command specified. + +Package specs are loaded from trusted package archives." + :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) @@ -484,6 +523,12 @@ 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-side-effects t) + (memq (package-desc-name pkg-desc) + package-vc-allow-side-effects)) + (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))) @@ -539,6 +584,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' @@ -560,6 +607,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))) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 58ca19f7fe2..6ce00bf4d6d 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)) "/")) @@ -1200,7 +1191,7 @@ 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")) + (unless (search-forward (concat ";;; " file-name ".el ends here") nil 'move) (lwarn '(package package-format) :warning "Package lacks a terminating comment")) ;; Try to include a trailing newline. @@ -1228,8 +1219,8 @@ boundaries." :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 +1228,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)) @@ -2268,25 +2258,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 +2288,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 +2312,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))) @@ -2738,7 +2740,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)) + (cdr (assoc :maintainer extras)))) (authors (cdr (assoc :authors extras))) (news (and-let* (pkg-dir ((not built-in)) @@ -2873,19 +2876,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))) @@ -3128,8 +3133,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)) @@ -3569,9 +3573,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)]))) @@ -4627,6 +4630,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..1c5ce5169ab 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -947,7 +947,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..550fab2f4b3 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -52,53 +52,237 @@ 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)) + (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) + (save-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 +290,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 +410,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/rx.el b/lisp/emacs-lisp/rx.el index 30195cbae32..d46d0ca5a98 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -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 @@ -167,7 +202,7 @@ 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)))) @@ -419,80 +454,96 @@ a list of named character classes in the order they occur in BODY." 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. + (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 'anything) + (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))))) @@ -596,10 +647,28 @@ If NEGATED, negate the sense (thus making it positive)." (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)))) + (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--charset-intervals (charset) "Return a sorted list of non-adjacent disjoint intervals from CHARSET. @@ -783,7 +852,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 @@ -1150,6 +1222,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/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index f5cbb2e645f..dbc061d8a70 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/subr-x.el b/lisp/emacs-lisp/subr-x.el index b164071763b..78dc58e0bcd 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 @@ -317,6 +331,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 @@ -340,6 +355,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..d8f6c58f6ca 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)) 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)))) |