diff options
Diffstat (limited to 'lisp/emacs-lisp')
51 files changed, 2468 insertions, 2120 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 9489a9fd1b3..752660156b9 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2042,8 +2042,6 @@ in that CLASS." function class name))) (error "ad-remove-advice: `%s' is not advised" function))) -(declare-function comp-subr-trampoline-install "comp-run") - ;;;###autoload (defun ad-add-advice (function advice class position) "Add a piece of ADVICE to FUNCTION's list of advices in CLASS. diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 73745e8c7ac..42ba89ba2c1 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -204,6 +204,9 @@ ('str (bindat--unpack-str len)) ('strz (bindat--unpack-strz len)) ('vec + (when (> len (length bindat-raw)) + (error "Vector length %d is greater than raw data length %d" + len (length bindat-raw))) (let ((v (make-vector len 0)) (vlen 1)) (if (consp vectype) (setq vlen (nth 1 vectype) @@ -941,9 +944,13 @@ a bindat type expression." (bindat-defmacro sint (bitlen le) "Signed integer of size BITLEN. Big-endian if LE is nil and little-endian if not." + (unless lexical-binding + (error "The `sint' type requires 'lexical-binding'")) (let ((bl (make-symbol "bitlen")) (max (make-symbol "max")) (wrap (make-symbol "wrap"))) + ;; FIXME: This `let*' around the `struct' results in code which the + ;; byte-compiler does not handle efficiently. 🙁 `(let* ((,bl ,bitlen) (,max (ash 1 (1- ,bl))) (,wrap (+ ,max ,max))) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index add13a5c312..ea163723a3e 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -482,9 +482,6 @@ There can be multiple entries for the same NAME if it has several aliases.") (push name byte-optimize--dynamic-vars) `(,fn ,name . ,optimized-rest))) - (`(,(pred byte-code-function-p) . ,exps) - (cons fn (mapcar #'byte-optimize-form exps))) - ((guard (when for-effect (if-let ((tmp (byte-opt--fget fn 'side-effect-free))) (or byte-compile-delete-errors @@ -1448,7 +1445,8 @@ See Info node `(elisp) Integer Basics'." (defun byte-optimize-apply (form) (let ((len (length form))) - (if (>= len 2) + ;; Single-arg `apply' is an abomination that we don't bother optimizing. + (if (> len 2) (let ((fn (nth 1 form)) (last (nth (1- len) form))) (cond @@ -1774,7 +1772,7 @@ See Info node `(elisp) Integer Basics'." string-version-lessp substring substring-no-properties sxhash-eq sxhash-eql sxhash-equal sxhash-equal-including-properties - take vconcat + take value< vconcat ;; frame.c frame-ancestor-p frame-bottom-divider-width frame-char-height frame-char-width frame-child-frame-border-width frame-focus @@ -1975,7 +1973,7 @@ See Info node `(elisp) Integer Basics'." 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 + string-search string-version-lessp take value< ;; search.c regexp-quote ;; syntax.c @@ -3115,7 +3113,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; (eval-when-compile (or (compiled-function-p (symbol-function 'byte-optimize-form)) - (assq 'byte-code (symbol-function 'byte-optimize-form)) (let ((byte-optimize nil) (byte-compile-warnings nil)) (mapc (lambda (x) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 1ef3f0fba6d..2b5eb34e571 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -231,17 +231,8 @@ This includes variable references and calls to functions such as `car'." :type 'boolean) (defvar byte-compile-dynamic nil - "If non-nil, compile function bodies so they load lazily. -They are hidden in comments in the compiled file, -and each one is brought into core when the -function is called. - -To enable this option, make it a file-local variable -in the source file you want it to apply to. -For example, add -*-byte-compile-dynamic: t;-*- on the first line. - -When this option is true, if you load the compiled file and then move it, -the functions you loaded will not be able to run.") + "Formerly used to compile function bodies so they load lazily. +This variable no longer has any effect.") (make-obsolete-variable 'byte-compile-dynamic "not worthwhile any more." "27.1") ;;;###autoload(put 'byte-compile-dynamic 'safe-local-variable 'booleanp) @@ -262,7 +253,7 @@ This option is enabled by default because it reduces Emacs memory usage." :type 'boolean) ;;;###autoload(put 'byte-compile-dynamic-docstrings 'safe-local-variable 'booleanp) -(defconst byte-compile-log-buffer "*Compile-Log*" +(defvar byte-compile-log-buffer "*Compile-Log*" "Name of the byte-compiler's log buffer.") (defvar byte-compile--known-dynamic-vars nil @@ -294,6 +285,7 @@ The information is logged to `byte-compile-log-buffer'." (defconst byte-compile-warning-types '( callargs constants docstrings docstrings-non-ascii-quotes docstrings-wide + docstrings-control-chars empty-body free-vars ignored-return-value interactive-only lexical lexical-dynamic make-local mapcar ; obsolete @@ -316,6 +308,8 @@ Elements of the list may be: docstrings that are too wide, containing lines longer than both `byte-compile-docstring-max-column' and `fill-column' characters. Only enabled when `docstrings' also is. + docstrings-control-chars + docstrings that contain control characters other than NL and TAB empty-body body argument to a special form or macro is empty. free-vars references to variables not in the current lexical scope. ignored-return-value @@ -354,7 +348,7 @@ A value of `all' really means all." '(docstrings-non-ascii-quotes) "List of warning types that are only enabled during Emacs builds. This is typically either warning types that are being phased in -(but shouldn't be enabled for packages yet), or that are only relevant +\(but shouldn't be enabled for packages yet), or that are only relevant for the Emacs build itself.") (defvar byte-compile--suppressed-warnings nil @@ -1749,68 +1743,100 @@ Also ignore URLs." The byte-compiler will emit a warning for documentation strings containing lines wider than this. If `fill-column' has a larger value, it will override this variable." - :group 'bytecomp :type 'natnum :safe #'natnump :version "28.1") -(define-obsolete-function-alias 'byte-compile-docstring-length-warn - 'byte-compile-docstring-style-warn "29.1") - -(defun byte-compile-docstring-style-warn (form) - "Warn if there are stylistic problems with the docstring in FORM. -Warn if documentation string of FORM is too wide. +(defun byte-compile--list-with-n (list n elem) + "Return LIST with its Nth element replaced by ELEM." + (if (eq elem (nth n list)) + list + (nconc (take n list) + (list elem) + (nthcdr (1+ n) list)))) + +(defun byte-compile--docstring-style-warn (docs kind name) + "Warn if there are stylistic problems in the docstring DOCS. +Warn if documentation string is too wide. It is too wide if it has any lines longer than the largest of `fill-column' and `byte-compile-docstring-max-column'." (when (byte-compile-warning-enabled-p 'docstrings) - (let* ((kind nil) (name nil) (docs nil) + (let* ((name (if (eq (car-safe name) 'quote) (cadr name) name)) (prefix (lambda () (format "%s%s" kind - (if name (format-message " `%s' " name) ""))))) - (pcase (car form) - ((or 'autoload 'custom-declare-variable 'defalias - 'defconst 'define-abbrev-table - 'defvar 'defvaralias - 'custom-declare-face) - (setq kind (nth 0 form)) - (setq name (nth 1 form)) - (when (and (consp name) (eq (car name) 'quote)) - (setq name (cadr name))) - (setq docs (nth 3 form))) - ('lambda - (setq kind "") ; can't be "function", unfortunately - (setq docs (nth 2 form)))) - (when (and kind docs (stringp docs)) - (let ((col (max byte-compile-docstring-max-column fill-column))) - (when (and (byte-compile-warning-enabled-p 'docstrings-wide) - (byte-compile--wide-docstring-p docs col)) - (byte-compile-warn-x - name - "%sdocstring wider than %s characters" (funcall prefix) col))) - ;; There's a "naked" ' character before a symbol/list, so it - ;; should probably be quoted with \=. - (when (string-match-p (rx (| (in " \t") bol) - (? (in "\"#")) - "'" - (in "A-Za-z" "(")) + (if name (format-message " `%S' " name) ""))))) + (let ((col (max byte-compile-docstring-max-column fill-column))) + (when (and (byte-compile-warning-enabled-p 'docstrings-wide) + (byte-compile--wide-docstring-p docs col)) + (byte-compile-warn-x + name + "%sdocstring wider than %s characters" (funcall prefix) col))) + + (when (byte-compile-warning-enabled-p 'docstrings-control-chars) + (let ((start 0) + (len (length docs))) + (while (and (< start len) + (string-match (rx (intersection (in (0 . 31) 127) + (not (in "\n\t")))) + docs start)) + (let* ((ofs (match-beginning 0)) + (c (aref docs ofs))) + ;; FIXME: it should be possible to use the exact source position + ;; of the control char in most cases, and it would be helpful + (byte-compile-warn-x + name + "%sdocstring contains control char #x%02x (position %d)" + (funcall prefix) c ofs) + (setq start (1+ ofs)))))) + + ;; There's a "naked" ' character before a symbol/list, so it + ;; should probably be quoted with \=. + (when (string-match-p (rx (| (in " \t") bol) + (? (in "\"#")) + "'" + (in "A-Za-z" "(")) + docs) + (byte-compile-warn-x + name + (concat "%sdocstring has wrong usage of unescaped single quotes" + " (use \\=%c or different quoting such as %c...%c)") + (funcall prefix) ?' ?` ?')) + ;; There's a "Unicode quote" in the string -- it should probably + ;; be an ASCII one instead. + (when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes) + (when (string-match-p (rx (| " \"" (in " \t") bol) + (in "‘’")) docs) (byte-compile-warn-x name - (concat "%sdocstring has wrong usage of unescaped single quotes" - " (use \\=%c or different quoting such as %c...%c)") - (funcall prefix) ?' ?` ?')) - ;; There's a "Unicode quote" in the string -- it should probably - ;; be an ASCII one instead. - (when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes) - (when (string-match-p (rx (| " \"" (in " \t") bol) - (in "‘’")) - docs) - (byte-compile-warn-x - name - "%sdocstring uses curved single quotes; use %s instead of ‘...’" - (funcall prefix) "`...'")))))) - form) + "%sdocstring uses curved single quotes; use %s instead of ‘...’" + (funcall prefix) "`...'")))))) + +(defvar byte-compile--\#$) ; Special value that will print as `#$'. +(defvar byte-compile--docstrings nil "Table of already compiled docstrings.") + +(defun byte-compile--docstring (doc kind name &optional is-a-value) + (byte-compile--docstring-style-warn doc kind name) + ;; Make docstrings dynamic, when applicable. + (cond + ((and byte-compile-dynamic-docstrings + ;; The native compiler doesn't use those dynamic docstrings. + (not byte-native-compiling) + ;; Docstrings can only be dynamic when compiling a file. + byte-compile--\#$) + (let* ((byte-pos (with-memoization + ;; Reuse a previously written identical docstring. + ;; This is not done out of thriftiness but to try and + ;; make sure that "equal" functions remain `equal'. + ;; (Often those identical docstrings come from + ;; `help-add-fundoc-usage'). + ;; Needed e.g. for `advice-tests-nadvice'. + (gethash doc byte-compile--docstrings) + (byte-compile-output-as-comment doc nil))) + (newdoc (cons byte-compile--\#$ byte-pos))) + (if is-a-value newdoc (macroexp-quote newdoc)))) + (t doc))) ;; If we have compiled any calls to functions which are not known to be ;; defined, issue a warning enumerating them. @@ -1845,6 +1871,8 @@ It is too wide if it has any lines longer than the largest of ;; macroenvironment. (copy-alist byte-compile-initial-macro-environment)) (byte-compile--outbuffer nil) + (byte-compile--\#$ nil) + (byte-compile--docstrings (make-hash-table :test 'equal)) (overriding-plist-environment nil) (byte-compile-function-environment nil) (byte-compile-bound-variables nil) @@ -1858,7 +1886,6 @@ It is too wide if it has any lines longer than the largest of ;; (byte-compile-verbose byte-compile-verbose) (byte-optimize byte-optimize) - (byte-compile-dynamic byte-compile-dynamic) (byte-compile-dynamic-docstrings byte-compile-dynamic-docstrings) (byte-compile-warnings byte-compile-warnings) @@ -1874,39 +1901,44 @@ It is too wide if it has any lines longer than the largest of (setq byte-to-native-plist-environment overriding-plist-environment))))) -(defmacro displaying-byte-compile-warnings (&rest body) +(defmacro displaying-byte-compile-warnings (&rest body) ;FIXME: namespace! (declare (debug (def-body))) `(bytecomp--displaying-warnings (lambda () ,@body))) (defun bytecomp--displaying-warnings (body-fn) - (let* ((warning-series-started + (let* ((wrapped-body + (lambda () + (if byte-compile-debug + (funcall body-fn) + ;; Use a `handler-bind' to remember the `byte-compile-form-stack' + ;; active at the time the error is signaled, so as to + ;; get more precise error locations. + (let ((form-stack nil)) + (condition-case error-info + (handler-bind + ((error (lambda (_err) + (setq form-stack byte-compile-form-stack)))) + (funcall body-fn)) + (error (let ((byte-compile-form-stack form-stack)) + (byte-compile-report-error error-info)))))))) + (warning-series-started (and (markerp warning-series) (eq (marker-buffer warning-series) (get-buffer byte-compile-log-buffer)))) (byte-compile-form-stack byte-compile-form-stack)) - (if (or (eq warning-series 'byte-compile-warning-series) + (if (or (eq warning-series #'byte-compile-warning-series) warning-series-started) ;; warning-series does come from compilation, ;; so don't bind it, but maybe do set it. - (let (tem) - ;; Log the file name. Record position of that text. - (setq tem (byte-compile-log-file)) + (let ((tem (byte-compile-log-file))) ;; Log the file name. (unless warning-series-started - (setq warning-series (or tem 'byte-compile-warning-series))) - (if byte-compile-debug - (funcall body-fn) - (condition-case error-info - (funcall body-fn) - (error (byte-compile-report-error error-info))))) + (setq warning-series (or tem #'byte-compile-warning-series))) + (funcall wrapped-body)) ;; warning-series does not come from compilation, so bind it. (let ((warning-series ;; Log the file name. Record position of that text. - (or (byte-compile-log-file) 'byte-compile-warning-series))) - (if byte-compile-debug - (funcall body-fn) - (condition-case error-info - (funcall body-fn) - (error (byte-compile-report-error error-info)))))))) + (or (byte-compile-log-file) #'byte-compile-warning-series))) + (funcall wrapped-body))))) ;;;###autoload (defun byte-force-recompile (directory) @@ -2368,7 +2400,12 @@ With argument ARG, insert value in current buffer after the form." (setq case-fold-search nil)) (displaying-byte-compile-warnings (with-current-buffer inbuffer - (when byte-compile-current-file + (when byte-compile-dest-file + (setq byte-compile--\#$ + (copy-sequence ;It needs to be a fresh new object. + ;; Also it stands for the `load-file-name' when the `.elc' will + ;; be loaded, so make it look like it. + byte-compile-dest-file)) (byte-compile-insert-header byte-compile-current-file byte-compile--outbuffer) ;; Instruct native-comp to ignore this file. @@ -2423,8 +2460,7 @@ With argument ARG, insert value in current buffer after the form." (defun byte-compile-insert-header (_filename outbuffer) "Insert a header at the start of OUTBUFFER. Call from the source buffer." - (let ((dynamic byte-compile-dynamic) - (optimize byte-optimize)) + (let ((optimize byte-optimize)) (with-current-buffer outbuffer (goto-char (point-min)) ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After @@ -2458,18 +2494,11 @@ Call from the source buffer." ((eq optimize 'byte) " byte-level optimization only") (optimize " all optimizations") (t "out optimization")) - ".\n" - (if dynamic ";;; Function definitions are lazy-loaded.\n" - "") - "\n\n")))) + ".\n\n\n")))) (defun byte-compile-output-file-form (form) ;; Write the given form to the output buffer, being careful of docstrings - ;; (for `byte-compile-dynamic-docstrings') in defvar, defvaralias, - ;; defconst, autoload, and custom-declare-variable. - ;; defalias calls are output directly by byte-compile-file-form-defmumble; - ;; it does not pay to first build the defalias in defmumble and then parse - ;; it here. + ;; (for `byte-compile-dynamic-docstrings'). (when byte-native-compiling ;; Spill output for the native compiler here (push (make-byte-to-native-top-level :form form :lexical lexical-binding) @@ -2479,152 +2508,17 @@ Call from the source buffer." (print-level nil) (print-quoted t) (print-gensym t) - (print-circle t)) ; Handle circular data structures. - (if (memq (car-safe form) '(defvar defvaralias defconst - autoload custom-declare-variable)) - (byte-compile-output-docform nil nil nil '("\n(" ")") form nil 3 nil - (memq (car form) - '(defvaralias autoload - custom-declare-variable))) - (princ "\n" byte-compile--outbuffer) - (prin1 form byte-compile--outbuffer) - nil))) + (print-circle t) + (print-continuous-numbering t) + (print-number-table (make-hash-table :test #'eq))) + (when byte-compile--\#$ + (puthash byte-compile--\#$ "#$" print-number-table)) + (princ "\n" byte-compile--outbuffer) + (prin1 form byte-compile--outbuffer) + nil)) (defvar byte-compile--for-effect) -(defun byte-compile--output-docform-recurse - (info position form cvecindex docindex specindex quoted) - "Print a form with a doc string. INFO is (prefix postfix). -POSITION is where the next doc string is to be inserted. -CVECINDEX is the index in the FORM of the constant vector, or nil. -DOCINDEX is the index of the doc string (or nil) in the FORM. -If SPECINDEX is non-nil, it is the index in FORM -of the function bytecode string. In that case, -we output that argument and the following argument -\(the constants vector) together, for lazy loading. -QUOTED says that we have to put a quote before the -list that represents a doc string reference. -`defvaralias', `autoload' and `custom-declare-variable' need that. - -Return the position after any inserted docstrings as comments." - (let ((index 0) - doc-string-position) - ;; Insert the doc string, and make it a comment with #@LENGTH. - (when (and byte-compile-dynamic-docstrings - (stringp (nth docindex form))) - (goto-char position) - (setq doc-string-position - (byte-compile-output-as-comment - (nth docindex form) nil) - position (point)) - (goto-char (point-max))) - - (insert (car info)) - (prin1 (car form) byte-compile--outbuffer) - (while (setq form (cdr form)) - (setq index (1+ index)) - (insert " ") - (cond ((and (numberp specindex) (= index specindex) - ;; Don't handle the definition dynamically - ;; if it refers (or might refer) - ;; to objects already output - ;; (for instance, gensyms in the arg list). - (let (non-nil) - (when (hash-table-p print-number-table) - (maphash (lambda (_k v) (if v (setq non-nil t))) - print-number-table)) - (not non-nil))) - ;; Output the byte code and constants specially - ;; for lazy dynamic loading. - (goto-char position) - (let ((lazy-position (byte-compile-output-as-comment - (cons (car form) (nth 1 form)) - t))) - (setq position (point)) - (goto-char (point-max)) - (princ (format "(#$ . %d) nil" lazy-position) - byte-compile--outbuffer) - (setq form (cdr form)) - (setq index (1+ index)))) - ((eq index cvecindex) - (let* ((cvec (car form)) - (len (length cvec)) - (index2 0) - elt) - (insert "[") - (while (< index2 len) - (setq elt (aref cvec index2)) - (if (byte-code-function-p elt) - (setq position - (byte-compile--output-docform-recurse - '("#[" "]") position - (append elt nil) ; Convert the vector to a list. - 2 4 specindex nil)) - (prin1 elt byte-compile--outbuffer)) - (setq index2 (1+ index2)) - (unless (eq index2 len) - (insert " "))) - (insert "]"))) - ((= index docindex) - (cond - (doc-string-position - (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") - doc-string-position) - byte-compile--outbuffer)) - ((stringp (car form)) - (let ((print-escape-newlines nil)) - (goto-char (prog1 (1+ (point)) - (prin1 (car form) - byte-compile--outbuffer))) - (insert "\\\n") - (goto-char (point-max)))) - (t (prin1 (car form) byte-compile--outbuffer)))) - (t (prin1 (car form) byte-compile--outbuffer)))) - (insert (cadr info)) - position)) - -(defun byte-compile-output-docform (preface tailpiece name info form - cvecindex docindex - specindex quoted) - "Print a form with a doc string. INFO is (prefix postfix). -If PREFACE, NAME, and TAILPIECE are non-nil, print them too, -before/after INFO and the FORM but after the doc string itself. -CVECINDEX is the index in the FORM of the constant vector, or nil. -DOCINDEX is the index of the doc string (or nil) in the FORM. -If SPECINDEX is non-nil, it is the index in FORM -of the function bytecode string. In that case, -we output that argument and the following argument -\(the constants vector) together, for lazy loading. -QUOTED says that we have to put a quote before the -list that represents a doc string reference. -`defvaralias', `autoload' and `custom-declare-variable' need that." - ;; We need to examine byte-compile-dynamic-docstrings - ;; in the input buffer (now current), not in the output buffer. - (let ((byte-compile-dynamic-docstrings byte-compile-dynamic-docstrings)) - (with-current-buffer byte-compile--outbuffer - (let ((position (point)) - (print-continuous-numbering t) - print-number-table - ;; FIXME: The bindings below are only needed for when we're - ;; called from ...-defmumble. - (print-escape-newlines t) - (print-length nil) - (print-level nil) - (print-quoted t) - (print-gensym t) - (print-circle t)) ; Handle circular data structures. - (when preface - ;; FIXME: We don't handle uninterned names correctly. - ;; E.g. if cl-define-compiler-macro uses uninterned name we get: - ;; (defalias '#1=#:foo--cmacro #[514 ...]) - ;; (put 'foo 'compiler-macro '#:foo--cmacro) - (insert preface) - (prin1 name byte-compile--outbuffer)) - (byte-compile--output-docform-recurse - info position form cvecindex docindex specindex quoted) - (when tailpiece - (insert tailpiece)))))) - (defun byte-compile-keep-pending (form &optional handler) (if (memq byte-optimize '(t source)) (setq form (byte-optimize-one-form form t))) @@ -2644,7 +2538,7 @@ list that represents a doc string reference. (if byte-compile-output (let ((form (byte-compile-out-toplevel t 'file))) (cond ((eq (car-safe form) 'progn) - (mapc 'byte-compile-output-file-form (cdr form))) + (mapc #'byte-compile-output-file-form (cdr form))) (form (byte-compile-output-file-form form))) (setq byte-compile-constants nil @@ -2719,12 +2613,12 @@ list that represents a doc string reference. (setq byte-compile-unresolved-functions (delq (assq funsym byte-compile-unresolved-functions) byte-compile-unresolved-functions))))) - (if (stringp (nth 3 form)) - (prog1 - form - (byte-compile-docstring-style-warn form)) - ;; No doc string, so we can compile this as a normal form. - (byte-compile-keep-pending form 'byte-compile-normal-call))) + (let* ((doc (nth 3 form)) + (newdoc (if (not (stringp doc)) doc + (byte-compile--docstring + doc 'autoload (nth 1 form))))) + (byte-compile-keep-pending (byte-compile--list-with-n form 3 newdoc) + #'byte-compile-normal-call))) (put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) (put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar) @@ -2736,9 +2630,10 @@ list that represents a doc string reference. (byte-compile-warn-x sym "global/dynamic var `%s' lacks a prefix" sym))) -(defun byte-compile--declare-var (sym) +(defun byte-compile--declare-var (sym &optional not-toplevel) (byte-compile--check-prefixed-var sym) - (when (memq sym byte-compile-lexical-variables) + (when (and (not not-toplevel) + (memq sym byte-compile-lexical-variables)) (setq byte-compile-lexical-variables (delq sym byte-compile-lexical-variables)) (when (byte-compile-warning-enabled-p 'lexical sym) @@ -2747,19 +2642,7 @@ list that represents a doc string reference. (push sym byte-compile--seen-defvars)) (defun byte-compile-file-form-defvar (form) - (let ((sym (nth 1 form))) - (byte-compile--declare-var sym) - (if (eq (car form) 'defconst) - (push sym byte-compile-const-variables))) - (if (and (null (cddr form)) ;No `value' provided. - (eq (car form) 'defvar)) ;Just a declaration. - nil - (byte-compile-docstring-style-warn form) - (setq form (copy-sequence form)) - (when (consp (nth 2 form)) - (setcar (cdr (cdr form)) - (byte-compile-top-level (nth 2 form) nil 'file))) - form)) + (byte-compile-defvar form 'toplevel)) (put 'define-abbrev-table 'byte-hunk-handler 'byte-compile-file-form-defvar-function) @@ -2767,26 +2650,37 @@ list that represents a doc string reference. (defun byte-compile-file-form-defvar-function (form) (pcase-let (((or `',name (let name nil)) (nth 1 form))) - (if name (byte-compile--declare-var name))) - ;; Variable aliases are better declared before the corresponding variable, - ;; since it makes it more likely that only one of the two vars has a value - ;; before the `defvaralias' gets executed, which avoids the need to - ;; merge values. - (pcase form - (`(defvaralias ,_ ',newname . ,_) - (when (memq newname byte-compile-bound-variables) - (if (byte-compile-warning-enabled-p 'suspicious) - (byte-compile-warn-x - newname - "Alias for `%S' should be declared before its referent" newname))))) - (byte-compile-docstring-style-warn form) - (byte-compile-keep-pending form)) + (if name (byte-compile--declare-var name)) + ;; Variable aliases are better declared before the corresponding variable, + ;; since it makes it more likely that only one of the two vars has a value + ;; before the `defvaralias' gets executed, which avoids the need to + ;; merge values. + (pcase form + (`(defvaralias ,_ ',newname . ,_) + (when (memq newname byte-compile-bound-variables) + (if (byte-compile-warning-enabled-p 'suspicious) + (byte-compile-warn-x + newname + "Alias for `%S' should be declared before its referent" + newname))))) + (let ((doc (nth 3 form))) + (when (stringp doc) + (setcar (nthcdr 3 form) + (byte-compile--docstring doc (nth 0 form) name)))) + (byte-compile-keep-pending form))) (put 'custom-declare-variable 'byte-hunk-handler 'byte-compile-file-form-defvar-function) (put 'custom-declare-face 'byte-hunk-handler - 'byte-compile-docstring-style-warn) + #'byte-compile--custom-declare-face) +(defun byte-compile--custom-declare-face (form) + (let ((kind (nth 0 form)) (name (nth 1 form)) (docs (nth 3 form))) + (when (stringp docs) + (let ((newdocs (byte-compile--docstring docs kind name))) + (unless (eq docs newdocs) + (setq form (byte-compile--list-with-n form 3 newdocs))))) + form)) (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) @@ -2940,34 +2834,24 @@ not to take responsibility for the actual compilation of the code." (cons (cons bare-name code) (symbol-value this-kind)))) - (if rest - ;; There are additional args to `defalias' (like maybe a docstring) - ;; that the code below can't handle: punt! - nil - ;; Otherwise, we have a bona-fide defun/defmacro definition, and use - ;; special code to allow dynamic docstrings and byte-code. - (byte-compile-flush-pending) + (byte-compile-flush-pending) + (let ((newform `(defalias ',bare-name + ,(if macro `'(macro . ,code) code) ,@rest))) (when byte-native-compiling - ;; Spill output for the native compiler here. + ;; Don't let `byte-compile-output-file-form' push the form to + ;; `byte-to-native-top-level-forms' because we want to use + ;; `make-byte-to-native-func-def' when possible. (push - (if macro + (if (or macro rest) (make-byte-to-native-top-level - :form `(defalias ',name '(macro . ,code) nil) + :form newform :lexical lexical-binding) (make-byte-to-native-func-def :name name :byte-func code)) byte-to-native-top-level-forms)) - ;; Output the form by hand, that's much simpler than having - ;; b-c-output-file-form analyze the defalias. - (byte-compile-output-docform - "\n(defalias '" ")" - bare-name - (if macro '(" '(macro . #[" "])") '(" #[" "]")) - (append code nil) ; Turn byte-code-function-p into list. - 2 4 - (and (atom code) byte-compile-dynamic 1) - nil) - t))))) + (let ((byte-native-compiling nil)) + (byte-compile-output-file-form newform))) + t)))) (defun byte-compile-output-as-comment (exp quoted) "Print Lisp object EXP in the output file at point, inside a comment. @@ -3012,18 +2896,10 @@ otherwise, print without quoting." (defun byte-compile--reify-function (fun) "Return an expression which will evaluate to a function value FUN. -FUN should be either a `lambda' value or a `closure' value." - (pcase-let* (((or (and `(lambda ,args . ,body) (let env nil)) - `(closure ,env ,args . ,body)) - fun) - (preamble nil) +FUN should be an interpreted closure." + (pcase-let* ((`(closure ,env ,args . ,body) fun) + (`(,preamble . ,body) (macroexp-parse-body body)) (renv ())) - ;; Split docstring and `interactive' form from body. - (when (stringp (car body)) - (push (pop body) preamble)) - (when (eq (car-safe (car body)) 'interactive) - (push (pop body) preamble)) - (setq preamble (nreverse preamble)) ;; Turn the function's closed vars (if any) into local let bindings. (dolist (binding env) (cond @@ -3045,41 +2921,39 @@ If FORM is a lambda or a macro, byte-compile it as a function." (fun (if (symbolp form) (symbol-function form) form)) - (macro (eq (car-safe fun) 'macro))) - (if macro - (setq fun (cdr fun))) - (prog1 - (cond - ;; Up until Emacs-24.1, byte-compile silently did nothing - ;; when asked to compile something invalid. So let's tone - ;; down the complaint from an error to a simple message for - ;; the known case where signaling an error causes problems. - ((compiled-function-p fun) - (message "Function %s is already compiled" - (if (symbolp form) form "provided")) - fun) - (t - (let (final-eval) - (when (or (symbolp form) (eq (car-safe fun) 'closure)) - ;; `fun' is a function *value*, so try to recover its corresponding - ;; source code. - (setq lexical-binding (eq (car fun) 'closure)) - (setq fun (byte-compile--reify-function fun)) - (setq final-eval t)) - ;; Expand macros. - (setq fun (byte-compile-preprocess fun)) - (setq fun (byte-compile-top-level fun nil 'eval)) - (if (symbolp form) - ;; byte-compile-top-level returns an *expression* equivalent to the - ;; `fun' expression, so we need to evaluate it, tho normally - ;; this is not needed because the expression is just a constant - ;; byte-code object, which is self-evaluating. - (setq fun (eval fun t))) - (if final-eval - (setq fun (eval fun t))) - (if macro (push 'macro fun)) - (if (symbolp form) (fset form fun)) - fun)))))))) + (macro (eq (car-safe fun) 'macro)) + (need-a-value nil)) + (when macro + (setq need-a-value t) + (setq fun (cdr fun))) + (cond + ;; Up until Emacs-24.1, byte-compile silently did nothing + ;; when asked to compile something invalid. So let's tone + ;; down the complaint from an error to a simple message for + ;; the known case where signaling an error causes problems. + ((compiled-function-p fun) + (message "Function %s is already compiled" + (if (symbolp form) form "provided")) + fun) + (t + (when (or (symbolp form) (eq (car-safe fun) 'closure)) + ;; `fun' is a function *value*, so try to recover its + ;; corresponding source code. + (when (setq lexical-binding (eq (car-safe fun) 'closure)) + (setq fun (byte-compile--reify-function fun))) + (setq need-a-value t)) + ;; Expand macros. + (setq fun (byte-compile-preprocess fun)) + (setq fun (byte-compile-top-level fun nil 'eval)) + (when need-a-value + ;; `byte-compile-top-level' returns an *expression* equivalent to + ;; the `fun' expression, so we need to evaluate it, tho normally + ;; this is not needed because the expression is just a constant + ;; byte-code object, which is self-evaluating. + (setq fun (eval fun lexical-binding))) + (if macro (push 'macro fun)) + (if (symbolp form) (fset form fun)) + fun)))))) (defun byte-compile-sexp (sexp) "Compile and return SEXP." @@ -3178,27 +3052,32 @@ lambda-expression." (setq fun (cons 'lambda fun)) (unless (eq 'lambda (car-safe fun)) (error "Not a lambda list: %S" fun))) - (byte-compile-docstring-style-warn fun) (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) + (bare-arglist (byte-run-strip-symbol-positions arglist)) ; for compile-defun. (arglistvars (byte-run-strip-symbol-positions (byte-compile-arglist-vars arglist))) (byte-compile-bound-variables (append (if (not lexical-binding) arglistvars) byte-compile-bound-variables)) (body (cdr (cdr fun))) - (doc (if (stringp (car body)) + ;; Treat a final string literal as a value, not a doc string. + (doc (if (and (cdr body) (stringp (car body))) (prog1 (car body) - ;; Discard the doc string - ;; unless it is the last element of the body. - (if (cdr body) - (setq body (cdr body)))))) + ;; Discard the doc string from the body. + (setq body (cdr body))))) (int (assq 'interactive body)) command-modes) (when lexical-binding + (when arglist + ;; byte-compile-make-args-desc lost the args's names, + ;; so preserve them in the docstring. + (setq doc (help-add-fundoc-usage doc bare-arglist))) (dolist (var arglistvars) (when (assq var byte-compile--known-dynamic-vars) (byte-compile--warn-lexical-dynamic var 'lambda)))) + (when (stringp doc) + (setq doc (byte-compile--docstring doc "" nil 'is-a-value))) ;; Process the interactive spec. (when int ;; Skip (interactive) if it is in front (the most usual location). @@ -3242,8 +3121,7 @@ lambda-expression." (and lexical-binding (byte-compile-make-lambda-lexenv arglistvars)) - reserved-csts)) - (bare-arglist (byte-run-strip-symbol-positions arglist))) ; for compile-defun. + reserved-csts))) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) (let ((out @@ -3255,12 +3133,7 @@ lambda-expression." ;; byte-string, constants-vector, stack depth (cdr compiled) ;; optionally, the doc string. - (cond ((and lexical-binding arglist) - ;; byte-compile-make-args-desc lost the args's names, - ;; so preserve them in the docstring. - (list (help-add-fundoc-usage doc bare-arglist))) - ((or doc int) - (list doc))) + (when (or doc int) (list doc)) ;; optionally, the interactive spec (and the modes the ;; command applies to). (cond @@ -3572,6 +3445,7 @@ lambda-expression." ((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)) + (bytecomp--actually-important-return-value-p form) (byte-compile-warning-enabled-p 'ignored-return-value (car form))) (byte-compile-warn-x @@ -3598,6 +3472,15 @@ lambda-expression." (if byte-compile--for-effect (byte-compile-discard))))) +(defun bytecomp--actually-important-return-value-p (form) + "Whether FORM is really a call with a return value that should not go unused. +This assumes the function has the `important-return-value' property." + (cond ((eq (car form) 'sort) + ;; For `sort', we only care about non-destructive uses. + (and (zerop (% (length form) 2)) ; new-style call + (not (plist-get (cddr form) :in-place)))) + (t t))) + (let ((important-return-value-fns '( ;; These functions are side-effect-free except for the @@ -3605,9 +3488,11 @@ lambda-expression." mapcar mapcan mapconcat assoc plist-get plist-member - ;; It's safe to ignore the value of `sort' and `nreverse' + ;; It's safe to ignore the value of `nreverse' ;; when used on arrays, but most calls pass lists. - nreverse sort + nreverse + + sort ; special handling (non-destructive calls only) match-data @@ -3814,7 +3699,6 @@ lambda-expression." (alen (length (cdr form))) (dynbinds ()) lap) - (fetch-bytecode fun) (setq lap (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t)) ;; optimized switch bytecode makes it impossible to guess the correct ;; `byte-compile-depth', which can result in incorrect inlined code. @@ -5141,49 +5025,49 @@ binding slots have been popped." (push (nth 1 (nth 1 form)) byte-compile-global-not-obsolete-vars)) (byte-compile-normal-call form)) -(defun byte-compile-defvar (form) - ;; This is not used for file-level defvar/consts. - (when (and (symbolp (nth 1 form)) - (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) - (byte-compile-warning-enabled-p 'lexical (nth 1 form))) - (byte-compile-warn-x - (nth 1 form) - "global/dynamic var `%s' lacks a prefix" - (nth 1 form))) - (byte-compile-docstring-style-warn form) - (let ((fun (nth 0 form)) - (var (nth 1 form)) - (value (nth 2 form)) - (string (nth 3 form))) - (when (or (> (length form) 4) - (and (eq fun 'defconst) (null (cddr form)))) - (let ((ncall (length (cdr form)))) - (byte-compile-warn-x - fun - "`%s' called with %d argument%s, but %s %s" - fun ncall - (if (= 1 ncall) "" "s") - (if (< ncall 2) "requires" "accepts only") - "2-3"))) - (push var byte-compile-bound-variables) +(defun byte-compile-defvar (form &optional toplevel) + (let* ((fun (nth 0 form)) + (var (nth 1 form)) + (value (nth 2 form)) + (string (nth 3 form))) + (byte-compile--declare-var var (not toplevel)) (if (eq fun 'defconst) (push var byte-compile-const-variables)) - (when (and string (not (stringp string))) + (cond + ((stringp string) + (setq string (byte-compile--docstring string fun var 'is-a-value))) + (string (byte-compile-warn-x string "third arg to `%s %s' is not a string: %s" - fun var string)) - ;; Delegate the actual work to the function version of the - ;; special form, named with a "-1" suffix. - (byte-compile-form-do-effect - (cond - ((eq fun 'defconst) `(defconst-1 ',var ,@(nthcdr 2 form))) - ((not (cddr form)) `',var) ; A simple (defvar foo) just returns foo. - (t `(defvar-1 ',var - ;; Don't eval `value' if `defvar' wouldn't eval it either. - ,(if (macroexp-const-p value) value - `(if (boundp ',var) nil ,value)) - ,@(nthcdr 3 form))))))) + fun var string))) + (if toplevel + ;; At top-level we emit calls to defvar/defconst. + (if (and (null (cddr form)) ;No `value' provided. + (eq (car form) 'defvar)) ;Just a declaration. + nil + (let ((tail (nthcdr 4 form))) + (when (or tail string) (push string tail)) + (when (cddr form) + (push (if (not (consp value)) value + (byte-compile-top-level value nil 'file)) + tail)) + `(,fun ,var ,@tail))) + ;; At non-top-level, since there is no byte code for + ;; defvar/defconst, we delegate the actual work to the function + ;; version of the special form, named with a "-1" suffix. + (byte-compile-form-do-effect + (cond + ((eq fun 'defconst) + `(defconst-1 ',var ,@(byte-compile--list-with-n + (nthcdr 2 form) 1 (macroexp-quote string)))) + ((not (cddr form)) `',var) ; A simple (defvar foo) just returns foo. + (t `(defvar-1 ',var + ;; Don't eval `value' if `defvar' wouldn't eval it either. + ,(if (macroexp-const-p value) value + `(if (boundp ',var) nil ,value)) + ,@(byte-compile--list-with-n + (nthcdr 3 form) 0 (macroexp-quote string))))))))) (defun byte-compile-autoload (form) (and (macroexp-const-p (nth 1 form)) @@ -5209,14 +5093,6 @@ binding slots have been popped." ;; For the compilation itself, we could largely get rid of this hunk-handler, ;; if it weren't for the fact that we need to figure out when a defalias ;; defines a macro, so as to add it to byte-compile-macro-environment. - ;; - ;; FIXME: we also use this hunk-handler to implement the function's - ;; dynamic docstring feature (via byte-compile-file-form-defmumble). - ;; We should probably actually implement it (more elegantly) in - ;; byte-compile-lambda so it applies to all lambdas. We did it here - ;; so the resulting .elc format was recognizable by make-docfile, - ;; but since then we stopped using DOC for the docstrings of - ;; preloaded elc files so that obstacle is gone. (let ((byte-compile-free-references nil) (byte-compile-free-assignments nil)) (pcase form @@ -5225,7 +5101,11 @@ binding slots have been popped." ;; - `arg' is the expression to which it is defined. ;; - `rest' is the rest of the arguments. (`(,_ ',name ,arg . ,rest) - (byte-compile-docstring-style-warn form) + (let ((doc (car rest))) + (when (stringp doc) + (setq rest (byte-compile--list-with-n + rest 0 + (byte-compile--docstring doc (nth 0 form) name))))) (pcase-let* ;; `macro' is non-nil if it defines a macro. ;; `fun' is the function part of `arg' (defaults to `arg'). @@ -5668,23 +5548,14 @@ invoked interactively." (if (null f) " <top level>";; shouldn't insert nil then, actually -sk " <not defined>")) - ((subrp (setq f (symbol-function f))) - " <subr>") - ((symbolp f) + ((symbolp (setq f (symbol-function f))) ;; An alias. (format " ==> %s" f)) - ((byte-code-function-p f) - "<compiled function>") ((not (consp f)) - "<malformed function>") + (format " <%s>" (type-of f))) ((eq 'macro (car f)) - (if (or (compiled-function-p (cdr f)) - ;; FIXME: Can this still happen? - (assq 'byte-code (cdr (cdr (cdr f))))) + (if (compiled-function-p (cdr f)) " <compiled macro>" " <macro>")) - ((assq 'byte-code (cdr (cdr f))) - ;; FIXME: Can this still happen? - "<compiled lambda>") ((eq 'lambda (car f)) "<function>") (t "???")) @@ -5894,6 +5765,16 @@ and corresponding effects." (eval form) form))) +;; Report comma operator used outside of backquote. +;; Inside backquote, backquote will transform it before it gets here. + +(put '\, 'compiler-macro #'bytecomp--report-comma) +(defun bytecomp--report-comma (form &rest _ignore) + (macroexp-warn-and-return + (format-message "`%s' called -- perhaps used not within backquote" + (car form)) + form (list 'suspicious (car form)) t)) + ;; Check for (in)comparable constant values in calls to `eq', `memq' etc. (defun bytecomp--dodgy-eq-arg-p (x number-ok) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index e210cfdf5ce..4ff47971351 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -621,12 +621,16 @@ places where they originally did not directly appear." (cconv-convert exp env extend)) (`(,func . ,forms) - (if (symbolp func) + (if (or (symbolp func) (functionp func)) ;; First element is function or whatever function-like forms are: ;; or, and, if, catch, progn, prog1, while, until - `(,func . ,(mapcar (lambda (form) - (cconv-convert form env extend)) - forms)) + (let ((args (mapcar (lambda (form) (cconv-convert form env extend)) + forms))) + (unless (symbolp func) + (byte-compile-warn-x + form + "Use `funcall' instead of `%s' in the function position" func)) + `(,func . ,args)) (byte-compile-warn-x form "Malformed function `%S'" func) nil)) diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index 0362c7d2c24..faa7824c8bd 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -40,7 +40,7 @@ ;;; Code: -(defconst check-declare-warning-buffer "*Check Declarations Warnings*" +(defvar check-declare-warning-buffer "*Check Declarations Warnings*" "Name of buffer used to display any `check-declare' warnings.") (defun check-declare-locate (file basefile) @@ -85,6 +85,9 @@ don't know how to recognize (e.g. some macros)." (let (alist) (with-temp-buffer (insert-file-contents file) + ;; Ensure shorthands available, as we will be `read'ing Elisp + ;; (bug#67523) + (let (enable-local-variables) (hack-local-variables)) ;; FIXME we could theoretically be inside a string. (while (re-search-forward "^[ \t]*\\((declare-function\\)[ \t\n]" nil t) (let ((pos (match-beginning 1))) @@ -145,64 +148,70 @@ is a string giving details of the error." (if (file-regular-p fnfile) (with-temp-buffer (insert-file-contents fnfile) + (unless cflag + ;; If in Elisp, ensure syntax and shorthands available + ;; (bug#67523) + (set-syntax-table emacs-lisp-mode-syntax-table) + (let (enable-local-variables) (hack-local-variables))) ;; defsubst's don't _have_ to be known at compile time. - (setq re (format (if cflag - "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\"" - "^[ \t]*(\\(fset[ \t]+'\\|\ + (setq re (if cflag + (format "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\"" + (regexp-opt (mapcar 'cadr fnlist) t)) + "^[ \t]*(\\(fset[ \t]+'\\|\ cl-def\\(?:generic\\|method\\|un\\)\\|\ def\\(?:un\\|subst\\|foo\\|method\\|class\\|\ ine-\\(?:derived\\|generic\\|\\(?:global\\(?:ized\\)?-\\)?minor\\)-mode\\|\ \\(?:ine-obsolete-function-\\)?alias[ \t]+'\\|\ ine-overloadable-function\\)\\)\ -[ \t]*%s\\([ \t;]+\\|$\\)") - (regexp-opt (mapcar 'cadr fnlist) t))) +[ \t]*\\(\\(?:\\sw\\|\\s_\\)+\\)\\([ \t;]+\\|$\\)")) (while (re-search-forward re nil t) (skip-chars-forward " \t\n") - (setq fn (match-string 2) - type (match-string 1) - ;; (min . max) for a fixed number of arguments, or - ;; arglists with optional elements. - ;; (min) for arglists with &rest. - ;; sig = 'err means we could not find an arglist. - sig (cond (cflag - (or - (when (search-forward "," nil t 3) - (skip-chars-forward " \t\n") - ;; Assuming minargs and maxargs on same line. - (when (looking-at "\\([0-9]+\\)[ \t]*,[ \t]*\ + (setq fn (symbol-name (car (read-from-string (match-string 2))))) + (when (member fn (mapcar 'cadr fnlist)) + (setq type (match-string 1) + ;; (min . max) for a fixed number of arguments, or + ;; arglists with optional elements. + ;; (min) for arglists with &rest. + ;; sig = 'err means we could not find an arglist. + sig (cond (cflag + (or + (when (search-forward "," nil t 3) + (skip-chars-forward " \t\n") + ;; Assuming minargs and maxargs on same line. + (when (looking-at "\\([0-9]+\\)[ \t]*,[ \t]*\ \\([0-9]+\\|MANY\\|UNEVALLED\\)") - (setq minargs (string-to-number - (match-string 1)) - maxargs (match-string 2)) - (cons minargs (unless (string-match "[^0-9]" - maxargs) - (string-to-number - maxargs))))) - 'err)) - ((string-match - "\\`define-\\(derived\\|generic\\)-mode\\'" - type) - '(0 . 0)) - ((string-match - "\\`define\\(-global\\(ized\\)?\\)?-minor-mode\\'" - type) - '(0 . 1)) - ;; Prompt to update. - ((string-match - "\\`define-obsolete-function-alias\\>" - type) - 'obsolete) - ;; Can't easily check arguments in these cases. - ((string-match "\\`\\(def\\(alias\\|class\\)\\|\ + (setq minargs (string-to-number + (match-string 1)) + maxargs (match-string 2)) + (cons minargs (unless (string-match "[^0-9]" + maxargs) + (string-to-number + maxargs))))) + 'err)) + ((string-match + "\\`define-\\(derived\\|generic\\)-mode\\'" + type) + '(0 . 0)) + ((string-match + "\\`define\\(-global\\(ized\\)?\\)?-minor-mode\\'" + type) + '(0 . 1)) + ;; Prompt to update. + ((string-match + "\\`define-obsolete-function-alias\\>" + type) + 'obsolete) + ;; Can't easily check arguments in these cases. + ((string-match "\\`\\(def\\(alias\\|class\\)\\|\ fset\\|\\(?:cl-\\)?defmethod\\)\\>" type) - t) - ((looking-at "\\((\\|nil\\)") - (byte-compile-arglist-signature - (read (current-buffer)))) - (t - 'err)) - ;; alist of functions and arglist signatures. - siglist (cons (cons fn sig) siglist))))) + t) + ((looking-at "\\((\\|nil\\)") + (byte-compile-arglist-signature + (read (current-buffer)))) + (t + 'err)) + ;; alist of functions and arglist signatures. + siglist (cons (cons fn sig) siglist)))))) (dolist (e fnlist) (setq arglist (nth 2 e) type @@ -319,9 +328,14 @@ Returns non-nil if any false statements are found." (setq root (directory-file-name (file-relative-name root))) (or (file-directory-p root) (error "Directory `%s' not found" root)) - (let ((files (directory-files-recursively root "\\.el\\'"))) - (when files - (apply #'check-declare-files files)))) + (when-let* ((files (directory-files-recursively root "\\.el\\'")) + (files (mapcan (lambda (file) + ;; Filter out lock files. + (and (not (string-prefix-p + ".#" (file-name-nondirectory file))) + (list file))) + files))) + (apply #'check-declare-files files))) (provide 'check-declare) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 80eaf93c3b7..c22dfb2eb26 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -556,7 +556,8 @@ the users will view as each check is completed." "Display and update the status buffer for the current checkdoc mode. CHECK is a list of four strings stating the current status of each test; the nth string describes the status of the nth test." - (let (temp-buffer-setup-hook) + (let (temp-buffer-setup-hook + (temp-buffer-show-hook #'special-mode)) (with-output-to-temp-buffer "*Checkdoc Status*" (mapc #'princ (list "Buffer comments and tags: " (nth 0 check) @@ -1993,7 +1994,7 @@ from the comment." (defun-depth (ppss-depth (syntax-ppss))) (lst nil) (ret nil) - (oo (make-vector 3 0))) ;substitute obarray for `read' + (oo (obarray-make 3))) ;substitute obarray for `read' (forward-char 1) (forward-sexp 1) (skip-chars-forward " \n\t") @@ -2793,7 +2794,7 @@ function called to create the messages." ": " msg))) (if (string= checkdoc-diagnostic-buffer "*warn*") (warn (apply #'concat text)) - (with-current-buffer (get-buffer checkdoc-diagnostic-buffer) + (with-current-buffer checkdoc-diagnostic-buffer (let ((inhibit-read-only t) (pt (point-max))) (goto-char pt) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 9281cd9821e..437dea2d6a9 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -711,11 +711,6 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (eval-when-compile (require 'cl-macs)) ;Explicitly, for cl--find-class. (require 'help-mode) -;; FIXME: We could go crazy and add another entry so describe-symbol can be -;; used with the slot names of CL structs (and/or EIEIO objects). -(add-to-list 'describe-symbol-backends - `(nil ,#'cl-find-class ,(lambda (s _b _f) (cl-describe-type s)))) - (defconst cl--typedef-regexp (concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct" "cl-deftype" "deftype")) @@ -725,11 +720,6 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (add-to-list 'find-function-regexp-alist '(define-type . cl--typedef-regexp))) -(define-button-type 'cl-help-type - :supertype 'help-function-def - 'help-function #'cl-describe-type - 'help-echo (purecopy "mouse-2, RET: describe this type")) - (define-button-type 'cl-type-definition :supertype 'help-function-def 'help-echo (purecopy "mouse-2, RET: find type definition")) @@ -744,7 +734,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" (cl--find-class type)) ;;;###autoload -(defun cl-describe-type (type) +(defun cl-describe-type (type &optional _buf _frame) "Display the documentation for type TYPE (a symbol)." (interactive (let ((str (completing-read "Describe type: " obarray #'cl-find-class t))) @@ -766,6 +756,15 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" ;; Return the text we displayed. (buffer-string))))) +(defun cl--class-children (class) + (let ((children '())) + (mapatoms + (lambda (sym) + (let ((sym-class (cl--find-class sym))) + (and sym-class (memq class (cl--class-parents sym-class)) + (push sym children))))) + children)) + (defun cl--describe-class (type &optional class) (unless class (setq class (cl--find-class type))) (let ((location (find-lisp-object-file-name type 'define-type)) @@ -773,7 +772,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" (insert (symbol-name type) (substitute-command-keys " is a type (of kind `")) (help-insert-xref-button (symbol-name metatype) - 'cl-help-type metatype) + 'help-type metatype) (insert (substitute-command-keys "')")) (when location (insert (substitute-command-keys " in `")) @@ -792,21 +791,19 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" (setq cur (cl--class-name cur)) (insert (substitute-quotes "`")) (help-insert-xref-button (symbol-name cur) - 'cl-help-type cur) + 'help-type cur) (insert (substitute-command-keys (if pl "', " "'")))) (insert ".\n"))) - ;; Children, if available. ¡For EIEIO! - (let ((ch (condition-case nil - (cl-struct-slot-value metatype 'children class) - (cl-struct-unknown-slot nil))) + ;; Children. + (let ((ch (cl--class-children class)) cur) (when ch (insert " Children ") (while (setq cur (pop ch)) (insert (substitute-quotes "`")) (help-insert-xref-button (symbol-name cur) - 'cl-help-type cur) + 'help-type cur) (insert (substitute-command-keys (if ch "', " "'")))) (insert ".\n"))) @@ -903,22 +900,25 @@ Outputs to the current buffer." (cslots (condition-case nil (cl-struct-slot-value metatype 'class-slots class) (cl-struct-unknown-slot nil)))) - (insert (propertize "Instance Allocated Slots:\n\n" - 'face 'bold)) - (let* ((has-doc nil) - (slots-strings - (mapcar - (lambda (slot) - (list (cl-prin1-to-string (cl--slot-descriptor-name slot)) - (cl-prin1-to-string (cl--slot-descriptor-type slot)) - (cl-prin1-to-string (cl--slot-descriptor-initform slot)) - (let ((doc (alist-get :documentation - (cl--slot-descriptor-props slot)))) - (if (not doc) "" - (setq has-doc t) - (substitute-command-keys doc))))) - slots))) - (cl--print-table `("Name" "Type" "Default") slots-strings has-doc)) + (if (and (null slots) (eq metatype 'built-in-class)) + (insert "This is a built-in type.\n") + + (insert (propertize "Instance Allocated Slots:\n\n" + 'face 'bold)) + (let* ((has-doc nil) + (slots-strings + (mapcar + (lambda (slot) + (list (cl-prin1-to-string (cl--slot-descriptor-name slot)) + (cl-prin1-to-string (cl--slot-descriptor-type slot)) + (cl-prin1-to-string (cl--slot-descriptor-initform slot)) + (let ((doc (alist-get :documentation + (cl--slot-descriptor-props slot)))) + (if (not doc) "" + (setq has-doc t) + (substitute-command-keys doc))))) + slots))) + (cl--print-table `("Name" "Type" "Default") slots-strings has-doc))) (insert "\n") (when (> (length cslots) 0) (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 48f5c06e390..8bda857afdd 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -672,7 +672,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; compiled. Otherwise the byte-compiler and all the code on ;; which it depends needs to be usable before cl-generic is loaded, ;; which imposes a significant burden on the bootstrap. - (if (consp (lambda (x) (+ x 1))) + (if (not (compiled-function-p (lambda (x) (+ x 1)))) (lambda (exp) (eval exp t)) ;; But do byte-compile the dispatchers once bootstrap is passed: ;; the performance difference is substantial (like a 5x speedup on @@ -1140,12 +1140,8 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (add-hook 'help-fns-describe-function-functions #'cl--generic-describe) (defun cl--generic-describe (function) - ;; Supposedly this is called from help-fns, so help-fns should be loaded at - ;; this point. - (declare-function help-fns-short-filename "help-fns" (filename)) (let ((generic (if (symbolp function) (cl--generic function)))) (when generic - (require 'help-mode) ;Needed for `help-function-def' button! (save-excursion ;; Ensure that we have two blank lines (but not more). (unless (looking-back "\n\n" (- (point) 2)) @@ -1153,33 +1149,49 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (insert "This is a generic function.\n\n") (insert (propertize "Implementations:\n\n" 'face 'bold)) ;; Loop over fanciful generics - (dolist (method (cl--generic-method-table generic)) - (pcase-let* - ((`(,qualifiers ,args ,doc) (cl--generic-method-info method))) - ;; FIXME: Add hyperlinks for the types as well. - (let ((print-quoted nil) - (quals (if (length> qualifiers 0) - (concat (substring qualifiers - 0 (string-match " *\\'" - qualifiers)) - "\n") - ""))) - (insert (format "%s%S" - quals - (cons function - (cl--generic-upcase-formal-args args))))) - (let* ((met-name (cl--generic-load-hist-format - function - (cl--generic-method-qualifiers method) - (cl--generic-method-specializers method))) - (file (find-lisp-object-file-name met-name 'cl-defmethod))) - (when file - (insert (substitute-command-keys " in `")) - (help-insert-xref-button (help-fns-short-filename file) - 'help-function-def met-name file - 'cl-defmethod) - (insert (substitute-command-keys "'.\n")))) - (insert "\n" (or doc "Undocumented") "\n\n"))))))) + (cl--map-methods-documentation + function + (lambda (quals signature file doc) + (insert (format "%s%S%s\n\n%s\n\n" + quals signature + (if file (format-message " in `%s'." file) "") + (or doc "Undocumented"))))))))) + +(defun cl--map-methods-documentation (funname metname-printer) + "Iterate on FUNNAME's methods documentation at point." + ;; Supposedly this is called from help-fns, so help-fns should be loaded at + ;; this point. + (require 'help-fns) + (declare-function help-fns-short-filename "help-fns" (filename)) + (let ((generic (if (symbolp funname) (cl--generic funname)))) + (when generic + (require 'help-mode) ;Needed for `help-function-def' button! + ;; Loop over fanciful generics + (dolist (method (cl--generic-method-table generic)) + (pcase-let* + ((`(,qualifiers ,args ,doc) (cl--generic-method-info method)) + ;; FIXME: Add hyperlinks for the types as well. + (quals (if (length> qualifiers 0) + (concat (substring qualifiers + 0 (string-match " *\\'" + qualifiers)) + "\n") + "")) + (met-name (cl--generic-load-hist-format + funname + (cl--generic-method-qualifiers method) + (cl--generic-method-specializers method))) + (file (find-lisp-object-file-name met-name 'cl-defmethod))) + (funcall metname-printer + quals + (cons funname + (cl--generic-upcase-formal-args args)) + (when file + (make-text-button (help-fns-short-filename file) nil + 'type 'help-function-def + 'help-args + (list met-name file 'cl-defmethod))) + doc)))))) (defun cl--generic-specializers-apply-to-type-p (specializers type) "Return non-nil if a method with SPECIALIZERS applies to TYPE." @@ -1318,62 +1330,30 @@ These match if the argument is `eql' to VAL." (cl--generic-prefill-dispatchers (terminal-parameter nil 'xterm--set-selection) (eql nil)) -;;; Support for cl-defstructs specializers. - -(defun cl--generic-struct-tag (name &rest _) - ;; Use exactly the same code as for `typeof'. - `(if ,name (type-of ,name) 'null)) +;;; Dispatch on "normal types". -(defun cl--generic-struct-specializers (tag &rest _) +(defun cl--generic-type-specializers (tag &rest _) (and (symbolp tag) - (let ((class (get tag 'cl--class))) - (when (cl-typep class 'cl-structure-class) + (let ((class (cl--find-class tag))) + (when class (cl--class-allparents class))))) -(cl-generic-define-generalizer cl--generic-struct-generalizer - 50 #'cl--generic-struct-tag - #'cl--generic-struct-specializers) - -(cl-defmethod cl-generic-generalizers :extra "cl-struct" (type) - "Support for dispatch on types defined by `cl-defstruct'." - (or - (when (symbolp type) - ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than - ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can - ;; take place without requiring cl-lib. - (let ((class (cl--find-class type))) - (and (cl-typep class 'cl-structure-class) - (or (null (cl--struct-class-type class)) - (error "Can't dispatch on cl-struct %S: type is %S" - type (cl--struct-class-type class))) - (progn (cl-assert (null (cl--struct-class-named class))) t) - (list cl--generic-struct-generalizer)))) - (cl-call-next-method))) - -(cl--generic-prefill-dispatchers 0 cl--generic-generalizer) - -;;; Dispatch on "system types". - (cl-generic-define-generalizer cl--generic-typeof-generalizer - ;; FIXME: We could also change `type-of' to return `null' for nil. - 10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null)) - (lambda (tag &rest _) - (and (symbolp tag) (assq tag cl--typeof-types)))) + 10 (lambda (name &rest _) `(cl-type-of ,name)) + #'cl--generic-type-specializers) (cl-defmethod cl-generic-generalizers :extra "typeof" (type) - "Support for dispatch on builtin types. -See the full list and their hierarchy in `cl--typeof-types'." - ;; FIXME: Add support for other types accepted by `cl-typep' such - ;; as `character', `face', `function', ... + "Support for dispatch on types. +This currently works for built-in types and types built on top of records." + ;; FIXME: Add support for other "types" accepted by `cl-typep' such + ;; as `character', `face', `keyword', ...? (or - (and (memq type cl--all-builtin-types) - (progn - ;; FIXME: While this wrinkle in the semantics can be occasionally - ;; problematic, this warning is more often annoying than helpful. - ;;(if (memq type '(vector array sequence)) - ;; (message "`%S' also matches CL structs and EIEIO classes" - ;; type)) - (list cl--generic-typeof-generalizer))) + (and (symbolp type) + (not (eq type t)) ;; Handled by the `t-generalizer'. + (let ((class (cl--find-class type))) + (memq (type-of class) + '(built-in-class cl-structure-class eieio--class))) + (list cl--generic-typeof-generalizer)) (cl-call-next-method))) (cl--generic-prefill-dispatchers 0 integer) @@ -1381,6 +1361,8 @@ See the full list and their hierarchy in `cl--typeof-types'." (cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer) (cl--generic-prefill-dispatchers 0 (eql 'x) integer) +(cl--generic-prefill-dispatchers 0 cl--generic-generalizer) + ;;; Dispatch on major mode. ;; Two parts: @@ -1418,19 +1400,13 @@ Used internally for the (major-mode MODE) context specializers." (defun cl--generic-oclosure-tag (name &rest _) `(oclosure-type ,name)) -(defun cl-generic--oclosure-specializers (tag &rest _) - (and (symbolp tag) - (let ((class (cl--find-class tag))) - (when (cl-typep class 'oclosure--class) - (oclosure--class-allparents class))))) - (cl-generic-define-generalizer cl--generic-oclosure-generalizer ;; Give slightly higher priority than the struct specializer, so that ;; for a generic function with methods dispatching structs and on OClosures, ;; we first try `oclosure-type' before `type-of' since `type-of' will return ;; non-nil for an OClosure as well. 51 #'cl--generic-oclosure-tag - #'cl-generic--oclosure-specializers) + #'cl--generic-type-specializers) (cl-defmethod cl-generic-generalizers :extra "oclosure-struct" (type) "Support for dispatch on types defined by `oclosure-define'." diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 88447203a64..a84ef4a34b2 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2250,7 +2250,7 @@ Like `cl-flet' but the definitions can refer to previous ones. ;;;###autoload (defmacro cl-labels (bindings &rest body) "Make local (recursive) function definitions. -+BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where +BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where FUNC is the function name, ARGLIST its arguments, and BODY the forms of the function body. FUNC is defined in any BODY, as well as FORM, so you can write recursive and mutually recursive @@ -3344,14 +3344,14 @@ Elements of FIELDS can be of the form (NAME PAT) in which case the contents of field NAME is matched against PAT, or they can be of the form NAME which is a shorthand for (NAME NAME)." (declare (debug (sexp &rest [&or (sexp pcase-PAT) sexp]))) - `(and (pred (pcase--flip cl-typep ',type)) + `(and (pred (cl-typep _ ',type)) ,@(mapcar (lambda (field) (let* ((name (if (consp field) (car field) field)) (pat (if (consp field) (cadr field) field))) `(app ,(if (eq (cl-struct-sequence-type type) 'list) `(nth ,(cl-struct-slot-offset type name)) - `(pcase--flip aref ,(cl-struct-slot-offset type name))) + `(aref _ ,(cl-struct-slot-offset type name))) ,pat))) fields))) @@ -3368,13 +3368,13 @@ the form NAME which is a shorthand for (NAME NAME)." "Extra special cases for `cl-typep' predicates." (let* ((x1 pred1) (x2 pred2) (t1 - (and (eq 'pcase--flip (car-safe x1)) (setq x1 (cdr x1)) - (eq 'cl-typep (car-safe x1)) (setq x1 (cdr x1)) + (and (eq 'cl-typep (car-safe x1)) (setq x1 (cdr x1)) + (eq '_ (car-safe x1)) (setq x1 (cdr x1)) (null (cdr-safe x1)) (setq x1 (car x1)) (eq 'quote (car-safe x1)) (cadr x1))) (t2 - (and (eq 'pcase--flip (car-safe x2)) (setq x2 (cdr x2)) - (eq 'cl-typep (car-safe x2)) (setq x2 (cdr x2)) + (and (eq 'cl-typep (car-safe x2)) (setq x2 (cdr x2)) + (eq '_ (car-safe x2)) (setq x2 (cdr x2)) (null (cdr-safe x2)) (setq x2 (car x2)) (eq 'quote (car-safe x2)) (cadr x2)))) (or @@ -3460,45 +3460,20 @@ Of course, we really can't know that for sure, so it's just a heuristic." (or (cdr (assq sym byte-compile-function-environment)) (cdr (assq sym macroexpand-all-environment)))))) +;; Please keep it in sync with `comp-known-predicates'. (pcase-dolist (`(,type . ,pred) ;; Mostly kept in alphabetical order. - '((array . arrayp) - (atom . atom) - (base-char . characterp) - (bignum . bignump) - (boolean . booleanp) - (bool-vector . bool-vector-p) - (buffer . bufferp) - (byte-code-function . byte-code-function-p) - (character . natnump) - (char-table . char-table-p) - (command . commandp) - (compiled-function . compiled-function-p) - (hash-table . hash-table-p) - (cons . consp) - (fixnum . fixnump) - (float . floatp) - (frame . framep) - (function . functionp) - (integer . integerp) - (keyword . keywordp) + ;; These aren't defined via `cl--define-built-in-type'. + '((base-char . characterp) ;Could be subtype of `fixnum'. + (character . natnump) ;Could be subtype of `fixnum'. + (command . commandp) ;Subtype of closure & subr. + (keyword . keywordp) ;Would need `keyword-with-pos`. + (natnum . natnump) ;Subtype of fixnum & bignum. + (real . numberp) ;Not clear where it would fit. + ;; This one is redundant, but we keep it to silence a + ;; warning during the early bootstrap when `cl-seq.el' gets + ;; loaded before `cl-preloaded.el' is defined. (list . listp) - (marker . markerp) - (natnum . natnump) - (number . numberp) - (null . null) - (overlay . overlayp) - (process . processp) - (real . numberp) - (sequence . sequencep) - (subr . subrp) - (string . stringp) - (symbol . symbolp) - (vector . vectorp) - (window . windowp) - ;; FIXME: Do we really want to consider these types? - (number-or-marker . number-or-marker-p) - (integer-or-marker . integer-or-marker-p) )) (put type 'cl-deftype-satisfies pred)) @@ -3818,7 +3793,8 @@ STRUCT-TYPE and SLOT-NAME are symbols. INST is a structure instance." (pcase-defmacro cl-type (type) "Pcase pattern that matches objects of TYPE. TYPE is a type descriptor as accepted by `cl-typep', which see." - `(pred (pcase--flip cl-typep ',type))) + `(pred (cl-typep _ ',type))) + ;; Local variables: ;; generated-autoload-file: "cl-loaddefs.el" diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 20e68555578..d23ad3972a9 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -50,51 +50,16 @@ (apply #'error string (append sargs args)) (signal 'cl-assertion-failed `(,form ,@sargs))))) -(defconst cl--typeof-types - ;; Hand made from the source code of `type-of'. - '((integer number integer-or-marker number-or-marker atom) - (symbol-with-pos symbol atom) (symbol atom) (string array sequence atom) - (cons list sequence) - ;; Markers aren't `numberp', yet they are accepted wherever integers are - ;; accepted, pretty much. - (marker integer-or-marker number-or-marker atom) - (overlay atom) (float number number-or-marker atom) - (window-configuration atom) (process atom) (window atom) - ;; FIXME: We'd want to put `function' here, but that's only true - ;; for those `subr's which aren't special forms! - (subr atom) - ;; FIXME: We should probably reverse the order between - ;; `compiled-function' and `byte-code-function' since arguably - ;; `subr' is also "compiled functions" but not "byte code functions", - ;; but it would require changing the value returned by `type-of' for - ;; byte code objects, which risks breaking existing code, which doesn't - ;; seem worth the trouble. - (compiled-function byte-code-function function atom) - (module-function function atom) - (buffer atom) (char-table array sequence atom) - (bool-vector array sequence atom) - (frame atom) (hash-table atom) (terminal atom) - (thread atom) (mutex atom) (condvar atom) - (font-spec atom) (font-entity atom) (font-object atom) - (vector array sequence atom) - (user-ptr atom) - (tree-sitter-parser atom) - (tree-sitter-node atom) - (tree-sitter-compiled-query atom) - ;; Plus, really hand made: - (null symbol list sequence atom)) - "Alist of supertypes. -Each element has the form (TYPE . SUPERTYPES) where TYPE is one of -the symbols returned by `type-of', and SUPERTYPES is the list of its -supertypes from the most specific to least specific.") - -(defconst cl--all-builtin-types - (delete-dups (copy-sequence (apply #'append cl--typeof-types)))) +(defun cl--builtin-type-p (name) + (if (not (fboundp 'built-in-class-p)) ;; Early bootstrap + nil + (let ((class (and (symbolp name) (get name 'cl--class)))) + (and class (built-in-class-p class))))) (defun cl--struct-name-p (name) "Return t if NAME is a valid structure name for `cl-defstruct'." (and name (symbolp name) (not (keywordp name)) - (not (memq name cl--all-builtin-types)))) + (not (cl--builtin-type-p name)))) ;; When we load this (compiled) file during pre-loading, the cl--struct-class ;; code below will need to access the `cl-struct' info, since it's considered @@ -147,7 +112,7 @@ supertypes from the most specific to least specific.") (defun cl--struct-register-child (parent tag) ;; Can't use (cl-typep parent 'cl-structure-class) at this stage ;; because `cl-structure-class' is defined later. - (while (recordp parent) + (while (cl--struct-class-p parent) (add-to-list (cl--struct-class-children-sym parent) tag) ;; Only register ourselves as a child of the leftmost parent since structs ;; can only have one parent. @@ -162,9 +127,14 @@ supertypes from the most specific to least specific.") (with-suppressed-warnings ((obsolete cl-old-struct-compat-mode)) (message "cl-old-struct-compat-mode is obsolete!") (cl-old-struct-compat-mode 1))) - (if (eq type 'record) - ;; Defstruct using record objects. - (setq type nil)) + (when (eq type 'record) + ;; Defstruct using record objects. + (setq type nil) + ;; `cl-structure-class' and `cl-structure-object' are allowed to be + ;; defined without specifying the parent, because their parent + ;; doesn't exist yet when they're defined. + (cl-assert (or parent (memq name '(cl-structure-class + cl-structure-object))))) (cl-assert (or type (not named))) (if (boundp children-sym) (add-to-list children-sym tag) @@ -172,7 +142,9 @@ supertypes from the most specific to least specific.") (and (null type) (eq (caar slots) 'cl-tag-slot) ;; Hide the tag slot from "standard" (i.e. non-`type'd) structs. (setq slots (cdr slots))) - (let* ((parent-class (when parent (cl--struct-get-class parent))) + (let* ((parent-class (if parent (cl--struct-get-class parent) + (cl--find-class (if (eq type 'list) 'cons + (or type 'record))))) (n (length slots)) (index-table (make-hash-table :test 'eq :size n)) (vslots (let ((v (make-vector n nil)) @@ -195,7 +167,9 @@ supertypes from the most specific to least specific.") name docstring (unless (symbolp parent-class) (list parent-class)) type named vslots index-table children-sym tag print))) - (unless (symbolp parent-class) + (cl-assert (or (not (symbolp parent-class)) + (memq name '(cl-structure-class cl-structure-object)))) + (when (cl--struct-class-p parent-class) (let ((pslots (cl--struct-class-slots parent-class))) (or (>= n (length pslots)) (let ((ok t)) @@ -286,7 +260,7 @@ supertypes from the most specific to least specific.") (cl-defstruct (cl--class (:constructor nil) (:copier nil)) - "Type of descriptors for any kind of structure-like data." + "Abstract supertype of all type descriptors." ;; Intended to be shared between defstruct and defclass. (name nil :type symbol) ;The type name. (docstring nil :type string) @@ -327,8 +301,170 @@ supertypes from the most specific to least specific.") (merge-ordered-lists (mapcar #'cl--class-allparents (cl--class-parents class))))) -(eval-and-compile - (cl-assert (null (cl--class-parents (cl--find-class 'cl-structure-object))))) +(cl-defstruct (built-in-class + (:include cl--class) + (:noinline t) + (:constructor nil) + (:constructor built-in-class--make (name docstring parents)) + (:copier nil)) + "Type descriptors for built-in types. +The `slots' (and hence `index-table') are currently unused." + ) + +(defmacro cl--define-built-in-type (name parents &optional docstring &rest slots) + ;; `slots' is currently unused, but we could make it take + ;; a list of "slot like properties" together with the corresponding + ;; accessor, and then we could maybe even make `slot-value' work + ;; on some built-in types :-) + (declare (indent 2) (doc-string 3)) + (unless (listp parents) (setq parents (list parents))) + (unless (or parents (eq name t)) + (error "Missing parents for %S: %S" name parents)) + (let ((predicate (intern-soft (format + (if (string-match "-" (symbol-name name)) + "%s-p" "%sp") + name)))) + (unless (fboundp predicate) (setq predicate nil)) + (while (keywordp (car slots)) + (let ((kw (pop slots)) (val (pop slots))) + (pcase kw + (:predicate (setq predicate val)) + (_ (error "Unknown keyword arg: %S" kw))))) + `(progn + ,(if predicate `(put ',name 'cl-deftype-satisfies #',predicate) + ;; (message "Missing predicate for: %S" name) + nil) + (put ',name 'cl--class + (built-in-class--make ',name ,docstring + (mapcar (lambda (type) + (let ((class (get type 'cl--class))) + (unless class + (error "Unknown type: %S" type)) + class)) + ',parents)))))) + +;; FIXME: Our type DAG has various quirks: +;; - Some `keyword's are also `symbol-with-pos' but that's not reflected +;; in the DAG. +;; - An OClosure can be an interpreted function or a `byte-code-function', +;; so the DAG of OClosure types is "orthogonal" to the distinction +;; between interpreted and compiled functions. + +(defun cl-functionp (object) + "Return non-nil if OBJECT is a member of type `function'. +This is like `functionp' except that it returns nil for all lists and symbols, +regardless if `funcall' would accept to call them." + (memq (cl-type-of object) + '(primitive-function subr-native-elisp module-function + interpreted-function byte-code-function))) + +(cl--define-built-in-type t nil "Abstract supertype of everything.") +(cl--define-built-in-type atom t "Abstract supertype of anything but cons cells." + :predicate atom) + +(cl--define-built-in-type tree-sitter-compiled-query atom) +(cl--define-built-in-type tree-sitter-node atom) +(cl--define-built-in-type tree-sitter-parser atom) +(when (fboundp 'user-ptrp) + (cl--define-built-in-type user-ptr atom nil + ;; FIXME: Shouldn't it be called `user-ptr-p'? + :predicate user-ptrp)) +(cl--define-built-in-type font-object atom) +(cl--define-built-in-type font-entity atom) +(cl--define-built-in-type font-spec atom) +(cl--define-built-in-type condvar atom) +(cl--define-built-in-type mutex atom) +(cl--define-built-in-type thread atom) +(cl--define-built-in-type terminal atom) +(cl--define-built-in-type hash-table atom) +(cl--define-built-in-type frame atom) +(cl--define-built-in-type buffer atom) +(cl--define-built-in-type window atom) +(cl--define-built-in-type process atom) +(cl--define-built-in-type finalizer atom) +(cl--define-built-in-type window-configuration atom) +(cl--define-built-in-type overlay atom) +(cl--define-built-in-type number-or-marker atom + "Abstract supertype of both `number's and `marker's.") +(cl--define-built-in-type symbol atom + "Type of symbols." + ;; Example of slots we could document. It would be desirable to + ;; have some way to extract this from the C code, or somehow keep it + ;; in sync (probably not for `cons' and `symbol' but for things like + ;; `font-entity'). + (name symbol-name) + (value symbol-value) + (function symbol-function) + (plist symbol-plist)) + +(cl--define-built-in-type obarray atom) +(cl--define-built-in-type native-comp-unit atom) + +(cl--define-built-in-type sequence t "Abstract supertype of sequences.") +(cl--define-built-in-type list sequence) +(cl--define-built-in-type array (sequence atom) "Abstract supertype of arrays.") +(cl--define-built-in-type number (number-or-marker) + "Abstract supertype of numbers.") +(cl--define-built-in-type float (number)) +(cl--define-built-in-type integer-or-marker (number-or-marker) + "Abstract supertype of both `integer's and `marker's.") +(cl--define-built-in-type integer (number integer-or-marker)) +(cl--define-built-in-type marker (integer-or-marker)) +(cl--define-built-in-type bignum (integer) + "Type of those integers too large to fit in a `fixnum'.") +(cl--define-built-in-type fixnum (integer) + (format "Type of small (fixed-size) integers. +The size depends on the Emacs version and compilation options. +For this build of Emacs it's %dbit." + (1+ (logb (1+ most-positive-fixnum))))) +(cl--define-built-in-type boolean (symbol) + "Type of the canonical boolean values, i.e. either nil or t.") +(cl--define-built-in-type symbol-with-pos (symbol) + "Type of symbols augmented with source-position information.") +(cl--define-built-in-type vector (array)) +(cl--define-built-in-type record (atom) + "Abstract type of objects with slots.") +(cl--define-built-in-type bool-vector (array) "Type of bitvectors.") +(cl--define-built-in-type char-table (array) + "Type of special arrays that are indexed by characters.") +(cl--define-built-in-type string (array)) +(cl--define-built-in-type null (boolean list) ;FIXME: `atom' comes before `list'? + "Type of the nil value." + :predicate null) +(cl--define-built-in-type cons (list) + "Type of cons cells." + ;; Example of slots we could document. + (car car) (cdr cdr)) +(cl--define-built-in-type function (atom) + "Abstract supertype of function values." + ;; FIXME: Historically, (cl-typep FOO 'function) called `functionp', + ;; so while `cl-functionp' would be the more correct predicate, it + ;; would breaks existing code :-( + ;; :predicate cl-functionp + ) +(cl--define-built-in-type compiled-function (function) + "Abstract type of functions that have been compiled.") +(cl--define-built-in-type byte-code-function (compiled-function) + "Type of functions that have been byte-compiled.") +(cl--define-built-in-type subr (atom) + "Abstract type of functions compiled to machine code.") +(cl--define-built-in-type module-function (function) + "Type of functions provided via the module API.") +(cl--define-built-in-type interpreted-function (function) + "Type of functions that have not been compiled.") +(cl--define-built-in-type special-form (subr) + "Type of the core syntactic elements of the Emacs Lisp language.") +(cl--define-built-in-type subr-native-elisp (subr compiled-function) + "Type of functions that have been compiled by the native compiler.") +(cl--define-built-in-type primitive-function (subr compiled-function) + "Type of functions hand written in C.") + +(unless (cl--class-parents (cl--find-class 'cl-structure-object)) + ;; When `cl-structure-object' is created, built-in classes didn't exist + ;; yet, so we couldn't put `record' as the parent. + ;; Fix it now to close the recursion. + (setf (cl--class-parents (cl--find-class 'cl-structure-object)) + (list (cl--find-class 'record)))) ;; Make sure functions defined with cl-defsubst can be inlined even in ;; packages which do not require CL. We don't put an autoload cookie diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index c35353ec3d0..5e5eee1da9e 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -444,7 +444,7 @@ primitives such as `prin1'.") (defun cl-print--preprocess (object) (let ((print-number-table (make-hash-table :test 'eq :rehash-size 2.0))) - (if (fboundp 'print--preprocess) + (if (fboundp 'print--preprocess) ;Emacs≥26 ;; Use the predefined C version if available. (print--preprocess object) ;Fill print-number-table! (let ((cl-print--number-index 0)) diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el index 6ba9664ea5c..4edfe811586 100644 --- a/lisp/emacs-lisp/comp-common.el +++ b/lisp/emacs-lisp/comp-common.el @@ -119,7 +119,7 @@ Used to modify the compiler environment." (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))) + (capitalize (function ((or integer string)) (or integer string))) (car (function (list) t)) (car-less-than-car (function (list list) boolean)) (car-safe (function (t) t)) @@ -240,7 +240,8 @@ Used to modify the compiler environment." (integer-or-marker-p (function (t) boolean)) (integerp (function (t) boolean)) (interactive-p (function () boolean)) - (intern-soft (function ((or string symbol) &optional vector) symbol)) + (intern-soft (function ((or string symbol) &optional (or obarray vector)) + symbol)) (invocation-directory (function () string)) (invocation-name (function () string)) (isnan (function (float) boolean)) @@ -309,7 +310,7 @@ Used to modify the compiler environment." (numberp (function (t) boolean)) (one-window-p (function (&optional t t) boolean)) (overlayp (function (t) boolean)) - (parse-colon-path (function (string) cons)) + (parse-colon-path (function (string) list)) (plist-get (function (list t &optional t) t)) (plist-member (function (list t &optional t) list)) (point (function () integer)) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index c65af16b725..cbfb9540f03 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -38,13 +38,7 @@ (require 'cl-lib) (require 'cl-extra) ;HACK: For `cl-find-class' when `cl-loaddefs' is missing. -(defconst comp--typeof-builtin-types (mapcar (lambda (x) - (append x '(t))) - cl--typeof-types) - ;; TODO can we just add t in `cl--typeof-types'? - "Like `cl--typeof-types' but with t as common supertype.") - -(cl-defstruct (comp-cstr (:constructor comp-type-to-cstr +(cl-defstruct (comp-cstr (:constructor comp--type-to-cstr (type &aux (null (eq type 'null)) (integer (eq type 'integer)) @@ -55,7 +49,7 @@ '(nil))) (range (when integer '((- . +)))))) - (:constructor comp-value-to-cstr + (:constructor comp--value-to-cstr (value &aux (integer (integerp value)) (valset (unless integer @@ -63,7 +57,7 @@ (range (when integer `((,value . ,value)))) (typeset ()))) - (:constructor comp-irange-to-cstr + (:constructor comp--irange-to-cstr (irange &aux (range (list irange)) (typeset ()))) @@ -89,12 +83,7 @@ Integer values are handled in the `range' slot.") (defun comp--cl-class-hierarchy (x) "Given a class name `x' return its hierarchy." - `(,@(cl--class-allparents (cl--struct-get-class x)) - ;; FIXME: AFAICT, `comp--all-classes' will also find those struct types - ;; which use :type and can thus be either `vector' or `cons' (the latter - ;; isn't `atom'). - atom - t)) + (cl--class-allparents (cl--find-class x))) (defun comp--all-classes () "Return all non built-in type names currently defined." @@ -106,15 +95,14 @@ Integer values are handled in the `range' slot.") res)) (defun comp--compute-typeof-types () - (append comp--typeof-builtin-types - (mapcar #'comp--cl-class-hierarchy (comp--all-classes)))) + (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) + do (puthash pred (comp--type-to-cstr class-name) h) finally return h)) (cl-defstruct comp-cstr-ctxt @@ -130,7 +118,7 @@ Integer values are handled in the `range' slot.") ;; TODO we should be able to just cons hash this. (common-supertype-mem (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for -`comp-common-supertype'.") +`comp-ctxt-common-supertype-mem'.") (subtype-p-mem (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for `comp-cstr-ctxt-subtype-p-mem'.") @@ -229,10 +217,10 @@ Return them as multiple value." ;; builds. (defvar comp-ctxt nil) -(defvar comp-cstr-one (comp-value-to-cstr 1) +(defvar comp-cstr-one (comp--value-to-cstr 1) "Represent the integer immediate one.") -(defvar comp-cstr-t (comp-type-to-cstr t) +(defvar comp-cstr-t (comp--type-to-cstr t) "Represent the superclass t.") @@ -249,6 +237,8 @@ Return them as multiple value." t) ((and (not (symbolp x)) (symbolp y)) nil) + ((or (consp x) (consp y) + nil)) (t (< (sxhash-equal x) (sxhash-equal y))))))) @@ -270,18 +260,10 @@ Return them as multiple value." (symbol-name y))) (defun comp--direct-supertypes (type) - "Return the direct supertypes of TYPE." - (let ((supers (comp-supertypes type))) - (cl-assert (eq type (car supers))) - (cl-loop - with notdirect = nil - with direct = nil - for parent in (cdr supers) - unless (memq parent notdirect) - do (progn - (push parent direct) - (setq notdirect (append notdirect (comp-supertypes parent)))) - finally return direct))) + (when (symbolp type) ;; FIXME: Can this test ever fail? + (let* ((class (cl--find-class type)) + (parents (if class (cl--class-parents class)))) + (mapcar #'cl--class-name parents)))) (defsubst comp-subtype-p (type1 type2) "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise." @@ -306,13 +288,10 @@ Return them as multiple value." (apply #'append (mapcar #'comp--direct-supertypes typeset))) for subs = (comp--direct-subtypes sup) - when (and (length> subs 1) ;;FIXME: Why? - ;; Every subtype of `sup` is a subtype of - ;; some element of `typeset`? - ;; It's tempting to just check (member x typeset), - ;; but think of the typeset (marker number), - ;; where `sup' is `integer-or-marker' and `sub' - ;; is `integer'. + when (and (length> subs 1) ;; If there's only one sub do + ;; nothing as we want to + ;; return the most specific + ;; type. (cl-every (lambda (sub) (cl-some (lambda (type) (comp-subtype-p sub type)) @@ -353,23 +332,8 @@ Return them as multiple value." (defun comp-supertypes (type) "Return the ordered list of supertypes of TYPE." - ;; FIXME: We should probably keep the results in - ;; `comp-cstr-ctxt-typeof-types' (or maybe even precompute them - ;; and maybe turn `comp-cstr-ctxt-typeof-types' into a hash-table). - ;; Or maybe we shouldn't keep structs and defclasses in it, - ;; and just use `cl--class-allparents' when needed (and refuse to - ;; compute their direct subtypes since we can't know them). - (cl-loop - named loop - with above - for lane in (comp-cstr-ctxt-typeof-types comp-ctxt) - do (let ((x (memq type lane))) - (cond - ((null x) nil) - ((eq x lane) (cl-return-from loop x)) ;A base type: easy case. - (t (setq above - (if above (comp--intersection x above) x))))) - finally return above)) + (or (assq type (comp-cstr-ctxt-typeof-types comp-ctxt)) + (error "Type %S missing from typeof-types!" type))) (defun comp-union-typesets (&rest typesets) "Union types present into TYPESETS." @@ -608,7 +572,7 @@ All SRCS constraints must be homogeneously negated or non-negated." ;; We propagate only values those types are not already ;; into typeset. when (cl-notany (lambda (x) - (comp-subtype-p (type-of v) x)) + (comp-subtype-p (cl-type-of v) x)) (comp-cstr-typeset dst)) collect v))) @@ -697,7 +661,7 @@ DST is returned." ;; Verify disjoint condition between positive types and ;; negative types coming from values, in case give-up. - (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) + (let ((neg-value-types (nconc (mapcar #'cl-type-of (valset neg)) (when (range neg) '(integer))))) (when (cl-some (lambda (x) @@ -718,7 +682,7 @@ DST is returned." ((cl-some (lambda (x) (cl-some (lambda (y) (comp-subtype-p y x)) - (mapcar #'type-of (valset pos)))) + (mapcar #'cl-type-of (valset pos)))) (typeset neg)) (give-up)) (t @@ -1141,7 +1105,7 @@ DST is returned." (cl-loop for v in (valset dst) unless (symbolp v) do (push v strip-values) - (push (type-of v) strip-types)) + (push (cl-type-of v) strip-types)) (when strip-values (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types) (valset dst) (cl-set-difference (valset dst) strip-values))) @@ -1210,14 +1174,14 @@ FN non-nil indicates we are parsing a function lambda list." ('nil (make-comp-cstr :typeset ())) ('fixnum - (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) + (comp--irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) ('boolean (comp-type-spec-to-cstr '(member t nil))) ('integer - (comp-irange-to-cstr '(- . +))) - ('null (comp-value-to-cstr nil)) + (comp--irange-to-cstr '(- . +))) + ('null (comp--value-to-cstr nil)) ((pred atom) - (comp-type-to-cstr type-spec)) + (comp--type-to-cstr type-spec)) (`(or . ,rest) (apply #'comp-cstr-union-make (mapcar #'comp-type-spec-to-cstr rest))) @@ -1227,16 +1191,16 @@ FN non-nil indicates we are parsing a function lambda list." (`(not ,cstr) (comp-cstr-negation-make (comp-type-spec-to-cstr cstr))) (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h)) - (comp-irange-to-cstr `(,l . ,h))) + (comp--irange-to-cstr `(,l . ,h))) (`(integer * ,(and (pred integerp) h)) - (comp-irange-to-cstr `(- . ,h))) + (comp--irange-to-cstr `(- . ,h))) (`(integer ,(and (pred integerp) l) *) - (comp-irange-to-cstr `(,l . +))) + (comp--irange-to-cstr `(,l . +))) (`(float ,(pred comp-star-or-num-p) ,(pred comp-star-or-num-p)) ;; No float range support :/ - (comp-type-to-cstr 'float)) + (comp--type-to-cstr 'float)) (`(member . ,rest) - (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest))) + (apply #'comp-cstr-union-make (mapcar #'comp--value-to-cstr rest))) (`(function ,args ,ret) (make-comp-cstr-f :args (mapcar (lambda (x) diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el index 5d1a193269d..5cc61579030 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -25,7 +25,7 @@ ;; While the main native compiler is implemented in comp.el, when ;; commonly used as a jit compiler it is only loaded by Emacs sub -;; processes performing async compilation. This files contains all +;; processes performing async compilation. This file contains all ;; the code needed to drive async compilations and any Lisp code ;; needed at runtime to run native code. @@ -72,11 +72,23 @@ Set this variable to nil to suppress warnings altogether, or to the symbol `silent' to log warnings but not pop up the *Warnings* buffer." :type '(choice - (const :tag "Do not report warnings" nil) - (const :tag "Report and display warnings" t) - (const :tag "Report but do not display warnings" silent)) + (const :tag "Do not report warnings/errors" nil) + (const :tag "Report and display warnings/errors" t) + (const :tag "Report but do not display warnings/errors" silent)) :version "28.1") +(defcustom native-comp-async-warnings-errors-kind 'important + "Which kind of warnings and errors to report from async native compilation. + +Setting this variable to `important' (the default) will report +only important warnings and all errors. +Setting this variable to `all' will report all warnings and +errors." + :type '(choice + (const :tag "Report all warnings/errors" all) + (const :tag "Report important warnings and all errors" important)) + :version "30.1") + (defcustom native-comp-always-compile nil "Non-nil means unconditionally (re-)compile all files." :type 'boolean @@ -184,13 +196,21 @@ processes from `comp-async-compilations'" (let ((warning-suppress-types (if (eq native-comp-async-report-warnings-errors 'silent) (cons '(comp) warning-suppress-types) - warning-suppress-types))) + warning-suppress-types)) + (regexp (if (eq native-comp-async-warnings-errors-kind 'all) + "^.*?\\(?:Error\\|Warning\\): .*$" + (rx bol + (*? nonl) + (or + (seq "Error: " (*? nonl)) + (seq "Warning: the function ‘" (1+ (not "’")) + "’ is not known to be defined.")) + eol)))) (with-current-buffer (process-buffer process) (save-excursion (accept-process-output process) (goto-char (or comp-last-scanned-async-output (point-min))) - (while (re-search-forward "^.*?\\(?:Error\\|Warning\\): .*$" - nil t) + (while (re-search-forward regexp nil t) (display-warning 'comp (match-string 0))) (setq comp-last-scanned-async-output (point-max))))) (accept-process-output process))) @@ -213,8 +233,8 @@ display a message." "`comp-files-queue' should be \".el\" files: %s" source-file) when (or native-comp-always-compile - load ; Always compile when the compilation is - ; commanded for late load. + load ; Always compile when the compilation is + ; commanded for late load. ;; Skip compilation if `comp-el-to-eln-filename' fails ;; to find a writable directory. (with-demoted-errors "Async compilation :%S" @@ -236,6 +256,7 @@ display a message." load-path backtrace-line-length byte-compile-warnings + comp-sanitizer-emit ;; package-load-list ;; package-user-dir ;; package-directory-list @@ -344,13 +365,15 @@ Return the trampoline if found or nil otherwise." (when (memq subr-name comp-warn-primitives) (warn "Redefining `%s' might break native compilation of trampolines." subr-name)) - (unless (or (null native-comp-enable-subr-trampolines) - (memq subr-name native-comp-never-optimize-functions) - (gethash subr-name comp-installed-trampolines-h)) - (cl-assert (subr-primitive-p (symbol-function subr-name))) - (when-let ((trampoline (or (comp-trampoline-search subr-name) - (comp-trampoline-compile subr-name)))) - (comp--install-trampoline subr-name trampoline)))) + (let ((subr (symbol-function subr-name))) + (unless (or (not (string= subr-name (subr-name subr))) ;; (bug#69573) + (null native-comp-enable-subr-trampolines) + (memq subr-name native-comp-never-optimize-functions) + (gethash subr-name comp-installed-trampolines-h)) + (cl-assert (subr-primitive-p subr)) + (when-let ((trampoline (or (comp-trampoline-search subr-name) + (comp-trampoline-compile subr-name)))) + (comp--install-trampoline subr-name trampoline))))) ;;;###autoload (defun native--compile-async (files &optional recursively load selector) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 260bd2f1acb..2ec55ed98ee 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -43,7 +43,7 @@ (defvar native-comp-eln-load-path) (defvar native-comp-enable-subr-trampolines) -(declare-function comp--compile-ctxt-to-file "comp.c") +(declare-function comp--compile-ctxt-to-file0 "comp.c") (declare-function comp--init-ctxt "comp.c") (declare-function comp--release-ctxt "comp.c") (declare-function comp-el-to-eln-filename "comp.c") @@ -68,7 +68,7 @@ :safe #'integerp :version "28.1") -(defcustom native-comp-debug 0 +(defcustom native-comp-debug 0 "Debug level for native compilation, a number between 0 and 3. This is intended for debugging the compiler itself. 0 no debug output. @@ -155,17 +155,19 @@ native compilation runs.") "Current allocation class. Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.") -(defconst comp-passes '(comp-spill-lap - comp-limplify - comp-fwprop - comp-call-optim - comp-ipa-pure - comp-add-cstrs - comp-fwprop - comp-tco - comp-fwprop - comp-remove-type-hints - comp-final) +(defconst comp-passes '(comp--spill-lap + comp--limplify + comp--fwprop + comp--call-optim + comp--ipa-pure + comp--add-cstrs + comp--fwprop + comp--tco + comp--fwprop + comp--remove-type-hints + comp--sanitizer + comp--compute-function-types + comp--final) "Passes to be executed in order.") (defvar comp-disabled-passes '() @@ -187,42 +189,56 @@ Useful to hook into pass checkers.") finally return h) "Hash table function -> `comp-constraint'.") +;; Keep it in sync with the `cl-deftype-satisfies' property set in +;; cl-macs.el. We can't use `cl-deftype-satisfies' directly as the +;; relation type <-> predicate is not bijective (bug#45576). (defconst comp-known-predicates - '((arrayp . array) - (atom . atom) - (characterp . fixnum) - (booleanp . boolean) - (bool-vector-p . bool-vector) - (bufferp . buffer) - (natnump . (integer 0 *)) - (char-table-p . char-table) - (hash-table-p . hash-table) - (consp . cons) - (integerp . integer) - (floatp . float) - (functionp . (or function symbol)) - (integerp . integer) - (keywordp . keyword) - (listp . list) - (numberp . number) - (null . null) - (numberp . number) - (sequencep . sequence) - (stringp . string) - (symbolp . symbol) - (vectorp . vector) - (integer-or-marker-p . integer-or-marker)) - "Alist predicate -> matched type specifier.") + ;; FIXME: Auto-generate (most of) it from `cl-deftype-satifies'? + '((arrayp array) + (atom atom) + (bool-vector-p bool-vector) + (booleanp boolean) + (bufferp buffer) + (char-table-p char-table) + (characterp fixnum t) + (consp cons) + (floatp float) + (framep frame) + (functionp (or function symbol cons) (not function)) + (hash-table-p hash-table) + (integer-or-marker-p integer-or-marker) + (integerp integer) + (keywordp symbol t) + (listp list) + (markerp marker) + (natnump (integer 0 *)) + (null null) + (number-or-marker-p number-or-marker) + (numberp number) + (obarrayp obarray) + (overlayp overlay) + (processp process) + (sequencep sequence) + (stringp string) + (subrp subr) + (symbol-with-pos-p symbol-with-pos) + (symbolp symbol) + (vectorp vector) + (windowp window)) + "(PREDICATE TYPE-IF-SATISFIED ?TYPE-IF-NOT-SATISFIED).") (defconst comp-known-predicates-h (cl-loop with comp-ctxt = (make-comp-cstr-ctxt) with h = (make-hash-table :test #'eq) - for (pred . type-spec) in comp-known-predicates - for cstr = (comp-type-spec-to-cstr type-spec) - do (puthash pred cstr h) + for (pred . type-specs) in comp-known-predicates + for pos-cstr = (comp-type-spec-to-cstr (car type-specs)) + for neg-cstr = (if (length> type-specs 1) + (comp-type-spec-to-cstr (cl-second type-specs)) + (comp-cstr-negation-make pos-cstr)) + do (puthash pred (cons pos-cstr neg-cstr) h) finally return h) - "Hash table function -> `comp-constraint'.") + "Hash table FUNCTION -> (POS-CSTR . NEG-CSTR).") (defun comp--known-predicate-p (predicate) "Return t if PREDICATE is known." @@ -230,9 +246,14 @@ Useful to hook into pass checkers.") (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))) t)) -(defun comp--pred-to-cstr (predicate) - "Given PREDICATE, return the corresponding constraint." - (or (gethash predicate comp-known-predicates-h) +(defun comp--pred-to-pos-cstr (predicate) + "Given PREDICATE, return the corresponding positive constraint." + (or (car-safe (gethash predicate comp-known-predicates-h)) + (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))) + +(defun comp--pred-to-neg-cstr (predicate) + "Given PREDICATE, return the corresponding negative constraint." + (or (cdr-safe (gethash predicate comp-known-predicates-h)) (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))) (defconst comp-symbol-values-optimizable '(most-positive-fixnum @@ -388,7 +409,7 @@ This is typically for top-level forms other than defun.") (closed nil :type boolean :documentation "t if closed.") ;; All the following are for SSA and CGF analysis. - ;; Keep in sync with `comp-clean-ssa'!! + ;; Keep in sync with `comp--clean-ssa'!! (in-edges () :type list :documentation "List of incoming edges.") (out-edges () :type list @@ -416,7 +437,7 @@ into it.") :documentation "Start block LAP address.") (non-ret-insn nil :type list :documentation "Insn known to perform a non local exit. -`comp-fwprop' may identify and store here basic blocks performing +`comp--fwprop' may identify and store here basic blocks performing non local exits and mark it rewrite it later.") (no-ret nil :type boolean :documentation "t when the block is known to perform a @@ -507,7 +528,7 @@ CFG is mutated by a pass.") (lambda-list nil :type list :documentation "Original lambda-list.")) -(cl-defstruct (comp-mvar (:constructor make--comp-mvar) +(cl-defstruct (comp-mvar (:constructor make--comp-mvar0) (:include comp-cstr)) "A meta-variable being a slot in the meta-stack." (id nil :type (or null number) @@ -516,6 +537,7 @@ CFG is mutated by a pass.") :documentation "Slot number in the array if a number or `scratch' for scratch slot.")) +;; In use by comp.c. (defun comp-mvar-type-hint-match-p (mvar type-hint) "Match MVAR against TYPE-HINT. In use by the back-end." @@ -569,10 +591,9 @@ In use by the back-end." finally return t) t)) -(defsubst comp--symbol-func-to-fun (symbol-funcion) - "Given a function called SYMBOL-FUNCION return its `comp-func'." - (gethash (gethash symbol-funcion (comp-ctxt-sym-to-c-name-h - comp-ctxt)) +(defsubst comp--symbol-func-to-fun (symbol-func) + "Given a function called SYMBOL-FUNC return its `comp-func'." + (gethash (gethash symbol-func (comp-ctxt-sym-to-c-name-h comp-ctxt)) (comp-ctxt-funcs-h comp-ctxt))) (defun comp--function-pure-p (f) @@ -637,7 +658,7 @@ VERBOSITY is a number between 0 and 3." -(defmacro comp-loop-insn-in-block (basic-block &rest body) +(defmacro comp--loop-insn-in-block (basic-block &rest body) "Loop over all insns in BASIC-BLOCK executing BODY. Inside BODY, `insn' and `insn-cell'can be used to read or set the current instruction or its cell." @@ -651,19 +672,19 @@ current instruction or its cell." ;;; spill-lap pass specific code. -(defun comp-lex-byte-func-p (f) +(defun comp--lex-byte-func-p (f) "Return t if F is a lexically-scoped byte compiled function." (and (byte-code-function-p f) (fixnump (aref f 0)))) -(defun comp-spill-decl-spec (function-name spec) +(defun comp--spill-decl-spec (function-name spec) "Return the declared specifier SPEC for FUNCTION-NAME." (plist-get (cdr (assq function-name byte-to-native-plist-environment)) spec)) -(defun comp-spill-speed (function-name) +(defun comp--spill-speed (function-name) "Return the speed for FUNCTION-NAME." - (or (comp-spill-decl-spec function-name 'speed) + (or (comp--spill-decl-spec function-name 'speed) (comp-ctxt-speed comp-ctxt))) ;; Autoloaded as might be used by `disassemble-internal'. @@ -702,7 +723,7 @@ clashes." ;; pick the first one. (concat prefix crypted "_" human-readable "_0")))) -(defun comp-decrypt-arg-list (x function-name) +(defun comp--decrypt-arg-list (x function-name) "Decrypt argument list X for FUNCTION-NAME." (unless (fixnump x) (signal 'native-compiler-error-dyn-func (list function-name))) @@ -717,21 +738,21 @@ clashes." :nonrest nonrest :rest rest)))) -(defsubst comp-byte-frame-size (byte-compiled-func) +(defsubst comp--byte-frame-size (byte-compiled-func) "Return the frame size to be allocated for BYTE-COMPILED-FUNC." (aref byte-compiled-func 3)) -(defun comp-add-func-to-ctxt (func) +(defun comp--add-func-to-ctxt (func) "Add FUNC to the current compiler context." (let ((name (comp-func-name func)) (c-name (comp-func-c-name func))) (puthash name c-name (comp-ctxt-sym-to-c-name-h comp-ctxt)) (puthash c-name func (comp-ctxt-funcs-h comp-ctxt)))) -(cl-defgeneric comp-spill-lap-function (input) +(cl-defgeneric comp--spill-lap-function (input) "Byte-compile INPUT and spill lap for further stages.") -(cl-defmethod comp-spill-lap-function ((function-name symbol)) +(cl-defmethod comp--spill-lap-function ((function-name symbol)) "Byte-compile FUNCTION-NAME, spilling data from the byte compiler." (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) @@ -747,9 +768,9 @@ clashes." (list (make-byte-to-native-func-def :name function-name :c-name c-name :byte-func byte-code))) - (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))) + (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h))) -(cl-defmethod comp-spill-lap-function ((form list)) +(cl-defmethod comp--spill-lap-function ((form list)) "Byte-compile FORM, spilling data from the byte compiler." (unless (memq (car-safe form) '(lambda closure)) (signal 'native-compiler-error @@ -763,9 +784,9 @@ clashes." (list (make-byte-to-native-func-def :name '--anonymous-lambda :c-name c-name :byte-func byte-code))) - (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))) + (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h))) -(defun comp-intern-func-in-ctxt (_ obj) +(defun comp--intern-func-in-ctxt (_ obj) "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'." (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) (let* ((lap (byte-to-native-lambda-lap obj)) @@ -778,9 +799,9 @@ clashes." (name (when top-l-form (byte-to-native-func-def-name top-l-form))) (c-name (comp-c-func-name (or name "anonymous-lambda") "F")) - (func (if (comp-lex-byte-func-p byte-func) + (func (if (comp--lex-byte-func-p byte-func) (make-comp-func-l - :args (comp-decrypt-arg-list (aref byte-func 0) + :args (comp--decrypt-arg-list (aref byte-func 0) name)) (make-comp-func-d :lambda-list (aref byte-func 0))))) (setf (comp-func-name func) name @@ -790,9 +811,9 @@ clashes." (comp-func-command-modes func) (command-modes byte-func) (comp-func-c-name func) c-name (comp-func-lap func) lap - (comp-func-frame-size func) (comp-byte-frame-size byte-func) - (comp-func-speed func) (comp-spill-speed name) - (comp-func-pure func) (comp-spill-decl-spec name 'pure)) + (comp-func-frame-size func) (comp--byte-frame-size byte-func) + (comp-func-speed func) (comp--spill-speed name) + (comp-func-pure func) (comp--spill-decl-spec name 'pure)) ;; Store the c-name to have it retrievable from ;; `comp-ctxt-top-level-forms'. @@ -800,11 +821,11 @@ clashes." (setf (byte-to-native-func-def-c-name top-l-form) c-name)) (unless name (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) - (comp-add-func-to-ctxt func) + (comp--add-func-to-ctxt func) (comp-log (format "Function %s:\n" name) 1) (comp-log lap 1 t)))) -(cl-defmethod comp-spill-lap-function ((filename string)) +(cl-defmethod comp--spill-lap-function ((filename string)) "Byte-compile FILENAME, spilling data from the byte compiler." (byte-compile-file filename) (when (or (null byte-native-qualities) @@ -829,7 +850,7 @@ clashes." collect (if (and (byte-to-native-func-def-p form) (eq -1 - (comp-spill-speed (byte-to-native-func-def-name form)))) + (comp--spill-speed (byte-to-native-func-def-name form)))) (let ((byte-code (byte-to-native-func-def-byte-func form))) (remhash byte-code byte-to-native-lambdas-h) (make-byte-to-native-top-level @@ -837,11 +858,11 @@ clashes." ',(byte-to-native-func-def-name form) ,byte-code nil) - :lexical (comp-lex-byte-func-p byte-code))) + :lexical (comp--lex-byte-func-p byte-code))) form))) - (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h)) + (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h)) -(defun comp-spill-lap (input) +(defun comp--spill-lap (input) "Byte-compile and spill the LAP representation for INPUT. If INPUT is a symbol, it is the function-name to be compiled. If INPUT is a string, it is the filename to be compiled." @@ -849,7 +870,7 @@ If INPUT is a string, it is the filename to be compiled." (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))) + (res (comp--spill-lap-function input))) (comp-cstr-ctxt-update-type-slots comp-ctxt) res)) @@ -878,55 +899,55 @@ Points to the next slot to be filled.") byte-switch byte-pushconditioncase) "LAP end of basic blocks op codes.") -(defun comp-lap-eob-p (inst) +(defun comp--lap-eob-p (inst) "Return t if INST closes the current basic blocks, nil otherwise." (when (memq (car inst) comp-lap-eob-ops) t)) -(defun comp-lap-fall-through-p (inst) +(defun comp--lap-fall-through-p (inst) "Return t if INST falls through, nil otherwise." (when (not (memq (car inst) '(byte-goto byte-return))) t)) -(defsubst comp-sp () +(defsubst comp--sp () "Current stack pointer." (declare (gv-setter (lambda (val) `(setf (comp-limplify-sp comp-pass) ,val)))) (comp-limplify-sp comp-pass)) -(defmacro comp-with-sp (sp &rest body) +(defmacro comp--with-sp (sp &rest body) "Execute BODY setting the stack pointer to SP. Restore the original value afterwards." (declare (debug (form body)) (indent defun)) (let ((sym (gensym))) - `(let ((,sym (comp-sp))) - (setf (comp-sp) ,sp) + `(let ((,sym (comp--sp))) + (setf (comp--sp) ,sp) (progn ,@body) - (setf (comp-sp) ,sym)))) + (setf (comp--sp) ,sym)))) -(defsubst comp-slot-n (n) +(defsubst comp--slot-n (n) "Slot N into the meta-stack." (comp-vec-aref (comp-limplify-frame comp-pass) n)) -(defsubst comp-slot () +(defsubst comp--slot () "Current slot into the meta-stack pointed by sp." - (comp-slot-n (comp-sp))) + (comp--slot-n (comp--sp))) -(defsubst comp-slot+1 () +(defsubst comp--slot+1 () "Slot into the meta-stack pointed by sp + 1." - (comp-slot-n (1+ (comp-sp)))) + (comp--slot-n (1+ (comp--sp)))) -(defsubst comp-label-to-addr (label) +(defsubst comp--label-to-addr (label) "Find the address of LABEL." (or (gethash label (comp-limplify-label-to-addr comp-pass)) (signal 'native-ice (list "label not found" label)))) -(defsubst comp-mark-curr-bb-closed () +(defsubst comp--mark-curr-bb-closed () "Mark the current basic block as closed." (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)) -(defun comp-bb-maybe-add (lap-addr &optional sp) +(defun comp--bb-maybe-add (lap-addr &optional sp) "If necessary create a pending basic block for LAP-ADDR with stack depth SP. The basic block is returned regardless it was already declared or not." (let ((bb (or (cl-loop ; See if the block was already limplified. @@ -944,24 +965,24 @@ The basic block is returned regardless it was already declared or not." (signal 'native-ice (list "incoherent stack pointers" sp (comp-block-lap-sp bb)))) bb) - (car (push (make--comp-block-lap lap-addr sp (comp-new-block-sym)) + (car (push (make--comp-block-lap lap-addr sp (comp--new-block-sym)) (comp-limplify-pending-blocks comp-pass)))))) -(defsubst comp-call (func &rest args) +(defsubst comp--call (func &rest args) "Emit a call for function FUNC with ARGS." `(call ,func ,@args)) -(defun comp-callref (func nargs stack-off) +(defun comp--callref (func nargs stack-off) "Emit a call using narg abi for FUNC. NARGS is the number of arguments. STACK-OFF is the index of the first slot frame involved." `(callref ,func ,@(cl-loop repeat nargs for sp from stack-off - collect (comp-slot-n sp)))) + collect (comp--slot-n sp)))) -(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type neg) +(cl-defun make--comp-mvar (&key slot (constant nil const-vld) type neg) "`comp-mvar' initializer." - (let ((mvar (make--comp-mvar :slot slot))) + (let ((mvar (make--comp-mvar0 :slot slot))) (when const-vld (comp--add-const-to-relocs constant) (setf (comp-cstr-imm mvar) constant)) @@ -971,49 +992,49 @@ STACK-OFF is the index of the first slot frame involved." (setf (comp-mvar-neg mvar) t)) mvar)) -(defun comp-new-frame (size vsize &optional ssa) +(defun comp--new-frame (size vsize &optional ssa) "Return a clean frame of meta variables of size SIZE and VSIZE. If SSA is non-nil, populate it with m-var in ssa form." (cl-loop with v = (make-comp-vec :beg (- vsize) :end size) for i from (- vsize) below size for mvar = (if ssa - (make-comp-ssa-mvar :slot i) - (make-comp-mvar :slot i)) + (make--comp--ssa-mvar :slot i) + (make--comp-mvar :slot i)) do (setf (comp-vec-aref v i) mvar) finally return v)) -(defun comp-emit (insn) +(defun comp--emit (insn) "Emit INSN into basic block BB." (let ((bb (comp-limplify-curr-block comp-pass))) (cl-assert (not (comp-block-closed bb))) (push insn (comp-block-insns bb)))) -(defun comp-emit-set-call (call) +(defun comp--emit-set-call (call) "Emit CALL assigning the result to the current slot frame. If the callee function is known to have a return type, propagate it." (cl-assert call) - (comp-emit (list 'set (comp-slot) call))) + (comp--emit (list 'set (comp--slot) call))) -(defun comp-copy-slot (src-n &optional dst-n) +(defun comp--copy-slot (src-n &optional dst-n) "Set slot number DST-N to slot number SRC-N as source. If DST-N is specified, use it; otherwise assume it to be the current slot." - (comp-with-sp (or dst-n (comp-sp)) - (let ((src-slot (comp-slot-n src-n))) + (comp--with-sp (or dst-n (comp--sp)) + (let ((src-slot (comp--slot-n src-n))) (cl-assert src-slot) - (comp-emit `(set ,(comp-slot) ,src-slot))))) + (comp--emit `(set ,(comp--slot) ,src-slot))))) -(defsubst comp-emit-annotation (str) +(defsubst comp--emit-annotation (str) "Emit annotation STR." - (comp-emit `(comment ,str))) + (comp--emit `(comment ,str))) -(defsubst comp-emit-setimm (val) +(defsubst comp--emit-setimm (val) "Set constant VAL to current slot." (comp--add-const-to-relocs val) ;; Leave relocation index nil on purpose, will be fixed-up in final ;; by `comp-finalize-relocs'. - (comp-emit `(setimm ,(comp-slot) ,val))) + (comp--emit `(setimm ,(comp--slot) ,val))) -(defun comp-make-curr-block (block-name entry-sp &optional addr) +(defun comp--make-curr-block (block-name entry-sp &optional addr) "Create a basic block with BLOCK-NAME and set it as current block. ENTRY-SP is the sp value when entering. Add block to the current function and return it." @@ -1025,104 +1046,104 @@ Add block to the current function and return it." (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) bb)) -(defun comp-latch-make-fill (target) +(defun comp--latch-make-fill (target) "Create a latch pointing to TARGET and fill it. Return the created latch." - (let ((latch (make-comp-latch :name (comp-new-block-sym "latch"))) + (let ((latch (make-comp-latch :name (comp--new-block-sym "latch"))) (curr-bb (comp-limplify-curr-block comp-pass))) - ;; See `comp-make-curr-block'. + ;; See `comp--make-curr-block'. (setf (comp-limplify-curr-block comp-pass) latch) (when (< (comp-func-speed comp-func) 3) ;; At speed 3 the programmer is responsible to manually ;; place `comp-maybe-gc-or-quit'. - (comp-emit '(call comp-maybe-gc-or-quit))) - ;; See `comp-emit-uncond-jump'. - (comp-emit `(jump ,(comp-block-name target))) - (comp-mark-curr-bb-closed) + (comp--emit '(call comp-maybe-gc-or-quit))) + ;; See `comp--emit-uncond-jump'. + (comp--emit `(jump ,(comp-block-name target))) + (comp--mark-curr-bb-closed) (puthash (comp-block-name latch) latch (comp-func-blocks comp-func)) (setf (comp-limplify-curr-block comp-pass) curr-bb) latch)) -(defun comp-emit-uncond-jump (lap-label) +(defun comp--emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." (cl-destructuring-bind (label-num . stack-depth) lap-label (when stack-depth - (cl-assert (= (1- stack-depth) (comp-sp)))) - (let* ((target-addr (comp-label-to-addr label-num)) - (target (comp-bb-maybe-add target-addr - (comp-sp))) + (cl-assert (= (1- stack-depth) (comp--sp)))) + (let* ((target-addr (comp--label-to-addr label-num)) + (target (comp--bb-maybe-add target-addr + (comp--sp))) (latch (when (< target-addr (comp-limplify-pc comp-pass)) - (comp-latch-make-fill target))) + (comp--latch-make-fill target))) (eff-target-name (comp-block-name (or latch target)))) - (comp-emit `(jump ,eff-target-name)) - (comp-mark-curr-bb-closed)))) + (comp--emit `(jump ,eff-target-name)) + (comp--mark-curr-bb-closed)))) -(defun comp-emit-cond-jump (a b target-offset lap-label negated) +(defun comp--emit-cond-jump (a b target-offset lap-label negated) "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. TARGET-OFFSET is the positive offset on the SP when branching to the target block. If NEGATED is non null, negate the tested condition. Return value is the fall-through block name." (cl-destructuring-bind (label-num . label-sp) lap-label - (let* ((bb (comp-block-name (comp-bb-maybe-add + (let* ((bb (comp-block-name (comp--bb-maybe-add (1+ (comp-limplify-pc comp-pass)) - (comp-sp)))) ; Fall through block. - (target-sp (+ target-offset (comp-sp))) - (target-addr (comp-label-to-addr label-num)) - (target (comp-bb-maybe-add target-addr target-sp)) + (comp--sp)))) ; Fall through block. + (target-sp (+ target-offset (comp--sp))) + (target-addr (comp--label-to-addr label-num)) + (target (comp--bb-maybe-add target-addr target-sp)) (latch (when (< target-addr (comp-limplify-pc comp-pass)) - (comp-latch-make-fill target))) + (comp--latch-make-fill target))) (eff-target-name (comp-block-name (or latch target)))) (when label-sp - (cl-assert (= (1- label-sp) (+ target-offset (comp-sp))))) - (comp-emit (if negated + (cl-assert (= (1- label-sp) (+ target-offset (comp--sp))))) + (comp--emit (if negated (list 'cond-jump a b bb eff-target-name) (list 'cond-jump a b eff-target-name bb))) - (comp-mark-curr-bb-closed) + (comp--mark-curr-bb-closed) bb))) -(defun comp-emit-handler (lap-label handler-type) +(defun comp--emit-handler (lap-label handler-type) "Emit a nonlocal-exit handler to LAP-LABEL of type HANDLER-TYPE." (cl-destructuring-bind (label-num . label-sp) lap-label - (cl-assert (= (- label-sp 2) (comp-sp))) + (cl-assert (= (- label-sp 2) (comp--sp))) (setf (comp-func-has-non-local comp-func) t) - (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) - (comp-sp))) - (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) - (1+ (comp-sp)))) - (pop-bb (make--comp-block-lap nil (comp-sp) (comp-new-block-sym)))) - (comp-emit (list 'push-handler + (let* ((guarded-bb (comp--bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp--sp))) + (handler-bb (comp--bb-maybe-add (comp--label-to-addr label-num) + (1+ (comp--sp)))) + (pop-bb (make--comp-block-lap nil (comp--sp) (comp--new-block-sym)))) + (comp--emit (list 'push-handler handler-type - (comp-slot+1) + (comp--slot+1) (comp-block-name pop-bb) (comp-block-name guarded-bb))) - (comp-mark-curr-bb-closed) + (comp--mark-curr-bb-closed) ;; Emit the basic block to pop the handler if we got the non local. (puthash (comp-block-name pop-bb) pop-bb (comp-func-blocks comp-func)) (setf (comp-limplify-curr-block comp-pass) pop-bb) - (comp-emit `(fetch-handler ,(comp-slot+1))) - (comp-emit `(jump ,(comp-block-name handler-bb))) - (comp-mark-curr-bb-closed)))) + (comp--emit `(fetch-handler ,(comp--slot+1))) + (comp--emit `(jump ,(comp-block-name handler-bb))) + (comp--mark-curr-bb-closed)))) -(defun comp-limplify-listn (n) +(defun comp--limplify-listn (n) "Limplify list N." - (comp-with-sp (+ (comp-sp) n -1) - (comp-emit-set-call (comp-call 'cons - (comp-slot) - (make-comp-mvar :constant nil)))) - (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp) - do (comp-with-sp sp - (comp-emit-set-call (comp-call 'cons - (comp-slot) - (comp-slot+1)))))) - -(defun comp-new-block-sym (&optional postfix) + (comp--with-sp (+ (comp--sp) n -1) + (comp--emit-set-call (comp--call 'cons + (comp--slot) + (make--comp-mvar :constant nil)))) + (cl-loop for sp from (+ (comp--sp) n -2) downto (comp--sp) + do (comp--with-sp sp + (comp--emit-set-call (comp--call 'cons + (comp--slot) + (comp--slot+1)))))) + +(defun comp--new-block-sym (&optional postfix) "Return a unique symbol postfixing POSTFIX naming the next new basic block." (intern (format (if postfix "bb_%s_%s" "bb_%s") (funcall (comp-func-block-cnt-gen comp-func)) postfix))) -(defun comp-fill-label-h () +(defun comp--fill-label-h () "Fill label-to-addr hash table for the current function." (setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql)) (cl-loop for insn in (comp-func-lap comp-func) @@ -1131,10 +1152,10 @@ Return value is the fall-through block name." (`(TAG ,label . ,_) (puthash label addr (comp-limplify-label-to-addr comp-pass)))))) -(defun comp-jump-table-optimizable (jmp-table) +(defun comp--jump-table-optimizable (jmp-table) "Return t if JMP-TABLE can be optimized out." ;; 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-constant #s(hash-table test eq purecopy t data (created 126 deleted 126 changed 126)) . 24) ;; (byte-switch) ;; (TAG 126 . 10) (let ((targets (hash-table-values jmp-table))) @@ -1143,13 +1164,13 @@ Return value is the fall-through block name." (`(TAG ,target . ,_label-sp) (= target (car targets))))))) -(defun comp-emit-switch (var last-insn) +(defun comp--emit-switch (var last-insn) "Emit a Limple for a lap jump table given VAR and LAST-INSN." ;; FIXME this not efficient for big jump tables. We should have a second ;; strategy for this case. (pcase last-insn (`(setimm ,_ ,jmp-table) - (unless (comp-jump-table-optimizable jmp-table) + (unless (comp--jump-table-optimizable jmp-table) (cl-loop for test being each hash-keys of jmp-table using (hash-value target-label) @@ -1157,27 +1178,27 @@ Return value is the fall-through block name." with test-func = (hash-table-test jmp-table) for n from 1 for last = (= n len) - for m-test = (make-comp-mvar :constant test) - for target-name = (comp-block-name (comp-bb-maybe-add - (comp-label-to-addr target-label) - (comp-sp))) + for m-test = (make--comp-mvar :constant test) + for target-name = (comp-block-name (comp--bb-maybe-add + (comp--label-to-addr target-label) + (comp--sp))) for ff-bb = (if last - (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) - (comp-sp)) + (comp--bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp--sp)) (make--comp-block-lap nil - (comp-sp) - (comp-new-block-sym))) + (comp--sp) + (comp--new-block-sym))) for ff-bb-name = (comp-block-name ff-bb) if (eq test-func 'eq) - do (comp-emit (list 'cond-jump var m-test target-name ff-bb-name)) + do (comp--emit (list 'cond-jump var m-test target-name ff-bb-name)) else ;; Store the result of the comparison into the scratch slot before ;; emitting the conditional jump. - do (comp-emit (list 'set (make-comp-mvar :slot 'scratch) - (comp-call test-func var m-test))) - (comp-emit (list 'cond-jump - (make-comp-mvar :slot 'scratch) - (make-comp-mvar :constant nil) + do (comp--emit (list 'set (make--comp-mvar :slot 'scratch) + (comp--call test-func var m-test))) + (comp--emit (list 'cond-jump + (make--comp-mvar :slot 'scratch) + (make--comp-mvar :constant nil) ff-bb-name target-name)) unless last ;; All fall through are artificially created here except the last one. @@ -1192,7 +1213,7 @@ SUBR-NAME is the name of function." (or (gethash subr-name comp-subr-arities-h) (func-arity subr-name))) -(defun comp-emit-set-call-subr (subr-name sp-delta) +(defun comp--emit-set-call-subr (subr-name sp-delta) "Emit a call for SUBR-NAME. SP-DELTA is the stack adjustment." (let* ((nargs (1+ (- sp-delta))) @@ -1203,39 +1224,39 @@ SP-DELTA is the stack adjustment." (signal 'native-ice (list "subr contains unevalled args" subr-name))) (if (eq maxarg 'many) ;; callref case. - (comp-emit-set-call (comp-callref subr-name nargs (comp-sp))) + (comp--emit-set-call (comp--callref subr-name nargs (comp--sp))) ;; Normal call. (unless (and (>= maxarg nargs) (<= minarg nargs)) (signal 'native-ice (list "incoherent stack adjustment" nargs maxarg minarg))) (let* ((subr-name subr-name) (slots (cl-loop for i from 0 below maxarg - collect (comp-slot-n (+ i (comp-sp)))))) - (comp-emit-set-call (apply #'comp-call (cons subr-name slots))))))) + collect (comp--slot-n (+ i (comp--sp)))))) + (comp--emit-set-call (apply #'comp--call (cons subr-name slots))))))) (eval-when-compile - (defun comp-op-to-fun (x) + (defun comp--op-to-fun (x) "Given the LAP op strip \"byte-\" to have the subr name." (intern (string-replace "byte-" "" x))) - (defun comp-body-eff (body op-name sp-delta) + (defun comp--body-eff (body op-name sp-delta) "Given the original BODY, compute the effective one. When BODY is `auto', guess function name from the LAP byte-code name. Otherwise expect lname fnname." (pcase (car body) ('auto - `((comp-emit-set-call-subr ',(comp-op-to-fun op-name) ,sp-delta))) + `((comp--emit-set-call-subr ',(comp--op-to-fun op-name) ,sp-delta))) ((pred symbolp) - `((comp-emit-set-call-subr ',(car body) ,sp-delta))) + `((comp--emit-set-call-subr ',(car body) ,sp-delta))) (_ body)))) -(defmacro comp-op-case (&rest cases) +(defmacro comp--op-case (&rest cases) "Expand CASES into the corresponding `pcase' expansion. This is responsible for generating the proper stack adjustment, when known, and the annotation emission." (declare (debug (body)) (indent defun)) - (declare-function comp-body-eff nil (body op-name sp-delta)) + (declare-function comp--body-eff nil (body op-name sp-delta)) `(pcase op ,@(cl-loop for (op . body) in cases for sp-delta = (gethash op comp-op-stack-info) @@ -1244,55 +1265,55 @@ and the annotation emission." collect `(',op ;; Log all LAP ops except the TAG one. ;; ,(unless (eq op 'TAG) - ;; `(comp-emit-annotation + ;; `(comp--emit-annotation ;; ,(concat "LAP op " op-name))) ;; Emit the stack adjustment if present. ,(when (and sp-delta (not (eq 0 sp-delta))) - `(cl-incf (comp-sp) ,sp-delta)) - ,@(comp-body-eff body op-name sp-delta)) + `(cl-incf (comp--sp) ,sp-delta)) + ,@(comp--body-eff body op-name sp-delta)) else collect `(',op (signal 'native-ice (list "unsupported LAP op" ',op-name)))) (_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op)))))) -(defun comp-limplify-lap-inst (insn) +(defun comp--limplify-lap-inst (insn) "Limplify LAP instruction INSN pushing it in the proper basic block." (let ((op (car insn)) (arg (if (consp (cdr insn)) (cadr insn) (cdr insn)))) - (comp-op-case + (comp--op-case (TAG (cl-destructuring-bind (_TAG label-num . label-sp) insn ;; Paranoid? (when label-sp (cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass)))) - (comp-emit-annotation (format "LAP TAG %d" label-num)))) + (comp--emit-annotation (format "LAP TAG %d" label-num)))) (byte-stack-ref - (comp-copy-slot (- (comp-sp) arg 1))) + (comp--copy-slot (- (comp--sp) arg 1))) (byte-varref - (comp-emit-set-call (comp-call 'symbol-value (make-comp-mvar + (comp--emit-set-call (comp--call 'symbol-value (make--comp-mvar :constant arg)))) (byte-varset - (comp-emit (comp-call 'set_internal - (make-comp-mvar :constant arg) - (comp-slot+1)))) + (comp--emit (comp--call 'set_internal + (make--comp-mvar :constant arg) + (comp--slot+1)))) (byte-varbind ;; Verify - (comp-emit (comp-call 'specbind - (make-comp-mvar :constant arg) - (comp-slot+1)))) + (comp--emit (comp--call 'specbind + (make--comp-mvar :constant arg) + (comp--slot+1)))) (byte-call - (cl-incf (comp-sp) (- arg)) - (comp-emit-set-call (comp-callref 'funcall (1+ arg) (comp-sp)))) + (cl-incf (comp--sp) (- arg)) + (comp--emit-set-call (comp--callref 'funcall (1+ arg) (comp--sp)))) (byte-unbind - (comp-emit (comp-call 'helper_unbind_n - (make-comp-mvar :constant arg)))) + (comp--emit (comp--call 'helper_unbind_n + (make--comp-mvar :constant arg)))) (byte-pophandler - (comp-emit '(pop-handler))) + (comp--emit '(pop-handler))) (byte-pushconditioncase - (comp-emit-handler (cddr insn) 'condition-case)) + (comp--emit-handler (cddr insn) 'condition-case)) (byte-pushcatch - (comp-emit-handler (cddr insn) 'catcher)) + (comp--emit-handler (cddr insn) 'catcher)) (byte-nth auto) (byte-symbolp auto) (byte-consp auto) @@ -1301,19 +1322,19 @@ and the annotation emission." (byte-eq auto) (byte-memq auto) (byte-not - (comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp)) - (make-comp-mvar :constant nil)))) + (comp--emit-set-call (comp--call 'eq (comp--slot-n (comp--sp)) + (make--comp-mvar :constant nil)))) (byte-car auto) (byte-cdr auto) (byte-cons auto) (byte-list1 - (comp-limplify-listn 1)) + (comp--limplify-listn 1)) (byte-list2 - (comp-limplify-listn 2)) + (comp--limplify-listn 2)) (byte-list3 - (comp-limplify-listn 3)) + (comp--limplify-listn 3)) (byte-list4 - (comp-limplify-listn 4)) + (comp--limplify-listn 4)) (byte-length auto) (byte-aref auto) (byte-aset auto) @@ -1324,11 +1345,11 @@ and the annotation emission." (byte-get auto) (byte-substring auto) (byte-concat2 - (comp-emit-set-call (comp-callref 'concat 2 (comp-sp)))) + (comp--emit-set-call (comp--callref 'concat 2 (comp--sp)))) (byte-concat3 - (comp-emit-set-call (comp-callref 'concat 3 (comp-sp)))) + (comp--emit-set-call (comp--callref 'concat 3 (comp--sp)))) (byte-concat4 - (comp-emit-set-call (comp-callref 'concat 4 (comp-sp)))) + (comp--emit-set-call (comp--callref 'concat 4 (comp--sp)))) (byte-sub1 1-) (byte-add1 1+) (byte-eqlsign =) @@ -1338,7 +1359,7 @@ and the annotation emission." (byte-geq >=) (byte-diff -) (byte-negate - (comp-emit-set-call (comp-call 'negate (comp-slot)))) + (comp--emit-set-call (comp--call 'negate (comp--slot)))) (byte-plus +) (byte-max auto) (byte-min auto) @@ -1353,9 +1374,9 @@ and the annotation emission." (byte-preceding-char preceding-char) (byte-current-column auto) (byte-indent-to - (comp-emit-set-call (comp-call 'indent-to - (comp-slot) - (make-comp-mvar :constant nil)))) + (comp--emit-set-call (comp--call 'indent-to + (comp--slot) + (make--comp-mvar :constant nil)))) (byte-scan-buffer-OBSOLETE) (byte-eolp auto) (byte-eobp auto) @@ -1364,7 +1385,7 @@ and the annotation emission." (byte-current-buffer auto) (byte-set-buffer auto) (byte-save-current-buffer - (comp-emit (comp-call 'record_unwind_current_buffer))) + (comp--emit (comp--call 'record_unwind_current_buffer))) (byte-set-mark-OBSOLETE) (byte-interactive-p-OBSOLETE) (byte-forward-char auto) @@ -1376,41 +1397,41 @@ and the annotation emission." (byte-buffer-substring auto) (byte-delete-region auto) (byte-narrow-to-region - (comp-emit-set-call (comp-call 'narrow-to-region - (comp-slot) - (comp-slot+1)))) + (comp--emit-set-call (comp--call 'narrow-to-region + (comp--slot) + (comp--slot+1)))) (byte-widen - (comp-emit-set-call (comp-call 'widen))) + (comp--emit-set-call (comp--call 'widen))) (byte-end-of-line auto) (byte-constant2) ; TODO ;; Branches. (byte-goto - (comp-emit-uncond-jump (cddr insn))) + (comp--emit-uncond-jump (cddr insn))) (byte-goto-if-nil - (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 + (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 0 (cddr insn) nil)) (byte-goto-if-not-nil - (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 + (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 0 (cddr insn) t)) (byte-goto-if-nil-else-pop - (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 + (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 1 (cddr insn) nil)) (byte-goto-if-not-nil-else-pop - (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 + (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 1 (cddr insn) t)) (byte-return - (comp-emit `(return ,(comp-slot+1)))) + (comp--emit `(return ,(comp--slot+1)))) (byte-discard 'pass) (byte-dup - (comp-copy-slot (1- (comp-sp)))) + (comp--copy-slot (1- (comp--sp)))) (byte-save-excursion - (comp-emit (comp-call 'record_unwind_protect_excursion))) + (comp--emit (comp--call 'record_unwind_protect_excursion))) (byte-save-window-excursion-OBSOLETE) (byte-save-restriction - (comp-emit (comp-call 'helper_save_restriction))) + (comp--emit (comp--call 'helper_save_restriction))) (byte-catch) ;; Obsolete (byte-unwind-protect - (comp-emit (comp-call 'helper_unwind_protect (comp-slot+1)))) + (comp--emit (comp--call 'helper_unwind_protect (comp--slot+1)))) (byte-condition-case) ;; Obsolete (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) @@ -1437,61 +1458,61 @@ and the annotation emission." (byte-numberp auto) (byte-integerp auto) (byte-listN - (cl-incf (comp-sp) (- 1 arg)) - (comp-emit-set-call (comp-callref 'list arg (comp-sp)))) + (cl-incf (comp--sp) (- 1 arg)) + (comp--emit-set-call (comp--callref 'list arg (comp--sp)))) (byte-concatN - (cl-incf (comp-sp) (- 1 arg)) - (comp-emit-set-call (comp-callref 'concat arg (comp-sp)))) + (cl-incf (comp--sp) (- 1 arg)) + (comp--emit-set-call (comp--callref 'concat arg (comp--sp)))) (byte-insertN - (cl-incf (comp-sp) (- 1 arg)) - (comp-emit-set-call (comp-callref 'insert arg (comp-sp)))) + (cl-incf (comp--sp) (- 1 arg)) + (comp--emit-set-call (comp--callref 'insert arg (comp--sp)))) (byte-stack-set - (comp-copy-slot (1+ (comp-sp)) (- (comp-sp) arg -1))) + (comp--copy-slot (1+ (comp--sp)) (- (comp--sp) arg -1))) (byte-stack-set2 (cl-assert nil)) ;; TODO (byte-discardN - (cl-incf (comp-sp) (- arg))) + (cl-incf (comp--sp) (- arg))) (byte-switch ;; Assume to follow the emission of a setimm. - ;; This is checked into comp-emit-switch. - (comp-emit-switch (comp-slot+1) + ;; This is checked into comp--emit-switch. + (comp--emit-switch (comp--slot+1) (cl-first (comp-block-insns (comp-limplify-curr-block comp-pass))))) (byte-constant - (comp-emit-setimm arg)) + (comp--emit-setimm arg)) (byte-discardN-preserve-tos - (cl-incf (comp-sp) (- arg)) - (comp-copy-slot (+ arg (comp-sp))))))) + (cl-incf (comp--sp) (- arg)) + (comp--copy-slot (+ arg (comp--sp))))))) -(defun comp-emit-narg-prologue (minarg nonrest rest) +(defun comp--emit-narg-prologue (minarg nonrest rest) "Emit the prologue for a narg function." (cl-loop for i below minarg - do (comp-emit `(set-args-to-local ,(comp-slot-n i))) - (comp-emit '(inc-args))) + do (comp--emit `(set-args-to-local ,(comp--slot-n i))) + (comp--emit '(inc-args))) (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_%s" i)) for fallback = (intern (format "entry_fallback_%s" i)) - do (comp-emit `(cond-jump-narg-leq ,i ,fallback ,bb)) - (comp-make-curr-block bb (comp-sp)) - (comp-emit `(set-args-to-local ,(comp-slot-n i))) - (comp-emit '(inc-args)) - finally (comp-emit '(jump entry_rest_args))) + do (comp--emit `(cond-jump-narg-leq ,i ,fallback ,bb)) + (comp--make-curr-block bb (comp--sp)) + (comp--emit `(set-args-to-local ,(comp--slot-n i))) + (comp--emit '(inc-args)) + finally (comp--emit '(jump entry_rest_args))) (when (/= minarg nonrest) (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_fallback_%s" i)) for next-bb = (if (= (1+ i) nonrest) 'entry_rest_args (intern (format "entry_fallback_%s" (1+ i)))) - do (comp-with-sp i - (comp-make-curr-block bb (comp-sp)) - (comp-emit-setimm nil) - (comp-emit `(jump ,next-bb))))) - (comp-make-curr-block 'entry_rest_args (comp-sp)) - (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest))) - (setf (comp-sp) nonrest) + do (comp--with-sp i + (comp--make-curr-block bb (comp--sp)) + (comp--emit-setimm nil) + (comp--emit `(jump ,next-bb))))) + (comp--make-curr-block 'entry_rest_args (comp--sp)) + (comp--emit `(set-rest-args-to-local ,(comp--slot-n nonrest))) + (setf (comp--sp) nonrest) (when (and (> nonrest 8) (null rest)) - (cl-decf (comp-sp)))) + (cl-decf (comp--sp)))) -(defun comp-limplify-finalize-function (func) +(defun comp--limplify-finalize-function (func) "Reverse insns into all basic blocks of FUNC." (cl-loop for bb being the hash-value in (comp-func-blocks func) do (setf (comp-block-insns bb) @@ -1499,49 +1520,49 @@ and the annotation emission." (comp--log-func func 2) func) -(cl-defgeneric comp-prepare-args-for-top-level (function) +(cl-defgeneric comp--prepare-args-for-top-level (function) "Given FUNCTION, return the two arguments for comp--register-...") -(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-l)) +(cl-defmethod comp--prepare-args-for-top-level ((function comp-func-l)) "Lexically-scoped FUNCTION." (let ((args (comp-func-l-args function))) - (cons (make-comp-mvar :constant (comp-args-base-min args)) - (make-comp-mvar :constant (cond + (cons (make--comp-mvar :constant (comp-args-base-min args)) + (make--comp-mvar :constant (cond ((comp-args-p args) (comp-args-max args)) ((comp-nargs-rest args) 'many) (t (comp-nargs-nonrest args))))))) -(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-d)) +(cl-defmethod comp--prepare-args-for-top-level ((function comp-func-d)) "Dynamically scoped FUNCTION." - (cons (make-comp-mvar :constant (func-arity (comp-func-byte-func function))) + (cons (make--comp-mvar :constant (func-arity (comp-func-byte-func function))) (let ((comp-curr-allocation-class 'd-default)) ;; Lambda-lists must stay in the same relocation class of ;; the object referenced by code to respect uninterned ;; symbols. - (make-comp-mvar :constant (comp-func-d-lambda-list function))))) + (make--comp-mvar :constant (comp-func-d-lambda-list function))))) -(cl-defgeneric comp-emit-for-top-level (form for-late-load) +(cl-defgeneric comp--emit-for-top-level (form for-late-load) "Emit the Limple code for top level FORM.") -(cl-defmethod comp-emit-for-top-level ((form byte-to-native-func-def) +(cl-defmethod comp--emit-for-top-level ((form byte-to-native-func-def) for-late-load) (let* ((name (byte-to-native-func-def-name form)) (c-name (byte-to-native-func-def-c-name form)) (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt))) - (args (comp-prepare-args-for-top-level f))) + (args (comp--prepare-args-for-top-level f))) (cl-assert (and name f)) - (comp-emit - `(set ,(make-comp-mvar :slot 1) - ,(comp-call (if for-late-load + (comp--emit + `(set ,(make--comp-mvar :slot 1) + ,(comp--call (if for-late-load 'comp--late-register-subr 'comp--register-subr) - (make-comp-mvar :constant name) - (make-comp-mvar :constant c-name) + (make--comp-mvar :constant name) + (make--comp-mvar :constant c-name) (car args) (cdr args) (setf (comp-func-type f) - (make-comp-mvar :constant nil)) - (make-comp-mvar + (make--comp-mvar :constant nil)) + (make--comp-mvar :constant (list (let* ((h (comp-ctxt-function-docs comp-ctxt)) @@ -1552,40 +1573,40 @@ and the annotation emission." (comp-func-command-modes f))) ;; This is the compilation unit it-self passed as ;; parameter. - (make-comp-mvar :slot 0)))))) + (make--comp-mvar :slot 0)))))) -(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level) +(cl-defmethod comp--emit-for-top-level ((form byte-to-native-top-level) for-late-load) (unless for-late-load - (comp-emit - (comp-call 'eval + (comp--emit + (comp--call 'eval (let ((comp-curr-allocation-class 'd-impure)) - (make-comp-mvar :constant + (make--comp-mvar :constant (byte-to-native-top-level-form form))) - (make-comp-mvar :constant + (make--comp-mvar :constant (byte-to-native-top-level-lexical form)))))) -(defun comp-emit-lambda-for-top-level (func) +(defun comp--emit-lambda-for-top-level (func) "Emit the creation of subrs for lambda FUNC. These are stored in the reloc data array." - (let ((args (comp-prepare-args-for-top-level func))) + (let ((args (comp--prepare-args-for-top-level func))) (let ((comp-curr-allocation-class 'd-impure)) (comp--add-const-to-relocs (comp-func-byte-func func))) - (comp-emit - (comp-call 'comp--register-lambda + (comp--emit + (comp--call 'comp--register-lambda ;; mvar to be fixed-up when containers are ;; finalized. (or (gethash (comp-func-byte-func func) (comp-ctxt-lambda-fixups-h comp-ctxt)) (puthash (comp-func-byte-func func) - (make-comp-mvar :constant nil) + (make--comp-mvar :constant nil) (comp-ctxt-lambda-fixups-h comp-ctxt))) - (make-comp-mvar :constant (comp-func-c-name func)) + (make--comp-mvar :constant (comp-func-c-name func)) (car args) (cdr args) (setf (comp-func-type func) - (make-comp-mvar :constant nil)) - (make-comp-mvar + (make--comp-mvar :constant nil)) + (make--comp-mvar :constant (list (let* ((h (comp-ctxt-function-docs comp-ctxt)) @@ -1596,9 +1617,9 @@ These are stored in the reloc data array." (comp-func-command-modes func))) ;; This is the compilation unit it-self passed as ;; parameter. - (make-comp-mvar :slot 0))))) + (make--comp-mvar :slot 0))))) -(defun comp-limplify-top-level (for-late-load) +(defun comp--limplify-top-level (for-late-load) "Create a Limple function to modify the global environment at load. When FOR-LATE-LOAD is non-nil, the emitted function modifies only function definition. @@ -1628,22 +1649,22 @@ into the C code forwarding the compilation unit." (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block-lap -1 0 'top-level) - :frame (comp-new-frame 1 0)))) - (comp-make-curr-block 'entry (comp-sp)) - (comp-emit-annotation (if for-late-load + :frame (comp--new-frame 1 0)))) + (comp--make-curr-block 'entry (comp--sp)) + (comp--emit-annotation (if for-late-load "Late top level" "Top level")) ;; Assign the compilation unit incoming as parameter to the slot frame 0. - (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0)) + (comp--emit `(set-par-to-local ,(comp--slot-n 0) 0)) (maphash (lambda (_ func) - (comp-emit-lambda-for-top-level func)) + (comp--emit-lambda-for-top-level func)) (comp-ctxt-byte-func-to-func-h comp-ctxt)) - (mapc (lambda (x) (comp-emit-for-top-level x for-late-load)) + (mapc (lambda (x) (comp--emit-for-top-level x for-late-load)) (comp-ctxt-top-level-forms comp-ctxt)) - (comp-emit `(return ,(make-comp-mvar :slot 1))) - (comp-limplify-finalize-function func))) + (comp--emit `(return ,(make--comp-mvar :slot 1))) + (comp--limplify-finalize-function func))) -(defun comp-addr-to-bb-name (addr) +(defun comp--addr-to-bb-name (addr) "Search for a block starting at ADDR into pending or limplified blocks." ;; FIXME Actually we could have another hash for this. (cl-flet ((pred (bb) @@ -1655,7 +1676,7 @@ into the C code forwarding the compilation unit." when (pred bb) return (comp-block-name bb))))) -(defun comp-limplify-block (bb) +(defun comp--limplify-block (bb) "Limplify basic-block BB and add it to the current function." (setf (comp-limplify-curr-block comp-pass) bb (comp-limplify-sp comp-pass) (comp-block-lap-sp bb) @@ -1666,51 +1687,51 @@ into the C code forwarding the compilation unit." (comp-func-lap comp-func)) for inst = (car inst-cell) for next-inst = (car-safe (cdr inst-cell)) - do (comp-limplify-lap-inst inst) + do (comp--limplify-lap-inst inst) (cl-incf (comp-limplify-pc comp-pass)) - when (comp-lap-fall-through-p inst) + when (comp--lap-fall-through-p inst) do (pcase next-inst (`(TAG ,_label . ,label-sp) (when label-sp - (cl-assert (= (1- label-sp) (comp-sp)))) + (cl-assert (= (1- label-sp) (comp--sp)))) (let* ((stack-depth (if label-sp (1- label-sp) - (comp-sp))) - (next-bb (comp-block-name (comp-bb-maybe-add + (comp--sp))) + (next-bb (comp-block-name (comp--bb-maybe-add (comp-limplify-pc comp-pass) stack-depth)))) (unless (comp-block-closed bb) - (comp-emit `(jump ,next-bb)))) + (comp--emit `(jump ,next-bb)))) (cl-return))) - until (comp-lap-eob-p inst))) + until (comp--lap-eob-p inst))) -(defun comp-limplify-function (func) +(defun comp--limplify-function (func) "Limplify a single function FUNC." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) (comp-pass (make-comp-limplify - :frame (comp-new-frame frame-size 0)))) - (comp-fill-label-h) + :frame (comp--new-frame frame-size 0)))) + (comp--fill-label-h) ;; Prologue - (comp-make-curr-block 'entry (comp-sp)) - (comp-emit-annotation (concat "Lisp function: " + (comp--make-curr-block 'entry (comp--sp)) + (comp--emit-annotation (concat "Lisp function: " (symbol-name (comp-func-name func)))) ;; Dynamic functions have parameters bound by the trampoline. (when (comp-func-l-p func) (let ((args (comp-func-l-args func))) (if (comp-args-p args) (cl-loop for i below (comp-args-max args) - do (cl-incf (comp-sp)) - (comp-emit `(set-par-to-local ,(comp-slot) ,i))) - (comp-emit-narg-prologue (comp-args-base-min args) + do (cl-incf (comp--sp)) + (comp--emit `(set-par-to-local ,(comp--slot) ,i))) + (comp--emit-narg-prologue (comp-args-base-min args) (comp-nargs-nonrest args) (comp-nargs-rest args))))) - (comp-emit '(jump bb_0)) + (comp--emit '(jump bb_0)) ;; Body - (comp-bb-maybe-add 0 (comp-sp)) + (comp--bb-maybe-add 0 (comp--sp)) (cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass)) while next-bb - do (comp-limplify-block next-bb)) + do (comp--limplify-block next-bb)) ;; Sanity check against block duplication. (cl-loop with addr-h = (make-hash-table) for bb being the hash-value in (comp-func-blocks func) @@ -1719,15 +1740,15 @@ into the C code forwarding the compilation unit." when addr do (cl-assert (null (gethash addr addr-h))) (puthash addr t addr-h)) - (comp-limplify-finalize-function func))) + (comp--limplify-finalize-function func))) -(defun comp-limplify (_) +(defun comp--limplify (_) "Compute LIMPLE IR for forms in `comp-ctxt'." - (maphash (lambda (_ f) (comp-limplify-function f)) + (maphash (lambda (_ f) (comp--limplify-function f)) (comp-ctxt-funcs-h comp-ctxt)) - (comp-add-func-to-ctxt (comp-limplify-top-level nil)) + (comp--add-func-to-ctxt (comp--limplify-top-level nil)) (when (comp-ctxt-with-late-load comp-ctxt) - (comp-add-func-to-ctxt (comp-limplify-top-level t)))) + (comp--add-func-to-ctxt (comp--limplify-top-level t)))) ;;; add-cstrs pass specific code. @@ -1751,22 +1772,22 @@ into the C code forwarding the compilation unit." ;; type specifier. -(defsubst comp-mvar-used-p (mvar) +(defsubst comp--mvar-used-p (mvar) "Non-nil when MVAR is used as lhs in the current function." (declare (gv-setter (lambda (val) `(puthash ,mvar ,val comp-pass)))) (gethash mvar comp-pass)) -(defun comp-collect-mvars (form) +(defun comp--collect-mvars (form) "Add rhs m-var present in FORM into `comp-pass'." (cl-loop for x in form if (consp x) - do (comp-collect-mvars x) + do (comp--collect-mvars x) else when (comp-mvar-p x) - do (setf (comp-mvar-used-p x) t))) + do (setf (comp--mvar-used-p x) t))) -(defun comp-collect-rhs () +(defun comp--collect-rhs () "Collect all lhs mvars into `comp-pass'." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) @@ -1774,11 +1795,13 @@ into the C code forwarding the compilation unit." for insn in (comp-block-insns b) for (op . args) = insn if (comp--assign-op-p op) - do (comp-collect-mvars (cdr args)) + do (comp--collect-mvars (if (eq op 'setimm) + (cl-first args) + (cdr args))) else - do (comp-collect-mvars args)))) + do (comp--collect-mvars args)))) -(defun comp-negate-arithm-cmp-fun (function) +(defun comp--negate-arithm-cmp-fun (function) "Negate FUNCTION. Return nil if we don't want to emit constraints for its negation." (cl-ecase function @@ -1788,7 +1811,7 @@ Return nil if we don't want to emit constraints for its negation." (>= '<) (<= '>))) -(defun comp-reverse-arithm-fun (function) +(defun comp--reverse-arithm-fun (function) "Reverse FUNCTION." (cl-case function (= '=) @@ -1798,7 +1821,7 @@ Return nil if we don't want to emit constraints for its negation." (<= '>=) (t function))) -(defun comp-emit-assume (kind lhs rhs bb negated) +(defun comp--emit-assume (kind lhs rhs bb negated) "Emit an assume of kind KIND for mvar LHS being RHS. When NEGATED is non-nil, the assumption is negated. The assume is emitted at the beginning of the block BB." @@ -1808,41 +1831,41 @@ The assume is emitted at the beginning of the block BB." ((or 'and 'and-nhc) (if (comp-mvar-p rhs) (let ((tmp-mvar (if negated - (make-comp-mvar :slot (comp-mvar-slot rhs)) + (make--comp-mvar :slot (comp-mvar-slot rhs)) rhs))) - (push `(assume ,(make-comp-mvar :slot lhs-slot) + (push `(assume ,(make--comp-mvar :slot lhs-slot) (,kind ,lhs ,tmp-mvar)) (comp-block-insns bb)) (if negated (push `(assume ,tmp-mvar (not ,rhs)) (comp-block-insns bb)))) ;; If is only a constraint we can negate it directly. - (push `(assume ,(make-comp-mvar :slot lhs-slot) + (push `(assume ,(make--comp-mvar :slot lhs-slot) (,kind ,lhs ,(if negated (comp-cstr-negation-make rhs) rhs))) (comp-block-insns bb)))) ((pred comp--arithm-cmp-fun-p) (when-let ((kind (if negated - (comp-negate-arithm-cmp-fun kind) + (comp--negate-arithm-cmp-fun kind) kind))) - (push `(assume ,(make-comp-mvar :slot lhs-slot) + (push `(assume ,(make--comp-mvar :slot lhs-slot) (,kind ,lhs ,(if-let* ((vld (comp-cstr-imm-vld-p rhs)) (val (comp-cstr-imm rhs)) (ok (and (integerp val) (not (memq kind '(= !=)))))) val - (make-comp-mvar :slot (comp-mvar-slot rhs))))) + (make--comp-mvar :slot (comp-mvar-slot rhs))))) (comp-block-insns bb)))) (_ (cl-assert nil))) (setf (comp-func-ssa-status comp-func) 'dirty))) -(defun comp-maybe-add-vmvar (op cmp-res insns-seq) +(defun comp--maybe-add-vmvar (op cmp-res insns-seq) "If CMP-RES is clobbering OP emit a new constrained mvar and return it. Return OP otherwise." (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) - (new-mvar (make-comp-mvar + (new-mvar (make--comp-mvar :slot (- (cl-incf (comp-func-vframe-size comp-func)))))) (progn @@ -1850,7 +1873,7 @@ Return OP otherwise." new-mvar) op)) -(defun comp-add-new-block-between (bb-symbol bb-a bb-b) +(defun comp--add-new-block-between (bb-symbol bb-a bb-b) "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B." (cl-loop with new-bb = (make-comp-block-cstr :name bb-symbol @@ -1873,7 +1896,7 @@ Return OP otherwise." finally (cl-assert nil))) ;; Cheap substitute to a copy propagation pass... -(defun comp-cond-cstrs-target-mvar (mvar exit-insn bb) +(defun comp--cond-cstrs-target-mvar (mvar exit-insn bb) "Given MVAR, search in BB the original mvar MVAR got assigned from. Keep on searching till EXIT-INSN is encountered." (cl-flet ((targetp (x) @@ -1890,7 +1913,7 @@ Keep on searching till EXIT-INSN is encountered." (setf res rhs))) finally (cl-assert nil)))) -(defun comp-add-cond-cstrs-target-block (curr-bb target-bb-sym) +(defun comp--add-cond-cstrs-target-block (curr-bb target-bb-sym) "Return the appropriate basic block to add constraint assumptions into. CURR-BB is the current basic block. TARGET-BB-SYM is the symbol name of the target block." @@ -1910,10 +1933,10 @@ TARGET-BB-SYM is the symbol name of the target block." until (null (gethash new-name (comp-func-blocks comp-func))) finally ;; Add it. - (cl-return (comp-add-new-block-between new-name curr-bb target-bb)))))) + (cl-return (comp--add-new-block-between new-name curr-bb target-bb)))))) -(defun comp-add-cond-cstrs-simple () - "`comp-add-cstrs' worker function for each selected function." +(defun comp--add-cond-cstrs-simple () + "`comp--add-cstrs' worker function for each selected function." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do @@ -1929,26 +1952,26 @@ TARGET-BB-SYM is the symbol name of the target block." for branch-target-cell on blocks for branch-target = (car branch-target-cell) for negated in '(nil t) - when (comp-mvar-used-p tmp-mvar) + when (comp--mvar-used-p tmp-mvar) do - (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (let ((block-target (comp--add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume 'and tmp-mvar obj2 block-target negated)) + (comp--emit-assume 'and tmp-mvar obj2 block-target negated)) finally (cl-return-from in-the-basic-block))) (`((cond-jump ,obj1 ,obj2 . ,blocks)) (cl-loop for branch-target-cell on blocks for branch-target = (car branch-target-cell) for negated in '(nil t) - when (comp-mvar-used-p obj1) + when (comp--mvar-used-p obj1) do - (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (let ((block-target (comp--add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume 'and obj1 obj2 block-target negated)) + (comp--emit-assume 'and obj1 obj2 block-target negated)) finally (cl-return-from in-the-basic-block))))))) -(defun comp-add-cond-cstrs () - "`comp-add-cstrs' worker function for each selected function." +(defun comp--add-cond-cstrs () + "`comp--add-cstrs' worker function for each selected function." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do @@ -1967,13 +1990,13 @@ TARGET-BB-SYM is the symbol name of the target block." (set ,(and (pred comp-mvar-p) mvar-3) (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2))) (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2)) - (comp-emit-assume 'and mvar-tested - (make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)) - (comp-add-cond-cstrs-target-block b bb2) + (comp--emit-assume 'and mvar-tested + (make--comp-mvar :type (comp-cstr-cl-tag mvar-tag)) + (comp--add-cond-cstrs-target-block b bb2) nil) - (comp-emit-assume 'and mvar-tested - (make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)) - (comp-add-cond-cstrs-target-block b bb1) + (comp--emit-assume 'and mvar-tested + (make--comp-mvar :type (comp-cstr-cl-tag mvar-tag)) + (comp--add-cond-cstrs-target-block b bb1) t)) (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp--call-op-p) @@ -1984,8 +2007,8 @@ TARGET-BB-SYM is the symbol name of the target block." ;; (comment ,_comment-str) (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) (cl-loop - with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) - with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) + with target-mvar1 = (comp--cond-cstrs-target-mvar op1 (car insns-seq) b) + with target-mvar2 = (comp--cond-cstrs-target-mvar op2 (car insns-seq) b) for branch-target-cell on blocks for branch-target = (car branch-target-cell) for negated in '(t nil) @@ -1994,61 +2017,51 @@ TARGET-BB-SYM is the symbol name of the target block." (eql 'and-nhc) (eq 'and) (t fun)) - when (or (comp-mvar-used-p target-mvar1) - (comp-mvar-used-p target-mvar2)) + when (or (comp--mvar-used-p target-mvar1) + (comp--mvar-used-p target-mvar2)) do - (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (let ((block-target (comp--add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) - (when (comp-mvar-used-p target-mvar1) - (comp-emit-assume kind target-mvar1 - (comp-maybe-add-vmvar op2 cmp-res prev-insns-seq) + (when (comp--mvar-used-p target-mvar1) + (comp--emit-assume kind target-mvar1 + (comp--maybe-add-vmvar op2 cmp-res prev-insns-seq) block-target negated)) - (when (comp-mvar-used-p target-mvar2) - (comp-emit-assume (comp-reverse-arithm-fun kind) + (when (comp--mvar-used-p target-mvar2) + (comp--emit-assume (comp--reverse-arithm-fun kind) target-mvar2 - (comp-maybe-add-vmvar op1 cmp-res prev-insns-seq) + (comp--maybe-add-vmvar op1 cmp-res prev-insns-seq) block-target negated))) finally (cl-return-from in-the-basic-block))) (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp--call-op-p) ,(and (pred comp--known-predicate-p) fun) ,op)) - ;; (comment ,_comment-str) - (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) - (cl-loop - with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) - with cstr = (comp--pred-to-cstr fun) - for branch-target-cell on blocks - for branch-target = (car branch-target-cell) - for negated in '(t nil) - when (comp-mvar-used-p target-mvar) - do - (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) - (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume 'and target-mvar cstr block-target negated)) - finally (cl-return-from in-the-basic-block))) - ;; Match predicate on the negated branch (unless). - (`((set ,(and (pred comp-mvar-p) cmp-res) - (,(pred comp--call-op-p) - ,(and (pred comp--known-predicate-p) fun) - ,op)) - (set ,neg-cmp-res (call eq ,cmp-res ,(pred comp-cstr-null-p))) - (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks)) + . ,(or + ;; (comment ,_comment-str) + (and `((cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) + (let negated-branch nil)) + (and `((set ,neg-cmp-res + (call eq ,cmp-res ,(pred comp-cstr-null-p))) + (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks)) + (let negated-branch t)))) (cl-loop - with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) - with cstr = (comp--pred-to-cstr fun) + with target-mvar = (comp--cond-cstrs-target-mvar op (car insns-seq) b) for branch-target-cell on blocks for branch-target = (car branch-target-cell) - for negated in '(nil t) - when (comp-mvar-used-p target-mvar) + for negated in (if negated-branch '(nil t) '(t nil)) + when (comp--mvar-used-p target-mvar) do - (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (let ((block-target (comp--add-cond-cstrs-target-block + b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume 'and target-mvar cstr block-target negated)) + (comp--emit-assume 'and target-mvar (if negated + (comp--pred-to-neg-cstr fun) + (comp--pred-to-pos-cstr fun)) + block-target nil)) finally (cl-return-from in-the-basic-block)))) (setf prev-insns-seq insns-seq)))) -(defsubst comp-insert-insn (insn insn-cell) +(defsubst comp--insert-insn (insn insn-cell) "Insert INSN as second insn of INSN-CELL." (let ((next-cell (cdr insn-cell)) (new-cell `(,insn))) @@ -2056,15 +2069,15 @@ TARGET-BB-SYM is the symbol name of the target block." (cdr new-cell) next-cell (comp-func-ssa-status comp-func) 'dirty))) -(defun comp-emit-call-cstr (mvar call-cell cstr) +(defun comp--emit-call-cstr (mvar call-cell cstr) "Emit a constraint CSTR for MVAR after CALL-CELL." - (let* ((new-mvar (make-comp-mvar :slot (comp-mvar-slot mvar))) + (let* ((new-mvar (make--comp-mvar :slot (comp-mvar-slot mvar))) ;; Have new-mvar as LHS *and* RHS to ensure monotonicity and ;; fwprop convergence!! (insn `(assume ,new-mvar (and ,new-mvar ,mvar ,cstr)))) - (comp-insert-insn insn call-cell))) + (comp--insert-insn insn call-cell))) -(defun comp-lambda-list-gen (lambda-list) +(defun comp--lambda-list-gen (lambda-list) "Return a generator to iterate over LAMBDA-LIST." (lambda () (cl-case (car lambda-list) @@ -2080,12 +2093,12 @@ TARGET-BB-SYM is the symbol name of the target block." (car lambda-list) (setf lambda-list (cdr lambda-list))))))) -(defun comp-add-call-cstr () +(defun comp--add-call-cstr () "Add args assumptions for each function of which the type specifier is known." (cl-loop for bb being each hash-value of (comp-func-blocks comp-func) do - (comp-loop-insn-in-block bb + (comp--loop-insn-in-block bb (when-let ((match (pcase insn (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args)) @@ -2096,10 +2109,10 @@ TARGET-BB-SYM is the symbol name of the target block." (cl-values f cstr-f nil args)))))) (cl-multiple-value-bind (f cstr-f lhs args) match (cl-loop - with gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f)) + with gen = (comp--lambda-list-gen (comp-cstr-f-args cstr-f)) for arg in args for cstr = (funcall gen) - for target = (comp-cond-cstrs-target-mvar arg insn bb) + for target = (comp--cond-cstrs-target-mvar arg insn bb) unless (comp-cstr-p cstr) do (signal 'native-ice (list "Incoherent type specifier for function" f)) @@ -2110,9 +2123,9 @@ TARGET-BB-SYM is the symbol name of the target block." (or (null lhs) (not (eql (comp-mvar-slot lhs) (comp-mvar-slot target))))) - do (comp-emit-call-cstr target insn-cell cstr))))))) + do (comp--emit-call-cstr target insn-cell cstr))))))) -(defun comp-add-cstrs (_) +(defun comp--add-cstrs (_) "Rewrite conditional branches adding appropriate `assume' insns. This is introducing and placing `assume' insns in use by fwprop to propagate conditional branch test information on target basic @@ -2126,10 +2139,10 @@ blocks." (not (comp-func-has-non-local f))) (let ((comp-func f) (comp-pass (make-hash-table :test #'eq))) - (comp-collect-rhs) - (comp-add-cond-cstrs-simple) - (comp-add-cond-cstrs) - (comp-add-call-cstr) + (comp--collect-rhs) + (comp--add-cond-cstrs-simple) + (comp--add-cond-cstrs) + (comp--add-call-cstr) (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2141,7 +2154,7 @@ blocks." ;; avoid optimizing-out functions and preventing their redefinition ;; being effective. -(defun comp-collect-calls (f) +(defun comp--collect-calls (f) "Return a list with all the functions called by F." (cl-loop with h = (make-hash-table :test #'eq) @@ -2161,17 +2174,17 @@ blocks." (comp-ctxt-funcs-h comp-ctxt))) f)))) -(defun comp-pure-infer-func (f) +(defun comp--pure-infer-func (f) "If all functions called by F are pure then F is pure too." (when (and (cl-every (lambda (x) (or (comp--function-pure-p x) (eq x (comp-func-name f)))) - (comp-collect-calls f)) + (comp--collect-calls f)) (not (eq (comp-func-pure f) t))) (comp-log (format "%s inferred to be pure" (comp-func-name f))) (setf (comp-func-pure f) t))) -(defun comp-ipa-pure (_) +(defun comp--ipa-pure (_) "Infer function purity." (cl-loop with pure-n = 0 @@ -2184,7 +2197,7 @@ blocks." when (and (>= (comp-func-speed f) 3) (comp-func-l-p f) (not (comp-func-pure f))) - do (comp-pure-infer-func f) + do (comp--pure-infer-func f) count (comp-func-pure f)))) finally (comp-log (format "ipa-pure iterated %d times" n)))) @@ -2198,13 +2211,13 @@ blocks." ;; this form is called 'minimal SSA form'. ;; This pass should be run every time basic blocks or m-var are shuffled. -(cl-defun make-comp-ssa-mvar (&rest rest &key _slot _constant _type) - "Same as `make-comp-mvar' but set the `id' slot." - (let ((mvar (apply #'make-comp-mvar rest))) +(cl-defun make--comp--ssa-mvar (&rest rest &key _slot _constant _type) + "Same as `make--comp-mvar' but set the `id' slot." + (let ((mvar (apply #'make--comp-mvar rest))) (setf (comp-mvar-id mvar) (sxhash-eq mvar)) mvar)) -(defun comp-clean-ssa (f) +(defun comp--clean-ssa (f) "Clean-up SSA for function F." (setf (comp-func-edges-h f) (make-hash-table)) (cl-loop @@ -2220,7 +2233,7 @@ blocks." unless (eq 'phi (car insn)) collect insn)))) -(defun comp-compute-edges () +(defun comp--compute-edges () "Compute the basic block edges for the current function." (cl-loop with blocks = (comp-func-blocks comp-func) for bb being each hash-value of blocks @@ -2256,7 +2269,7 @@ blocks." (comp-block-in-edges (comp-edge-dst edge)))) (comp--log-edges comp-func))) -(defun comp-collect-rev-post-order (basic-block) +(defun comp--collect-rev-post-order (basic-block) "Walk BASIC-BLOCK children and return their name in reversed post-order." (let ((visited (make-hash-table)) (acc ())) @@ -2271,7 +2284,7 @@ blocks." (collect-rec basic-block) acc))) -(defun comp-compute-dominator-tree () +(defun comp--compute-dominator-tree () "Compute immediate dominators for each basic block in current function." ;; Originally based on: "A Simple, Fast Dominance Algorithm" ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). @@ -2296,7 +2309,7 @@ blocks." ;; No point to go on if the only bb is 'entry'. (bb0 (gethash 'bb_0 blocks))) (cl-loop - with rev-bb-list = (comp-collect-rev-post-order entry) + with rev-bb-list = (comp--collect-rev-post-order entry) with changed = t while changed initially (progn @@ -2323,7 +2336,7 @@ blocks." new-idom) changed t)))))) -(defun comp-compute-dominator-frontiers () +(defun comp--compute-dominator-frontiers () "Compute the dominator frontier for each basic block in `comp-func'." ;; Originally based on: "A Simple, Fast Dominance Algorithm" ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). @@ -2338,7 +2351,7 @@ blocks." (puthash b-name b (comp-block-df runner)) (setf runner (comp-block-idom runner)))))) -(defun comp-log-block-info () +(defun comp--log-block-info () "Log basic blocks info for the current function." (maphash (lambda (name bb) (let ((dom (comp-block-idom bb)) @@ -2351,7 +2364,7 @@ blocks." 3))) (comp-func-blocks comp-func))) -(defun comp-place-phis () +(defun comp--place-phis () "Place phi insns into the current function." ;; Originally based on: Static Single Assignment Book ;; Algorithm 3.1: Standard algorithm for inserting phi-functions @@ -2392,7 +2405,7 @@ blocks." (unless (cl-find y defs-v) (push y w)))))))) -(defun comp-dom-tree-walker (bb pre-lambda post-lambda) +(defun comp--dom-tree-walker (bb pre-lambda post-lambda) "Dominator tree walker function starting from basic block BB. PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (when pre-lambda @@ -2402,18 +2415,18 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." for child = (comp-edge-dst ed) when (eq bb (comp-block-idom child)) ;; Current block is the immediate dominator then recur. - do (comp-dom-tree-walker child pre-lambda post-lambda))) + do (comp--dom-tree-walker child pre-lambda post-lambda))) (when post-lambda (funcall post-lambda bb))) -(cl-defstruct (comp-ssa (:copier nil)) +(cl-defstruct (comp--ssa (:copier nil)) "Support structure used while SSA renaming." - (frame (comp-new-frame (comp-func-frame-size comp-func) + (frame (comp--new-frame (comp-func-frame-size comp-func) (comp-func-vframe-size comp-func) t) :type comp-vec :documentation "`comp-vec' of m-vars.")) -(defun comp-ssa-rename-insn (insn frame) +(defun comp--ssa-rename-insn (insn frame) (cl-loop for slot-n from (- (comp-func-vframe-size comp-func)) below (comp-func-frame-size comp-func) @@ -2424,17 +2437,19 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (eql slot-n (comp-mvar-slot x)))) (new-lvalue () ;; If is an assignment make a new mvar and put it as l-value. - (let ((mvar (make-comp-ssa-mvar :slot slot-n))) + (let ((mvar (make--comp--ssa-mvar :slot slot-n))) (setf (comp-vec-aref frame slot-n) mvar (cadr insn) mvar)))) (pcase insn + (`(setimm ,(pred targetp) ,_imm) + (new-lvalue)) (`(,(pred comp--assign-op-p) ,(pred targetp) . ,_) (let ((mvar (comp-vec-aref frame slot-n))) (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn)))) (new-lvalue)) (`(fetch-handler . ,_) ;; Clobber all no matter what! - (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) + (setf (comp-vec-aref frame slot-n) (make--comp--ssa-mvar :slot slot-n))) (`(phi ,n) (when (equal n slot-n) (new-lvalue))) @@ -2442,7 +2457,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (let ((mvar (comp-vec-aref frame slot-n))) (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) -(defun comp-ssa-rename () +(defun comp--ssa-rename () "Entry point to rename into SSA within the current function." (comp-log "Renaming\n" 2) (let ((visited (make-hash-table))) @@ -2450,7 +2465,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (unless (gethash bb visited) (puthash bb t visited) (cl-loop for insn in (comp-block-insns bb) - do (comp-ssa-rename-insn insn in-frame)) + do (comp--ssa-rename-insn insn in-frame)) (setf (comp-block-final-frame bb) (copy-sequence in-frame)) (when-let ((out-edges (comp-block-out-edges bb))) @@ -2461,11 +2476,11 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." do (ssa-rename-rec child (comp-vec-copy in-frame))))))) (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func)) - (comp-new-frame (comp-func-frame-size comp-func) + (comp--new-frame (comp-func-frame-size comp-func) (comp-func-vframe-size comp-func) t))))) -(defun comp-finalize-phis () +(defun comp--finalize-phis () "Fixup r-values into phis in all basic blocks." (cl-flet ((finalize-phi (args b) ;; Concatenate into args all incoming m-vars for this phi. @@ -2482,7 +2497,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." when (eq op 'phi) do (finalize-phi args b))))) -(defun comp-remove-unreachable-blocks () +(defun comp--remove-unreachable-blocks () "Remove unreachable basic blocks. Return t when one or more block was removed, nil otherwise." (cl-loop @@ -2498,7 +2513,7 @@ Return t when one or more block was removed, nil otherwise." ret t) finally return ret)) -(defun comp-ssa () +(defun comp--ssa () "Port all functions into minimal SSA form." (maphash (lambda (_ f) (let* ((comp-func f) @@ -2506,15 +2521,15 @@ Return t when one or more block was removed, nil otherwise." (unless (eq ssa-status t) (cl-loop when (eq ssa-status 'dirty) - do (comp-clean-ssa f) - do (comp-compute-edges) - (comp-compute-dominator-tree) - until (null (comp-remove-unreachable-blocks))) - (comp-compute-dominator-frontiers) - (comp-log-block-info) - (comp-place-phis) - (comp-ssa-rename) - (comp-finalize-phis) + do (comp--clean-ssa f) + do (comp--compute-edges) + (comp--compute-dominator-tree) + until (null (comp--remove-unreachable-blocks))) + (comp--compute-dominator-frontiers) + (comp--log-block-info) + (comp--place-phis) + (comp--ssa-rename) + (comp--finalize-phis) (comp--log-func comp-func 3) (setf (comp-func-ssa-status f) t)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2526,12 +2541,12 @@ Return t when one or more block was removed, nil otherwise." ;; This is also responsible for removing function calls to pure functions if ;; possible. -(defconst comp-fwprop-max-insns-scan 4500 +(defconst comp--fwprop-max-insns-scan 4500 ;; Chosen as ~ the greatest required value for full convergence ;; native compiling all Emacs code-base. "Max number of scanned insn before giving-up.") -(defun comp-copy-insn (insn) +(defun comp--copy-insn-rec (insn) "Deep copy INSN." ;; Adapted from `copy-tree'. (if (consp insn) @@ -2539,16 +2554,23 @@ Return t when one or more block was removed, nil otherwise." (while (consp insn) (let ((newcar (car insn))) (if (or (consp (car insn)) (comp-mvar-p (car insn))) - (setf newcar (comp-copy-insn (car insn)))) + (setf newcar (comp--copy-insn (car insn)))) (push newcar result)) (setf insn (cdr insn))) (nconc (nreverse result) - (if (comp-mvar-p insn) (comp-copy-insn insn) insn))) + (if (comp-mvar-p insn) (comp--copy-insn insn) insn))) (if (comp-mvar-p insn) (copy-comp-mvar insn) insn))) -(defmacro comp-apply-in-env (func &rest args) +(defun comp--copy-insn (insn) + "Deep copy INSN." + (pcase insn + (`(setimm ,mvar ,imm) + `(setimm ,(copy-comp-mvar mvar) ,imm)) + (_ (comp--copy-insn-rec insn)))) + +(defmacro comp--apply-in-env (func &rest args) "Apply FUNC to ARGS in the current compilation environment." `(let ((env (cl-loop for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt) @@ -2564,7 +2586,7 @@ Return t when one or more block was removed, nil otherwise." for (func-name . def) in env do (setf (symbol-function func-name) def))))) -(defun comp-fwprop-prologue () +(defun comp--fwprop-prologue () "Prologue for the propagate pass. Here goes everything that can be done not iteratively (read once). Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or invoked? @@ -2576,16 +2598,16 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or (`(setimm ,lval ,v) (setf (comp-cstr-imm lval) v)))))) -(defun comp-function-foldable-p (f args) +(defun comp--function-foldable-p (f args) "Given function F called with ARGS, return non-nil when optimizable." (and (comp--function-pure-p f) (cl-every #'comp-cstr-imm-vld-p args))) -(defun comp-function-call-maybe-fold (insn f args) +(defun comp--function-call-maybe-fold (insn f args) "Given INSN, when F is pure if all ARGS are known, remove the function call. Return non-nil if the function is folded successfully." (cl-flet ((rewrite-insn-as-setimm (insn value) - ;; See `comp-emit-setimm'. + ;; See `comp--emit-setimm'. (comp--add-const-to-relocs value) (setf (car insn) 'setimm (cddr insn) `(,value)))) @@ -2597,7 +2619,7 @@ Return non-nil if the function is folded successfully." comp-symbol-values-optimizable))) (rewrite-insn-as-setimm insn (symbol-value (comp-cstr-imm (car args)))))) - ((comp-function-foldable-p f args) + ((comp--function-foldable-p f args) (ignore-errors ;; No point to complain here in case of error because we ;; should do basic block pruning in order to be sure that this @@ -2608,14 +2630,14 @@ Return non-nil if the function is folded successfully." ;; and know to be pure. (comp-func-byte-func f-in-ctxt) f)) - (value (comp-apply-in-env f (mapcar #'comp-cstr-imm args)))) + (value (comp--apply-in-env f (mapcar #'comp-cstr-imm args)))) (rewrite-insn-as-setimm insn value))))))) -(defun comp-fwprop-call (insn lval f args) +(defun comp--fwprop-call (insn lval f args) "Propagate on a call INSN into LVAL. F is the function being called with arguments ARGS. Fold the call in case." - (unless (comp-function-call-maybe-fold insn f args) + (unless (comp--function-call-maybe-fold insn f args) (when (and (eq 'funcall f) (comp-cstr-imm-vld-p (car args))) (setf f (comp-cstr-imm (car args)) @@ -2636,16 +2658,16 @@ Fold the call in case." (comp-type-spec-to-cstr (comp-cstr-imm (car args))))))))) -(defun comp-fwprop-insn (insn) +(defun comp--fwprop-insn (insn) "Propagate within INSN." (pcase insn (`(set ,lval ,rval) (pcase rval (`(,(or 'call 'callref) ,f . ,args) - (comp-fwprop-call insn lval f args)) + (comp--fwprop-call insn lval f args)) (`(,(or 'direct-call 'direct-callref) ,f . ,args) (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) - (comp-fwprop-call insn lval f args))) + (comp--fwprop-call insn lval f args))) (_ (comp-cstr-shallow-copy lval rval)))) (`(assume ,lval ,(and (pred comp-mvar-p) rval)) @@ -2690,7 +2712,7 @@ Fold the call in case." (rvals (mapcar #'car rest))) (apply prop-fn lval rvals))))) -(defun comp-fwprop* () +(defun comp--fwprop* () "Propagate for set* and phi operands. Return t if something was changed." (cl-loop named outer @@ -2702,17 +2724,17 @@ Return t if something was changed." for insn in (comp-block-insns b) for orig-insn = (unless modified ;; Save consing after 1st change. - (comp-copy-insn insn)) + (comp--copy-insn insn)) do - (comp-fwprop-insn insn) + (comp--fwprop-insn insn) (cl-incf i) when (and (null modified) (not (equal insn orig-insn))) do (setf modified t)) - when (> i comp-fwprop-max-insns-scan) + when (> i comp--fwprop-max-insns-scan) do (cl-return-from outer nil) finally return modified)) -(defun comp-rewrite-non-locals () +(defun comp--rewrite-non-locals () "Make explicit in LIMPLE non-local exits if identified." (cl-loop for bb being each hash-value of (comp-func-blocks comp-func) @@ -2729,26 +2751,26 @@ Return t if something was changed." (cdr insn-seq) '((unreachable)) (comp-func-ssa-status comp-func) 'dirty)))) -(defun comp-fwprop (_) +(defun comp--fwprop (_) "Forward propagate types and consts within the lattice." - (comp-ssa) - (comp-dead-code) + (comp--ssa) + (comp--dead-code) (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 2) ;; FIXME remove the following condition when tested. (not (comp-func-has-non-local f))) (let ((comp-func f)) - (comp-fwprop-prologue) + (comp--fwprop-prologue) (cl-loop for i from 1 to 100 - while (comp-fwprop*) + while (comp--fwprop*) finally (when (= i 100) (display-warning 'comp (format "fwprop pass jammed into %s?" (comp-func-name f)))) (comp-log (format "Propagation run %d times\n" i) 2)) - (comp-rewrite-non-locals) + (comp--rewrite-non-locals) (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2768,7 +2790,7 @@ Return t if something was changed." ;; the full compilation unit. ;; For this reason this is triggered only at native-comp-speed == 3. -(defun comp-func-in-unit (func) +(defun comp--func-in-unit (func) "Given FUNC return the `comp-fun' definition in the current context. FUNCTION can be a function-name or byte compiled function." (if (symbolp func) @@ -2776,11 +2798,11 @@ FUNCTION can be a function-name or byte compiled function." (cl-assert (byte-code-function-p func)) (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt)))) -(defun comp-call-optim-form-call (callee args) +(defun comp--call-optim-form-call (callee args) (cl-flet ((fill-args (args total) ;; Fill missing args to reach TOTAL (append args (cl-loop repeat (- total (length args)) - collect (make-comp-mvar :constant nil))))) + collect (make--comp-mvar :constant nil))))) (when (and callee (or (symbolp callee) (gethash callee (comp-ctxt-byte-func-to-func-h comp-ctxt))) @@ -2798,7 +2820,7 @@ FUNCTION can be a function-name or byte compiled function." ;; actually cheaper since it avoids the call to the ;; intermediate native trampoline (bug#67005). (subrp (subrp f)) - (comp-func-callee (comp-func-in-unit callee))) + (comp-func-callee (comp--func-in-unit callee))) (cond ((and subrp (not (subr-native-elisp-p f))) ;; Trampoline removal. @@ -2833,30 +2855,30 @@ FUNCTION can be a function-name or byte compiled function." ((comp--type-hint-p callee) `(call ,callee ,@args))))))) -(defun comp-call-optim-func () +(defun comp--call-optim-func () "Perform the trampoline call optimization for the current function." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (comp-loop-insn-in-block b + do (comp--loop-insn-in-block b (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) (when-let ((ok (comp-cstr-imm-vld-p f)) - (new-form (comp-call-optim-form-call + (new-form (comp--call-optim-form-call (comp-cstr-imm f) rest))) (setf insn `(set ,lval ,new-form)))) (`(callref funcall ,f . ,rest) (when-let ((ok (comp-cstr-imm-vld-p f)) - (new-form (comp-call-optim-form-call + (new-form (comp--call-optim-form-call (comp-cstr-imm f) rest))) (setf insn new-form))))))) -(defun comp-call-optim (_) +(defun comp--call-optim (_) "Try to optimize out funcall trampoline usage when possible." (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 2) (comp-func-l-p f)) (let ((comp-func f)) - (comp-call-optim-func)))) + (comp--call-optim-func)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2867,16 +2889,16 @@ FUNCTION can be a function-name or byte compiled function." ;; ;; This pass can be run as last optim. -(defun comp-collect-mvar-ids (insn) +(defun comp--collect-mvar-ids (insn) "Collect the m-var unique identifiers into INSN." (cl-loop for x in insn if (consp x) - append (comp-collect-mvar-ids x) + append (comp--collect-mvar-ids x) else when (comp-mvar-p x) collect (comp-mvar-id x))) -(defun comp-dead-assignments-func () +(defun comp--dead-assignments-func () "Clean-up dead assignments into current function. Return the list of m-var ids nuked." (let ((l-vals ()) @@ -2889,9 +2911,10 @@ Return the list of m-var ids nuked." for (op arg0 . rest) = insn if (comp--assign-op-p op) do (push (comp-mvar-id arg0) l-vals) - (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) + (unless (eq op 'setimm) + (setf r-vals (nconc (comp--collect-mvar-ids rest) r-vals))) else - do (setf r-vals (nconc (comp-collect-mvar-ids insn) r-vals)))) + do (setf r-vals (nconc (comp--collect-mvar-ids insn) r-vals)))) ;; Every l-value appearing that does not appear as r-value has no right to ;; exist and gets nuked. (let ((nuke-list (cl-set-difference l-vals r-vals))) @@ -2903,7 +2926,7 @@ Return the list of m-var ids nuked." 3) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (comp-loop-insn-in-block b + do (comp--loop-insn-in-block b (cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn (when (and (comp--assign-op-p op) (memq (comp-mvar-id arg0) nuke-list)) @@ -2914,7 +2937,7 @@ Return the list of m-var ids nuked." insn)))))))) nuke-list))) -(defun comp-dead-code () +(defun comp--dead-code () "Dead code elimination." (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 2) @@ -2923,7 +2946,7 @@ Return the list of m-var ids nuked." (cl-loop for comp-func = f for i from 1 - while (comp-dead-assignments-func) + while (comp--dead-assignments-func) finally (comp-log (format "dead code rm run %d times\n" i) 2) (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2931,14 +2954,14 @@ Return the list of m-var ids nuked." ;;; Tail Call Optimization pass specific code. -(defun comp-form-tco-call-seq (args) +(defun comp--form-tco-call-seq (args) "Generate a TCO sequence for ARGS." `(,@(cl-loop for arg in args for i from 0 - collect `(set ,(make-comp-mvar :slot i) ,arg)) + collect `(set ,(make--comp-mvar :slot i) ,arg)) (jump bb_0))) -(defun comp-tco-func () +(defun comp--tco-func () "Try to pattern match and perform TCO within the current function." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) @@ -2951,20 +2974,20 @@ Return the list of m-var ids nuked." (return ,ret-val)) (when (and (string= func (comp-func-c-name comp-func)) (eq l-val ret-val)) - (let ((tco-seq (comp-form-tco-call-seq args))) + (let ((tco-seq (comp--form-tco-call-seq args))) (setf (car insns-seq) (car tco-seq) (cdr insns-seq) (cdr tco-seq) (comp-func-ssa-status comp-func) 'dirty) (cl-return-from in-the-basic-block)))))))) -(defun comp-tco (_) +(defun comp--tco (_) "Simple peephole pass performing self TCO." (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 3) (comp-func-l-p f) (not (comp-func-has-non-local f))) (let ((comp-func f)) - (comp-tco-func) + (comp--tco-func) (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2974,54 +2997,88 @@ Return the list of m-var ids nuked." ;; This must run after all SSA prop not to have the type hint ;; information overwritten. -(defun comp-remove-type-hints-func () +(defun comp--remove-type-hints-func () "Remove type hints from the current function. These are substituted with a normal `set' op." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (comp-loop-insn-in-block b + do (comp--loop-insn-in-block b (pcase insn (`(set ,l-val (call ,(pred comp--type-hint-p) ,r-val)) (setf insn `(set ,l-val ,r-val))))))) -(defun comp-remove-type-hints (_) +(defun comp--remove-type-hints (_) "Dead code elimination." (maphash (lambda (_ f) (when (>= (comp-func-speed f) 2) (let ((comp-func f)) - (comp-remove-type-hints-func) + (comp--remove-type-hints-func) (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) -;;; Final pass specific code. +;;; Sanitizer pass specific code. -(defun comp-args-to-lambda-list (args) - "Return a lambda list for ARGS." - (cl-loop - with res - repeat (comp-args-base-min args) - do (push t res) - finally - (if (comp-args-p args) - (cl-loop - with n = (- (comp-args-max args) (comp-args-min args)) - initially (unless (zerop n) - (push '&optional res)) - repeat n - do (push t res)) +;; This pass aims to verify compile-time value-type predictions during +;; execution of the code. +;; The sanitizer pass injects a call to 'helper_sanitizer_assert' before +;; each conditional branch. 'helper_sanitizer_assert' will verify that +;; the variable tested by the conditional branch is of the predicted +;; value type, or signal an error otherwise. + +;;; Example: + +;; Assume we want to compile 'test.el' and test the function `foo' +;; defined in it. Then: + +;; - Native-compile 'test.el' instrumenting it for sanitizer usage: +;; (let ((comp-sanitizer-emit t)) +;; (load (native-compile "test.el"))) + +;; - Run `foo' with the sanitizer active: +;; (let ((comp-sanitizer-active t)) +;; (foo)) + +(defvar comp-sanitizer-emit nil + "Gates the sanitizer pass. +This is intended to be used only for development and verification of +the native compiler.") + +(defun comp--sanitizer (_) + (when comp-sanitizer-emit + (cl-loop + for f being each hash-value of (comp-ctxt-funcs-h comp-ctxt) + for comp-func = f + unless (comp-func-has-non-local comp-func) + do (cl-loop - with n = (- (comp-nargs-nonrest args) (comp-nargs-min args)) - initially (unless (zerop n) - (push '&optional res)) - repeat n - do (push t res) - finally (when (comp-nargs-rest args) - (push '&rest res) - (push 't res)))) - (cl-return (reverse res)))) + for b being each hash-value of (comp-func-blocks f) + do + (cl-loop + named in-the-basic-block + for insns-seq on (comp-block-insns b) + do (pcase insns-seq + (`((cond-jump ,(and (pred comp-mvar-p) mvar-tested) + ,(pred comp-mvar-p) ,_bb1 ,_bb2)) + (let ((type (comp-cstr-to-type-spec mvar-tested)) + (insn (car insns-seq))) + ;; No need to check if type is t. + (unless (eq type t) + (comp--add-const-to-relocs type) + (setcar + insns-seq + (comp--call 'helper_sanitizer_assert + mvar-tested + (make--comp-mvar :constant type))) + (setcdr insns-seq (list insn))) + ;; (setf (comp-func-ssa-status comp-func) 'dirty) + (cl-return-from in-the-basic-block)))))) + do (comp--log-func comp-func 3)))) + + +;;; Function types pass specific code. -(defun comp-compute-function-type (_ func) +(defun comp--compute-function-type (_ func) "Compute type specifier for `comp-func' FUNC. Set it into the `type' slot." (when (and (comp-func-l-p func) @@ -3041,13 +3098,45 @@ Set it into the `type' slot." (`(return ,mvar) (push mvar res)))) finally return res))) - (type `(function ,(comp-args-to-lambda-list (comp-func-l-args func)) + (type `(function ,(comp--args-to-lambda-list (comp-func-l-args func)) ,(comp-cstr-to-type-spec res-mvar)))) (comp--add-const-to-relocs type) ;; Fix it up. (setf (comp-cstr-imm (comp-func-type func)) type)))) -(defun comp-finalize-container (cont) +(defun comp--compute-function-types (_) + "Compute and store the type specifier for all functions." + (maphash #'comp--compute-function-type (comp-ctxt-funcs-h comp-ctxt))) + + +;;; Final pass specific code. + +(defun comp--args-to-lambda-list (args) + "Return a lambda list for ARGS." + (cl-loop + with res + repeat (comp-args-base-min args) + do (push t res) + finally + (if (comp-args-p args) + (cl-loop + with n = (- (comp-args-max args) (comp-args-min args)) + initially (unless (zerop n) + (push '&optional res)) + repeat n + do (push t res)) + (cl-loop + with n = (- (comp-nargs-nonrest args) (comp-nargs-min args)) + initially (unless (zerop n) + (push '&optional res)) + repeat n + do (push t res) + finally (when (comp-nargs-rest args) + (push '&rest res) + (push 't res)))) + (cl-return (reverse res)))) + +(defun comp--finalize-container (cont) "Finalize data container CONT." (setf (comp-data-container-l cont) (cl-loop with h = (comp-data-container-idx cont) @@ -3065,7 +3154,7 @@ Set it into the `type' slot." 'lambda-fixup obj)))) -(defun comp-finalize-relocs () +(defun comp--finalize-relocs () "Finalize data containers for each relocation class. Remove immediate duplicates within relocation classes. Update all insn accordingly." @@ -3081,7 +3170,7 @@ Update all insn accordingly." (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt)) (d-ephemeral-idx (comp-data-container-idx d-ephemeral))) ;; We never want compiled lambdas ending up in pure space. A copy must - ;; be already present in impure (see `comp-emit-lambda-for-top-level'). + ;; be already present in impure (see `comp--emit-lambda-for-top-level'). (cl-loop for obj being each hash-keys of d-default-idx when (gethash obj (comp-ctxt-lambda-fixups-h comp-ctxt)) do (cl-assert (gethash obj d-impure-idx)) @@ -3097,7 +3186,7 @@ Update all insn accordingly." do (remhash obj d-ephemeral-idx)) ;; Fix-up indexes in each relocation class and fill corresponding ;; reloc lists. - (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral)) + (mapc #'comp--finalize-container (list d-default d-impure d-ephemeral)) ;; Make a vector from the function documentation hash table. (cl-loop with h = (comp-ctxt-function-docs comp-ctxt) with v = (make-vector (hash-table-count h) nil) @@ -3121,11 +3210,11 @@ Update all insn accordingly." (comp-mvar-range mvar) (list (cons idx idx))) (puthash idx t reverse-h)))) -(defun comp-compile-ctxt-to-file (name) +(defun comp--compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. Prepare every function for final compilation and drive the C back-end." (let ((dir (file-name-directory name))) - (comp-finalize-relocs) + (comp--finalize-relocs) (maphash (lambda (_ f) (comp--log-func f 1)) (comp-ctxt-funcs-h comp-ctxt)) @@ -3133,12 +3222,12 @@ Prepare every function for final compilation and drive the C back-end." ;; In case it's created in the meanwhile. (ignore-error file-already-exists (make-directory dir t))) - (comp--compile-ctxt-to-file name))) + (comp--compile-ctxt-to-file0 name))) -(defun comp-final1 () +(defun comp--final1 () (comp--init-ctxt) (unwind-protect - (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt)) + (comp--compile-ctxt-to-file (comp-ctxt-output comp-ctxt)) (comp--release-ctxt))) (defvar comp-async-compilation nil @@ -3147,17 +3236,16 @@ Prepare every function for final compilation and drive the C back-end." (defvar comp-running-batch-compilation nil "Non-nil when compilation is driven by any `batch-*-compile' function.") -(defun comp-final (_) +(defun comp--final (_) "Final pass driving the C back-end for code emission." - (maphash #'comp-compute-function-type (comp-ctxt-funcs-h comp-ctxt)) (unless comp-dry-run ;; Always run the C side of the compilation as a sub-process ;; unless during bootstrap or async compilation (bug#45056). GCC ;; leaks memory but also interfere with the ability of Emacs to ;; detect when a sub-process completes (TODO understand why). (if (or comp-running-batch-compilation comp-async-compilation) - (comp-final1) - ;; Call comp-final1 in a child process. + (comp--final1) + ;; Call comp--final1 in a child process. (let* ((output (comp-ctxt-output comp-ctxt)) (print-escape-newlines t) (print-length nil) @@ -3179,7 +3267,7 @@ Prepare every function for final compilation and drive the C back-end." load-path ',load-path) ,native-comp-async-env-modifier-form (message "Compiling %s..." ',output) - (comp-final1))) + (comp--final1))) (temp-file (make-temp-file (concat "emacs-int-comp-" (file-name-base output) "-") @@ -3223,7 +3311,7 @@ Prepare every function for final compilation and drive the C back-end." ;; Primitive function advice machinery -(defun comp-make-lambda-list-from-subr (subr) +(defun comp--make-lambda-list-from-subr (subr) "Given SUBR return the equivalent lambda-list." (pcase-let ((`(,min . ,max) (subr-arity subr)) (lambda-list '())) @@ -3267,7 +3355,7 @@ Prepare every function for final compilation and drive the C back-end." ;;;###autoload (defun comp-trampoline-compile (subr-name) "Synthesize compile and return a trampoline for SUBR-NAME." - (let* ((lambda-list (comp-make-lambda-list-from-subr + (let* ((lambda-list (comp--make-lambda-list-from-subr (symbol-function subr-name))) ;; The synthesized trampoline must expose the exact same ABI of ;; the primitive we are replacing in the function reloc table. @@ -3311,6 +3399,7 @@ filename (including FILE)." do (ignore-error file-error (comp-delete-or-replace-file f)))))) +;; In use by comp.c. (defun comp-delete-or-replace-file (oldfile &optional newfile) "Replace OLDFILE with NEWFILE. When NEWFILE is nil just delete OLDFILE. @@ -3399,16 +3488,18 @@ the deferred compilation mechanism." (if (and comp-async-compilation (not (eq (car err) 'native-compiler-error))) (progn - (message (if err-val - "%s: Error: %s %s" - "%s: Error %s") + (message "%s: Error %s" function-or-file - (get (car err) 'error-message) - (car-safe err-val)) + (error-message-string err)) (kill-emacs -1)) ;; Otherwise re-signal it adding the compilation input. + ;; FIXME: We can't just insert arbitrary info in the + ;; error-data part of an error: the handler may expect + ;; specific data at specific positions! (signal (car err) (if (consp err-val) (cons function-or-file err-val) + ;; FIXME: `err-val' is supposed to be + ;; a list, so it can only be nil here! (list function-or-file err-val))))))) (if (stringp function-or-file) data @@ -3492,7 +3583,8 @@ last directory in `native-comp-eln-load-path')." else collect (byte-compile-file file)))) -(defun comp-write-bytecode-file (eln-file) +;; In use by elisp-mode.el +(defun comp--write-bytecode-file (eln-file) "After native compilation write the bytecode file for ELN-FILE. Make sure that eln file is younger than byte-compiled one and return the filename of this last. @@ -3529,7 +3621,7 @@ variable \"NATIVE_DISABLED\" is set, only byte compile." (car (last native-comp-eln-load-path))) (byte-to-native-output-buffer-file nil) (eln-file (car (batch-native-compile)))) - (comp-write-bytecode-file eln-file) + (comp--write-bytecode-file eln-file) (setq command-line-args-left (cdr command-line-args-left))))) (defun native-compile-prune-cache () diff --git a/lisp/emacs-lisp/compat.el b/lisp/emacs-lisp/compat.el new file mode 100644 index 00000000000..f7037dc4101 --- /dev/null +++ b/lisp/emacs-lisp/compat.el @@ -0,0 +1,92 @@ +;;; compat.el --- Stub of the Compatibility Library -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2024 Free Software Foundation, Inc. + +;; Author: \ +;; Philip Kaludercic <philipk@posteo.net>, \ +;; Daniel Mendler <mail@daniel-mendler.de> +;; Maintainer: \ +;; Daniel Mendler <mail@daniel-mendler.de>, \ +;; Compat Development <~pkal/compat-devel@lists.sr.ht>, +;; emacs-devel@gnu.org +;; URL: https://github.com/emacs-compat/compat +;; Keywords: lisp, maint + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; The Compat package on ELPA provides forward-compatibility +;; definitions for other packages. While mostly transparent, a +;; minimal API is necessary whenever core definitions change calling +;; conventions (e.g. `plist-get' can be invoked with a predicate from +;; Emacs 29.1 onward). For core packages on ELPA to be able to take +;; advantage of this functionality, the macros `compat-function' and +;; `compat-call' have to be available in the core, usable even if +;; users do not have the Compat package installed, which this file +;; ensures. + +;; A basic introduction to Compat is given in the Info node `(elisp) +;; Forwards Compatibility'. Further details on Compat are documented +;; in the Info node `(compat) Top' (installed along with the Compat +;; package) or read the same manual online: +;; https://elpa.gnu.org/packages/doc/compat.html. + +;;; Code: + +(defmacro compat-function (fun) + "Return compatibility function symbol for FUN. +This is a pseudo-compatibility stub for core packages on ELPA, +that depend on the Compat package, whenever the user doesn't have +the package installed on their current system." + `#',fun) + +(defmacro compat-call (fun &rest args) + "Call compatibility function or macro FUN with ARGS. +This is a pseudo-compatibility stub for core packages on ELPA, +that depend on the Compat package, whenever the user doesn't have +the package installed on their current system." + (cons fun args)) + +;;;; Clever trick to avoid installing Compat if not necessary + +;; The versioning scheme of the Compat package follows that of Emacs, +;; to indicate the version of Emacs, that functionality is being +;; provided for. For example, the Compat version number 29.2.3.9 +;; would attempt to provide compatibility definitions up to Emacs +;; 29.2, while also designating that this is the third major release +;; and ninth minor release of Compat, for the specific Emacs release. + +;; The package version of this file is specified programmatically, +;; instead of giving a fixed version in the header of this file. This +;; is done to ensure that the version of compat.el provided by Emacs +;; always corresponds to the current version of Emacs. In addition to +;; the major-minor version, a large "major release" makes sure that +;; the built-in version of Compat is always preferred over an external +;; installation. This means that if a package specifies a dependency +;; on Compat which matches the current or an older version of Emacs +;; that is being used, no additional dependencies have to be +;; downloaded. +;; +;; Further details and background on this file can be found in the +;; bug#66554 discussion. + +;;;###autoload (push (list 'compat +;;;###autoload emacs-major-version +;;;###autoload emacs-minor-version +;;;###autoload 9999) +;;;###autoload package--builtin-versions) + +(provide 'compat) +;;; compat.el ends here diff --git a/lisp/emacs-lisp/debug-early.el b/lisp/emacs-lisp/debug-early.el index f2eb8792bfa..8a0dddc2679 100644 --- a/lisp/emacs-lisp/debug-early.el +++ b/lisp/emacs-lisp/debug-early.el @@ -27,14 +27,17 @@ ;; This file dumps a backtrace on stderr when an error is thrown. It ;; has no dependencies on any Lisp libraries and is thus used for ;; generating backtraces for bugs in the early parts of bootstrapping. -;; It is also always used in batch model. It was introduced in Emacs +;; It is also always used in batch mode. It was introduced in Emacs ;; 29, before which there was no backtrace available during early ;; bootstrap. ;;; Code: +;; For bootstrap reasons, we cannot use any macros here since they're +;; not defined yet. + (defalias 'debug-early-backtrace - #'(lambda () + #'(lambda (&optional base) "Print a trace of Lisp function calls currently active. The output stream used is the value of `standard-output'. @@ -51,26 +54,39 @@ of the build process." (require 'cl-print) (error nil))) #'cl-prin1 - #'prin1))) + #'prin1)) + (first t)) (mapbacktrace #'(lambda (evald func args _flags) - (let ((args args)) - (if evald + (if first + ;; The first is the debug-early entry point itself. + (setq first nil) + (let ((args args)) + (if evald + (progn + (princ " ") + (funcall prin1 func) + (princ "(")) (progn - (princ " ") - (funcall prin1 func) - (princ "(")) - (progn - (princ " (") - (setq args (cons func args)))) - (if args - (while (progn - (funcall prin1 (car args)) - (setq args (cdr args))) - (princ " "))) - (princ ")\n"))))))) - -(defalias 'debug-early + (princ " (") + (setq args (cons func args)))) + (if args + (while (progn + (funcall prin1 (car args)) + (setq args (cdr args))) + (princ " "))) + (princ ")\n")))) + base)))) + +(defalias 'debug--early + #'(lambda (error base) + (princ "\nError: ") + (prin1 (car error)) ; The error symbol. + (princ " ") + (prin1 (cdr error)) ; The error data. + (debug-early-backtrace base))) + +(defalias 'debug-early ;Called from C. #'(lambda (&rest args) "Print an error message with a backtrace of active Lisp function calls. The output stream used is the value of `standard-output'. @@ -88,10 +104,31 @@ support the latter, except in batch mode which always uses \(In versions of Emacs prior to Emacs 29, no backtrace was available before `debug' was usable.)" - (princ "\nError: ") - (prin1 (car (car (cdr args)))) ; The error symbol. - (princ " ") - (prin1 (cdr (car (cdr args)))) ; The error data. - (debug-early-backtrace))) + (debug--early (car (cdr args)) #'debug-early))) ; The error object. + +(defalias 'debug-early--handler ;Called from C. + #'(lambda (err) + (if backtrace-on-error-noninteractive + (debug--early err #'debug-early--handler)))) + +(defalias 'debug-early--muted ;Called from C. + #'(lambda (err) + (save-current-buffer + (set-buffer (get-buffer-create "*Redisplay-trace*")) + (goto-char (point-max)) + (if (bobp) nil + (let ((separator "\n\n\n\n")) + (save-excursion + ;; The C code tested `backtrace_yet', instead we + ;; keep a max of 10 backtraces. + (if (search-backward separator nil t 10) + (delete-region (point-min) (match-end 0)))) + (insert separator))) + (insert "-- Caught at " (current-time-string) "\n") + (let ((standard-output (current-buffer))) + (debug--early err #'debug-early--muted)) + (setq delayed-warnings-list + (cons '(error "Error in a redisplay Lisp hook. See buffer *Redisplay-trace*") + delayed-warnings-list))))) ;;; debug-early.el ends here. diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 506b73f6fa2..ec947c1215d 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -153,6 +153,12 @@ where CAUSE can be: (insert (debugger--buffer-state-content state))) (goto-char (debugger--buffer-state-pos state))) +(defvar debugger--last-error nil) + +(defun debugger--duplicate-p (args) + (pcase args + (`(error ,err . ,_) (and (consp err) (eq err debugger--last-error))))) + ;;;###autoload (setq debugger 'debug) ;;;###autoload @@ -175,9 +181,14 @@ first will be printed into the backtrace buffer. If `inhibit-redisplay' is non-nil when this function is called, the debugger will not be entered." (interactive) - (if inhibit-redisplay - ;; Don't really try to enter debugger within an eval from redisplay. + (if (or inhibit-redisplay + (debugger--duplicate-p args)) + ;; Don't really try to enter debugger within an eval from redisplay + ;; or if we already popper into the debugger for this error, + ;; which can happen when we have several nested `handler-bind's that + ;; want to invoke the debugger. debugger-value + (setq debugger--last-error nil) (let ((non-interactive-frame (or noninteractive ;FIXME: Presumably redundant. ;; If we're in the initial-frame (where `message' just @@ -200,7 +211,7 @@ the debugger will not be entered." (let (debugger-value (debugger-previous-state (if (get-buffer "*Backtrace*") - (with-current-buffer (get-buffer "*Backtrace*") + (with-current-buffer "*Backtrace*" (debugger--save-buffer-state)))) (debugger-args args) (debugger-buffer (get-buffer-create "*Backtrace*")) @@ -318,6 +329,12 @@ the debugger will not be entered." (backtrace-mode)))) (with-timeout-unsuspend debugger-with-timeout-suspend) (set-match-data debugger-outer-match-data))) + (when (eq 'error (car-safe debugger-args)) + ;; Remember the error we just debugged, to avoid re-entering + ;; the debugger if some higher-up `handler-bind' invokes us + ;; again, oblivious that the error was already debugged from + ;; a more deeply nested `handler-bind'. + (setq debugger--last-error (nth 1 debugger-args))) (setq debug-on-next-call debugger-step-after-exit) debugger-value)))) @@ -651,7 +668,7 @@ Complete list of commands: (princ (debugger-eval-expression exp)) (terpri)) - (with-current-buffer (get-buffer debugger-record-buffer) + (with-current-buffer debugger-record-buffer (message "%s" (buffer-substring (line-beginning-position 0) (line-end-position 0))))) diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 5c224362708..2423426dca0 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -211,10 +211,10 @@ See Info node `(elisp)Derived Modes' for more details. (defvar ,hook nil) (unless (get ',hook 'variable-documentation) (put ',hook 'variable-documentation - ,(format "Hook run after entering %s mode. + ,(format "Hook run after entering `%S'. No problems result if this variable is not bound. `add-hook' automatically binds it. (This is true for all hook variables.)" - name))) + child))) (unless (boundp ',map) (put ',map 'definition-name ',child)) (with-no-warnings (defvar ,map (make-sparse-keymap))) @@ -365,137 +365,6 @@ which more-or-less shadow%s %s's corresponding table%s." docstring)) -;;; OBSOLETE -;; The functions below are only provided for backward compatibility with -;; code byte-compiled with versions of derived.el prior to Emacs-21. - -(defsubst derived-mode-setup-function-name (mode) - "Construct a setup-function name based on a MODE name." - (declare (obsolete nil "28.1")) - (intern (concat (symbol-name mode) "-setup"))) - - -;; Utility functions for defining a derived mode. - -;;;###autoload -(defun derived-mode-init-mode-variables (mode) - "Initialize variables for a new MODE. -Right now, if they don't already exist, set up a blank keymap, an -empty syntax table, and an empty abbrev table -- these will be merged -the first time the mode is used." - - (if (boundp (derived-mode-map-name mode)) - t - (eval `(defvar ,(derived-mode-map-name mode) - (make-sparse-keymap) - ,(format "Keymap for %s." mode))) - (put (derived-mode-map-name mode) 'derived-mode-unmerged t)) - - (if (boundp (derived-mode-syntax-table-name mode)) - t - (eval `(defvar ,(derived-mode-syntax-table-name mode) - ;; Make a syntax table which doesn't specify anything - ;; for any char. Valid data will be merged in by - ;; derived-mode-merge-syntax-tables. - (make-char-table 'syntax-table nil) - ,(format "Syntax table for %s." mode))) - (put (derived-mode-syntax-table-name mode) 'derived-mode-unmerged t)) - - (if (boundp (derived-mode-abbrev-table-name mode)) - t - (eval `(defvar ,(derived-mode-abbrev-table-name mode) - (progn - (define-abbrev-table (derived-mode-abbrev-table-name ',mode) nil) - (make-abbrev-table)) - ,(format "Abbrev table for %s." mode))))) - -;; Utility functions for running a derived mode. - -(defun derived-mode-set-keymap (mode) - "Set the keymap of the new MODE, maybe merging with the parent." - (let* ((map-name (derived-mode-map-name mode)) - (new-map (eval map-name)) - (old-map (current-local-map))) - (and old-map - (get map-name 'derived-mode-unmerged) - (derived-mode-merge-keymaps old-map new-map)) - (put map-name 'derived-mode-unmerged nil) - (use-local-map new-map))) - -(defun derived-mode-set-syntax-table (mode) - "Set the syntax table of the new MODE, maybe merging with the parent." - (let* ((table-name (derived-mode-syntax-table-name mode)) - (old-table (syntax-table)) - (new-table (eval table-name))) - (if (get table-name 'derived-mode-unmerged) - (derived-mode-merge-syntax-tables old-table new-table)) - (put table-name 'derived-mode-unmerged nil) - (set-syntax-table new-table))) - -(defun derived-mode-set-abbrev-table (mode) - "Set the abbrev table for MODE if it exists. -Always merge its parent into it, since the merge is non-destructive." - (let* ((table-name (derived-mode-abbrev-table-name mode)) - (old-table local-abbrev-table) - (new-table (eval table-name))) - (derived-mode-merge-abbrev-tables old-table new-table) - (setq local-abbrev-table new-table))) - -(defun derived-mode-run-hooks (mode) - "Run the mode hook for MODE." - (let ((hooks-name (derived-mode-hook-name mode))) - (if (boundp hooks-name) - (run-hooks hooks-name)))) - -;; Functions to merge maps and tables. - -(defun derived-mode-merge-keymaps (old new) - "Merge an OLD keymap into a NEW one. -The old keymap is set to be the last cdr of the new one, so that there will -be automatic inheritance." - ;; ?? Can this just use `set-keymap-parent'? - (let ((tail new)) - ;; Scan the NEW map for prefix keys. - (while (consp tail) - (and (consp (car tail)) - (let* ((key (vector (car (car tail)))) - (subnew (lookup-key new key)) - (subold (lookup-key old key))) - ;; If KEY is a prefix key in both OLD and NEW, merge them. - (and (keymapp subnew) (keymapp subold) - (derived-mode-merge-keymaps subold subnew)))) - (and (vectorp (car tail)) - ;; Search a vector of ASCII char bindings for prefix keys. - (let ((i (1- (length (car tail))))) - (while (>= i 0) - (let* ((key (vector i)) - (subnew (lookup-key new key)) - (subold (lookup-key old key))) - ;; If KEY is a prefix key in both OLD and NEW, merge them. - (and (keymapp subnew) (keymapp subold) - (derived-mode-merge-keymaps subold subnew))) - (setq i (1- i))))) - (setq tail (cdr tail)))) - (setcdr (nthcdr (1- (length new)) new) old)) - -(defun derived-mode-merge-syntax-tables (old new) - "Merge an OLD syntax table into a NEW one. -Where the new table already has an entry, nothing is copied from the old one." - (set-char-table-parent new old)) - -;; Merge an old abbrev table into a new one. -;; This function requires internal knowledge of how abbrev tables work, -;; presuming that they are obarrays with the abbrev as the symbol, the expansion -;; as the value of the symbol, and the hook as the function definition. -(defun derived-mode-merge-abbrev-tables (old new) - (if old - (mapatoms - (lambda (symbol) - (or (intern-soft (symbol-name symbol) new) - (define-abbrev new (symbol-name symbol) - (symbol-value symbol) (symbol-function symbol)))) - old))) - (provide 'derived) ;;; derived.el ends here diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index a876e6b5744..850cc2085f7 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -54,7 +54,7 @@ (defun disassemble (object &optional buffer indent interactive-p) "Print disassembled code for OBJECT in (optional) BUFFER. OBJECT can be a symbol defined as a function, or a function itself -\(a lambda expression or a compiled-function object). +\(a lambda expression or a byte-code-function object). If OBJECT is not already compiled, we compile it, but do not redefine OBJECT if it is a symbol." (interactive @@ -70,7 +70,7 @@ redefine OBJECT if it is a symbol." (save-excursion (if (or interactive-p (null buffer)) (with-output-to-temp-buffer "*Disassemble*" - (set-buffer "*Disassemble*") + (set-buffer standard-output) (let ((lexical-binding lb)) (disassemble-internal object indent (not interactive-p)))) (set-buffer buffer) @@ -191,8 +191,6 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (if (consp obj) (setq bytes (car (cdr obj)) ;the byte code constvec (car (cdr (cdr obj)))) ;constant vector - ;; If it is lazy-loaded, load it now - (fetch-bytecode obj) (setq bytes (aref obj 1) constvec (aref obj 2))) (cl-assert (not (multibyte-string-p bytes))) @@ -252,29 +250,22 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." ;; if the succeeding op is byte-switch, display the jump table ;; used (cond ((eq (car-safe (car-safe (cdr lap))) 'byte-switch) - (insert (format "<jump-table-%s (" (hash-table-test arg))) - (let ((first-time t)) - (maphash #'(lambda (value tag) - (if first-time - (setq first-time nil) - (insert " ")) - (insert (format "%s %s" value (cadr tag)))) - arg)) - (insert ")>")) - ;; if the value of the constant is compiled code, then - ;; recursively disassemble it. - ((or (byte-code-function-p arg) - (and (consp arg) (functionp arg) - (assq 'byte-code arg)) + (insert (format "<jump-table-%s (" (hash-table-test arg))) + (let ((first-time t)) + (maphash #'(lambda (value tag) + (if first-time + (setq first-time nil) + (insert " ")) + (insert (format "%s %s" value (cadr tag)))) + arg)) + (insert ")>")) + ;; if the value of the constant is compiled code, then + ;; recursively disassemble it. + ((or (byte-code-function-p arg) (and (eq (car-safe arg) 'macro) - (or (byte-code-function-p (cdr arg)) - (and (consp (cdr arg)) - (functionp (cdr arg)) - (assq 'byte-code (cdr arg)))))) + (byte-code-function-p (cdr arg)))) (cond ((byte-code-function-p arg) (insert "<compiled-function>\n")) - ((functionp arg) - (insert "<compiled lambda>")) (t (insert "<compiled macro>\n"))) (disassemble-internal arg @@ -287,7 +278,7 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (+ indent disassemble-recursive-indent))) ((eq (car-safe (car-safe arg)) 'byte-code) (insert "(<byte code>...)\n") - (mapc ;recurse on list of byte-code objects + (mapc ;Recurse on list of byte-code objects. (lambda (obj) (disassemble-1 obj diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 05b23a86fc0..4fa05008dd8 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -132,7 +132,7 @@ it is disabled.") (string-replace "'" "\\='" (format "%S" getter))))) (let ((start (point))) (insert argdoc) - (when (fboundp 'fill-region) + (when (fboundp 'fill-region) ;Don't break bootstrap! (fill-region start (point) 'left t)))) ;; Finally, insert the keymap. (when (and (boundp keymap-sym) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index a8a51502503..b27ffbca908 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -193,11 +193,15 @@ Use this with caution since it is not debugged." (defcustom edebug-print-length 50 - "If non-nil, default value of `print-length' for printing results in Edebug." - :type '(choice integer (const nil))) + "Maximum length of list to print before abbreviating, when in Edebug. +If this is nil, use the value of `print-length' instead." + :type '(choice (integer :tag "A number") + (const :tag "Use `print-length'" nil))) (defcustom edebug-print-level 50 - "If non-nil, default value of `print-level' for printing results in Edebug." - :type '(choice integer (const nil))) + "Maximum depth of list nesting to print before abbreviating, when in Edebug. +If nil, use the value of `print-level' instead." + :type '(choice (integer :tag "A number") + (const :tag "Use `print-level'" nil))) (defcustom edebug-print-circle t "If non-nil, default value of `print-circle' for printing results in Edebug." :type 'boolean) @@ -481,7 +485,7 @@ just FUNCTION is printed." (edebug--eval-defun #'eval-defun edebug-it))) ;;;###autoload -(defalias 'edebug-defun 'edebug-eval-top-level-form) +(defalias 'edebug-defun #'edebug-eval-top-level-form) ;;;###autoload (defun edebug-eval-top-level-form () @@ -1225,10 +1229,12 @@ purpose by adding an entry to this alist, and setting ;; But the list will just be reversed. ,@(nreverse edebug-def-args)) 'nil) - ;; 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))))) + #'(lambda () + ;; Mark the closure so we don't throw away unused vars (bug#59213). + :closure-dont-trim-context + ;; Make sure `forms' is not nil so we don't accidentally return + ;; the magic keyword. + ,@(or forms '(nil))))) (defvar edebug-form-begin-marker) ; the mark for def being instrumented @@ -1266,55 +1272,48 @@ Does not unwrap inside vectors, records, structures, or hash tables." (pcase sexp (`(edebug-after ,_before-form ,_after-index ,form) form) - (`(lambda ,args (edebug-enter ',_sym ,_arglist - (function (lambda nil . ,body)))) - `(lambda ,args ,@body)) - (`(closure ,env ,args (edebug-enter ',_sym ,_arglist - (function (lambda nil . ,body)))) - `(closure ,env ,args ,@body)) - (`(edebug-enter ',_sym ,_args (function (lambda nil . ,body))) + (`(edebug-enter ',_sym ,_args + #'(lambda nil :closure-dont-trim-context . ,body)) (macroexp-progn body)) (_ sexp))) +(defconst edebug--unwrap-cache + (make-hash-table :test 'eq :weakness 'key) + "Hash-table containing the results of unwrapping cons cells. +These results are reused to avoid redundant work but also to avoid +infinite loops when the code/environment contains a circular object.") + (defun edebug-unwrap* (sexp) "Return the SEXP recursively unwrapped." - (let ((ht (make-hash-table :test 'eq))) - (edebug--unwrap1 sexp ht))) - -(defun edebug--unwrap1 (sexp hash-table) - "Unwrap SEXP using HASH-TABLE of things already unwrapped. -HASH-TABLE contains the results of unwrapping cons cells within -SEXP, which are reused to avoid infinite loops when SEXP is or -contains a circular object." - (let ((new-sexp (edebug-unwrap sexp))) - (while (not (eq sexp new-sexp)) - (setq sexp new-sexp - new-sexp (edebug-unwrap sexp))) - (if (consp new-sexp) - (let ((result (gethash new-sexp hash-table nil))) - (unless result - (let ((remainder new-sexp) - current) - (setq result (cons nil nil) - current result) - (while - (progn - (puthash remainder current hash-table) - (setf (car current) - (edebug--unwrap1 (car remainder) hash-table)) - (setq remainder (cdr remainder)) - (cond - ((atom remainder) - (setf (cdr current) - (edebug--unwrap1 remainder hash-table)) - nil) - ((gethash remainder hash-table nil) - (setf (cdr current) (gethash remainder hash-table nil)) - nil) - (t (setq current - (setf (cdr current) (cons nil nil))))))))) - result) - new-sexp))) + (while (not (eq sexp (setq sexp (edebug-unwrap sexp))))) + (cond + ((consp sexp) + (or (gethash sexp edebug--unwrap-cache nil) + (let ((remainder sexp) + (current (cons nil nil))) + (prog1 current + (while + (progn + (puthash remainder current edebug--unwrap-cache) + (setf (car current) + (edebug-unwrap* (car remainder))) + (setq remainder (cdr remainder)) + (cond + ((atom remainder) + (setf (cdr current) + (edebug-unwrap* remainder)) + nil) + ((gethash remainder edebug--unwrap-cache nil) + (setf (cdr current) (gethash remainder edebug--unwrap-cache nil)) + nil) + (t (setq current + (setf (cdr current) (cons nil nil))))))))))) + ((byte-code-function-p sexp) + (apply #'make-byte-code + (aref sexp 0) (aref sexp 1) + (vconcat (mapcar #'edebug-unwrap* (aref sexp 2))) + (nthcdr 3 (append sexp ())))) + (t sexp))) (defun edebug-defining-form (cursor form-begin form-end speclist) @@ -1729,7 +1728,7 @@ contains a circular object." (defun edebug-match-form (cursor) (list (edebug-form cursor))) -(defalias 'edebug-match-place 'edebug-match-form) +(defalias 'edebug-match-place #'edebug-match-form) ;; Currently identical to edebug-match-form. ;; This is for common lisp setf-style place arguments. @@ -2277,12 +2276,7 @@ only be active while Edebug is. It checks `debug-on-error' to see whether it should call the debugger. When execution is resumed, the error is signaled again." (if (and (listp debug-on-error) (memq signal-name debug-on-error)) - (edebug 'error (cons signal-name signal-data))) - ;; If we reach here without another non-local exit, then send signal again. - ;; i.e. the signal is not continuable, yet. - ;; Avoid infinite recursion. - (let ((signal-hook-function nil)) - (signal signal-name signal-data))) + (edebug 'error (cons signal-name signal-data)))) ;;; Entering Edebug @@ -2326,6 +2320,12 @@ and run its entry function, and set up `edebug-before' and (debug-on-error (or debug-on-error edebug-on-error)) (debug-on-quit edebug-on-quit)) (unwind-protect + ;; FIXME: We could replace this `signal-hook-function' with + ;; a cleaner `handler-bind' but then we wouldn't be able to + ;; install it here (i.e. once and for all when entering + ;; an Edebugged function), but instead it would have to + ;; be installed into a modified `edebug-after' which wraps + ;; the `handler-bind' around its argument(s). :-( (let ((signal-hook-function #'edebug-signal)) (setq edebug-execution-mode (or edebug-next-execution-mode edebug-initial-mode @@ -3348,7 +3348,7 @@ With prefix argument, make it a temporary breakpoint." (message "%s" msg))) -(defalias 'edebug-step-through-mode 'edebug-step-mode) +(defalias 'edebug-step-through-mode #'edebug-step-mode) (defun edebug-step-mode () "Proceed to next stop point." @@ -3836,12 +3836,12 @@ be installed in `emacs-lisp-mode-map'.") ;; Global GUD bindings for all emacs-lisp-mode buffers. (unless edebug-inhibit-emacs-lisp-mode-bindings - (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode) - (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode) - (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode) - (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" #'edebug-step-mode) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" #'edebug-next-mode) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" #'edebug-go-mode) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" #'edebug-where) ;; The following isn't a GUD binding. - (define-key emacs-lisp-mode-map "\C-x\C-a\C-m" 'edebug-set-initial-mode)) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-m" #'edebug-set-initial-mode)) (defvar-keymap edebug-mode-map :parent emacs-lisp-mode-map @@ -4234,13 +4234,13 @@ Remove frames for Edebug's functions and the lambdas in and after-index fields in both FRAMES and the returned list of deinstrumented frames, for those frames where the source code location is known." - (let (skip-next-lambda def-name before-index after-index results - (index (length frames))) + (let ((index (length frames)) + skip-next-lambda def-name before-index after-index results) (dolist (frame (reverse frames)) (let ((new-frame (copy-edebug--frame frame)) (fun (edebug--frame-fun frame)) (args (edebug--frame-args frame))) - (cl-decf index) + (cl-decf index) ;; FIXME: Not used? (pcase fun ('edebug-enter (setq skip-next-lambda t @@ -4250,38 +4250,46 @@ code location is known." (nth 1 (nth 0 args)) (nth 0 args)) after-index (nth 1 args))) - ((pred edebug--symbol-not-prefixed-p) - (edebug--unwrap-frame new-frame) - (edebug--add-source-info new-frame def-name before-index after-index) - (edebug--add-source-info frame def-name before-index after-index) - (push new-frame results) - (setq before-index nil - after-index nil)) - (`(,(or 'lambda 'closure) . ,_) + ;; Just skip all our own frames. + ((pred edebug--symbol-prefixed-p) nil) + (_ + (when (and skip-next-lambda + (not (memq (car-safe fun) '(closure lambda)))) + (warn "Edebug--strip-instrumentation expected an interpreted function:\n%S" fun)) (unless skip-next-lambda (edebug--unwrap-frame new-frame) - (edebug--add-source-info frame def-name before-index after-index) (edebug--add-source-info new-frame def-name before-index after-index) + (edebug--add-source-info frame def-name before-index after-index) (push new-frame results)) - (setq before-index nil + (setq before-index nil after-index nil skip-next-lambda nil))))) results)) -(defun edebug--symbol-not-prefixed-p (sym) - "Return non-nil if SYM is a symbol not prefixed by \"edebug-\"." +(defun edebug--symbol-prefixed-p (sym) + "Return non-nil if SYM is a symbol prefixed by \"edebug-\"." (and (symbolp sym) - (not (string-prefix-p "edebug-" (symbol-name sym))))) + (string-prefix-p "edebug-" (symbol-name sym)))) (defun edebug--unwrap-frame (frame) "Remove Edebug's instrumentation from FRAME. Strip it from the function and any unevaluated arguments." - (setf (edebug--frame-fun frame) (edebug-unwrap* (edebug--frame-fun frame))) - (unless (edebug--frame-evald frame) - (let (results) - (dolist (arg (edebug--frame-args frame)) - (push (edebug-unwrap* arg) results)) - (setf (edebug--frame-args frame) (nreverse results))))) + (cl-callf edebug-unwrap* (edebug--frame-fun frame)) + ;; We used to try to be careful to apply `edebug-unwrap' only to source + ;; expressions and not to values, so we did not apply unwrap to the arguments + ;; of the frame if they had already been evaluated. + ;; But this was not careful enough since `edebug-unwrap*' gleefully traverses + ;; its argument without paying attention to its syntactic structure so it + ;; also "mistakenly" descends into the values contained within the "source + ;; code". In practice this *very* rarely leads to undesired results. + ;; On the contrary, it's often useful to descend into values because they + ;; may contain interpreted closures and hence source code where we *do* + ;; want to apply `edebug-unwrap'. + ;; So based on this experience, we now also apply `edebug-unwrap*' to + ;; the already evaluated arguments. + ;;(unless (edebug--frame-evald frame) + (cl-callf (lambda (xs) (mapcar #'edebug-unwrap* xs)) + (edebug--frame-args frame))) (defun edebug--add-source-info (frame def-name before-index after-index) "Update FRAME with the additional info needed by an edebug--frame. diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 9c526f67204..cf8bd749f2a 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -191,7 +191,7 @@ Abstract classes cannot be instantiated." ;; We autoload this because it's used in `make-autoload'. ;;;###autoload -(defun eieio-defclass-autoload (cname _superclasses filename doc) +(defun eieio-defclass-autoload (cname superclasses filename doc) "Create autoload symbols for the EIEIO class CNAME. SUPERCLASSES are the superclasses that CNAME inherits from. DOC is the docstring for CNAME. @@ -199,15 +199,9 @@ This function creates a mock-class for CNAME and adds it into SUPERCLASSES as children. It creates an autoload function for CNAME's constructor." ;; Assume we've already debugged inputs. - - ;; We used to store the list of superclasses in the `parent' slot (as a list - ;; of class names). But now this slot holds a list of class objects, and - ;; those parents may not exist yet, so the corresponding class objects may - ;; simply not exist yet. So instead we just don't store the list of parents - ;; here in eieio-defclass-autoload at all, since it seems that they're just - ;; not needed before the class is actually loaded. (let* ((oldc (cl--find-class cname)) - (newc (eieio--class-make cname))) + (newc (eieio--class-make cname)) + (parents (mapcar #'cl-find-class superclasses))) (if (eieio--class-p oldc) nil ;; Do nothing if we already have this class. @@ -218,6 +212,12 @@ It creates an autoload function for CNAME's constructor." use '%s or turn off `eieio-backward-compatibility' instead" cname) "25.1")) + (when (memq nil parents) + ;; If some parents aren't yet fully defined, just ignore them for now. + (setq parents (delq nil parents))) + (unless parents + (setq parents (list (cl--find-class 'eieio-default-superclass)))) + (setf (cl--class-parents newc) parents) (setf (cl--find-class cname) newc) ;; Create an autoload on top of our constructor function. @@ -293,8 +293,7 @@ See `defclass' for more information." ;; reloading the file that does the `defclass', we don't ;; want to create a new class object. (eieio--class-make cname))) - (groups nil) ;; list of groups id'd from slots - (clearparent nil)) + (groups nil)) ;; list of groups id'd from slots ;; If this class already existed, and we are updating its structure, ;; make sure we keep the old child list. This can cause bugs, but @@ -317,6 +316,9 @@ See `defclass' for more information." (setf (eieio--class-children newc) children) (remhash cname eieio-defclass-autoload-map)))) + (unless (or superclasses (eq cname 'eieio-default-superclass)) + (setq superclasses '(eieio-default-superclass))) + (if superclasses (progn (dolist (p superclasses) @@ -336,16 +338,13 @@ See `defclass' for more information." (push c (eieio--class-parents newc)))))) ;; Reverse the list of our parents so that they are prioritized in ;; the same order as specified in the code. - (cl-callf nreverse (eieio--class-parents newc))) - ;; If there is nothing to loop over, then inherit from the - ;; default superclass. - (unless (eq cname 'eieio-default-superclass) - ;; adopt the default parent here, but clear it later... - (setq clearparent t) - ;; save new child in parent - (cl-pushnew cname (eieio--class-children eieio-default-superclass)) - ;; save parent in child - (setf (eieio--class-parents newc) (list eieio-default-superclass)))) + (cl-callf nreverse (eieio--class-parents newc)) + ;; Before adding new slots, let's add all the methods and classes + ;; in from the parent class. + (eieio-copy-parents-into-subclass newc)) + + (cl-assert (eq cname 'eieio-default-superclass)) + (setf (eieio--class-parents newc) (list (cl--find-class 'record)))) ;; turn this into a usable self-pointing symbol; FIXME: Why? (when eieio-backward-compatibility @@ -376,10 +375,6 @@ See `defclass' for more information." cname) "25.1"))) - ;; Before adding new slots, let's add all the methods and classes - ;; in from the parent class. - (eieio-copy-parents-into-subclass newc) - ;; Store the new class vector definition into the symbol. We need to ;; do this first so that we can call defmethod for the accessor. ;; The vector will be updated by the following while loop and will not @@ -512,10 +507,6 @@ See `defclass' for more information." ;; Set up the options we have collected. (setf (eieio--class-options newc) options) - ;; if this is a superclass, clear out parent (which was set to the - ;; default superclass eieio-default-superclass) - (if clearparent (setf (eieio--class-parents newc) nil)) - ;; Create the cached default object. (let ((cache (make-record newc (+ (length (eieio--class-slots newc)) @@ -967,19 +958,13 @@ need be... May remove that later...)" (cdr tuple) nil))) -(defsubst eieio--class/struct-parents (class) - (or (eieio--class-parents class) - `(,eieio-default-superclass))) - (defun eieio--class-precedence-c3 (class) "Return all parents of CLASS in c3 order." - (let ((parents (eieio--class-parents class))) + (let ((parents (cl--class-parents class))) (cons class (merge-ordered-lists (append - (or - (mapcar #'eieio--class-precedence-c3 parents) - `((,eieio-default-superclass))) + (mapcar #'eieio--class-precedence-c3 parents) (list parents)) (lambda (remaining-inputs) (signal 'inconsistent-class-hierarchy @@ -989,17 +974,15 @@ need be... May remove that later...)" (defun eieio--class-precedence-dfs (class) "Return all parents of CLASS in depth-first order." - (let* ((parents (eieio--class-parents class)) + (let* ((parents (cl--class-parents class)) (classes (copy-sequence (apply #'append (list class) - (or - (mapcar - (lambda (parent) - (cons parent - (eieio--class-precedence-dfs parent))) - parents) - `((,eieio-default-superclass)))))) + (mapcar + (lambda (parent) + (cons parent + (eieio--class-precedence-dfs parent))) + parents)))) (tail classes)) ;; Remove duplicates. (while tail @@ -1012,13 +995,12 @@ need be... May remove that later...)" (defun eieio--class-precedence-bfs (class) "Return all parents of CLASS in breadth-first order." (let* ((result) - (queue (eieio--class/struct-parents class))) + (queue (cl--class-parents class))) (while queue (let ((head (pop queue))) (unless (member head result) (push head result) - (unless (eq head eieio-default-superclass) - (setq queue (append queue (eieio--class/struct-parents head))))))) + (setq queue (append queue (cl--class-parents head)))))) (cons class (nreverse result))) ) @@ -1058,6 +1040,14 @@ method invocation orders of the involved classes." ;;;; General support to dispatch based on the type of the argument. +;; FIXME: We could almost use the typeof-generalizer (i.e. the same as +;; used for cl-structs), except that that generalizer doesn't support +;; `:method-invocation-order' :-( + +(defun cl--generic-struct-tag (name &rest _) + ;; Use exactly the same code as for `typeof'. + `(cl-type-of ,name)) + (cl-generic-define-generalizer eieio--generic-generalizer ;; Use the exact same tagcode as for cl-struct, so that methods ;; that dispatch on both kinds of objects get to share this @@ -1066,8 +1056,7 @@ method invocation orders of the involved classes." (lambda (tag &rest _) (let ((class (cl--find-class tag))) (and (eieio--class-p class) - (mapcar #'eieio--class-name - (eieio--class-precedence-list class)))))) + (cl--class-allparents class))))) (cl-defmethod cl-generic-generalizers :extra "class" (specializer) "Support for dispatch on types defined by EIEIO's `defclass'." @@ -1089,10 +1078,11 @@ method invocation orders of the involved classes." ;; Instead, we add a new "subclass" specializer. (defun eieio--generic-subclass-specializers (tag &rest _) - (when (eieio--class-p tag) - (mapcar (lambda (class) - `(subclass ,(eieio--class-name class))) - (eieio--class-precedence-list tag)))) + (when (cl--class-p tag) + (when (eieio--class-p tag) + (setq tag (eieio--full-class-object tag))) ;Autoload, if applicable. + (mapcar (lambda (class) `(subclass ,class)) + (cl--class-allparents tag)))) (cl-generic-define-generalizer eieio--generic-subclass-generalizer 60 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name))) diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 893f8cd7e7f..bf6be1690e4 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -50,7 +50,7 @@ variable `eieio-default-superclass'." (if (not root-class) (setq root-class 'eieio-default-superclass)) (cl-check-type root-class class) (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t) - (with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*") + (with-current-buffer "*EIEIO OBJECT BROWSE*" (erase-buffer) (goto-char 0) (eieio-browse-tree root-class "" "") diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index df85a64baf3..74f5e21db7d 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -387,9 +387,9 @@ contents of field NAME is matched against PAT, or they can be of ,@(mapcar (lambda (field) (pcase-exhaustive field (`(,name ,pat) - `(app (pcase--flip eieio-oref ',name) ,pat)) + `(app (eieio-oref _ ',name) ,pat)) ((pred symbolp) - `(app (pcase--flip eieio-oref ',field) ,field)))) + `(app (eieio-oref _ ',field) ,field)))) fields))) ;;; Simple generators, and query functions. None of these would do @@ -449,7 +449,12 @@ If EXTRA, include that in the string returned to represent the symbol." (defun eieio-class-parents (class) ;; FIXME: What does "(overload of variable)" mean here? "Return parent classes to CLASS. (overload of variable)." - (eieio--class-parents (eieio--full-class-object class))) + ;; (declare (obsolete cl--class-parents "30.1")) + (let ((parents (eieio--class-parents (eieio--full-class-object class)))) + (if (and (null (cdr parents)) + (eq (car parents) (cl--find-class 'eieio-default-superclass))) + nil + parents))) (define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") @@ -497,7 +502,7 @@ If EXTRA, include that in the string returned to represent the symbol." (setq class (eieio--class-object class)) (cl-check-type class eieio--class) (while (and child (not (eq child class))) - (setq p (append p (eieio--class-parents child)) + (setq p (append p (cl--class-parents child)) child (pop p))) (if child t)))) @@ -680,8 +685,7 @@ If SLOT is unbound, do nothing." (defclass eieio-default-superclass nil nil "Default parent class for classes with no specified parent class. -Its slots are automatically adopted by classes with no specified parents. -This class is not stored in the `parent' slot of a class vector." +Its slots are automatically adopted by classes with no specified parents." :abstract t) (setq eieio-default-superclass (cl--find-class 'eieio-default-superclass)) diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 06970d40e8a..24afd03fbe6 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -155,7 +155,7 @@ Remember to keep it a prime number to improve hash performance.") (defvar eldoc-message-commands ;; Don't define as `defconst' since it would then go to (read-only) purespace. - (make-vector eldoc-message-commands-table-size 0) + (obarray-make eldoc-message-commands-table-size) "Commands after which it is appropriate to print in the echo area. ElDoc does not try to print function arglists, etc., after just any command, because some commands print their own messages in the echo area and these @@ -191,7 +191,7 @@ It should receive the same arguments as `message'.") When `eldoc-print-after-edit' is non-nil, ElDoc messages are only printed after commands contained in this obarray." - (let ((cmds (make-vector 31 0)) + (let ((cmds (obarray-make 31)) (re (regexp-opt '("delete" "insert" "edit" "electric" "newline")))) (mapatoms (lambda (s) (and (commandp s) @@ -312,9 +312,11 @@ Otherwise, it displays the message like `message' would." (not (and (listp mode-line-format) (assq 'eldoc-mode-line-string mode-line-format)))) (setq mode-line-format - (list "" '(eldoc-mode-line-string - (" " eldoc-mode-line-string " ")) - mode-line-format))) + (funcall + (if (listp mode-line-format) #'append #'list) + (list "" '(eldoc-mode-line-string + (" " eldoc-mode-line-string " "))) + mode-line-format))) (setq eldoc-mode-line-string (when (stringp format-string) (apply #'format-message format-string args))) diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index a8bc4bdd1e0..27c169cc657 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -266,6 +266,7 @@ This environment can be passed to `macroexpand'." (insert-file-contents file) (let ((buffer-file-name file) (max-lisp-eval-depth (max 1000 max-lisp-eval-depth))) + (hack-local-variables) (with-syntax-table emacs-lisp-mode-syntax-table (mapc 'elint-top-form (elint-update-env))))) (elint-set-mode-line) diff --git a/lisp/emacs-lisp/ert-font-lock.el b/lisp/emacs-lisp/ert-font-lock.el index 29114712f92..e77c8945dc3 100644 --- a/lisp/emacs-lisp/ert-font-lock.el +++ b/lisp/emacs-lisp/ert-font-lock.el @@ -39,16 +39,33 @@ (require 'newcomment) (require 'pcase) -(defconst ert-font-lock--assertion-re +(defconst ert-font-lock--face-symbol-re + (rx (one-or-more (or alphanumeric "-" "_" "."))) + "A face symbol matching regex.") + +(defconst ert-font-lock--face-symbol-list-re + (rx "(" + (* whitespace) + (one-or-more + (seq (regexp ert-font-lock--face-symbol-re) + (* whitespace))) + ")") + "A face symbol list matching regex.") + +(defconst ert-font-lock--assertion-line-re (rx - ;; column specifiers + ;; leading column assertion (arrow/caret) (group (or "^" "<-")) - (one-or-more " ") + (zero-or-more whitespace) + ;; possible to have many carets on an assertion line + (group (zero-or-more (seq "^" (zero-or-more whitespace)))) ;; optional negation of the face specification (group (optional "!")) - ;; face symbol name - (group (one-or-more (or alphanumeric "-" "_" ".")))) - "An ert-font-lock assertion regex.") + (zero-or-more whitespace) + ;; face symbol name or a list of symbols + (group (or (regexp ert-font-lock--face-symbol-re) + (regexp ert-font-lock--face-symbol-list-re)))) + "An ert-font-lock assertion line regex.") (defun ert-font-lock--validate-major-mode (mode) "Validate if MODE is a valid major mode." @@ -212,7 +229,7 @@ be used through `ert'. (save-excursion (beginning-of-line) (skip-syntax-forward " ") - (re-search-forward ert-font-lock--assertion-re + (re-search-forward ert-font-lock--assertion-line-re (line-end-position) t 1))) (defun ert-font-lock--goto-first-char () @@ -252,8 +269,8 @@ be used through `ert'. (throw 'nextline t)) - ;; Collect the assertion - (when (re-search-forward ert-font-lock--assertion-re + ;; Collect the first line assertion (caret or arrow) + (when (re-search-forward ert-font-lock--assertion-line-re (line-end-position) t 1) (unless (> linetocheck -1) @@ -266,21 +283,38 @@ be used through `ert'. (- (match-beginning 1) (line-beginning-position)) (ert-font-lock--get-first-char-column))) ;; negate the face? - (negation (string-equal (match-string-no-properties 2) "!")) + (negation (string-equal (match-string-no-properties 3) "!")) ;; the face that is supposed to be in the position specified - (face (match-string-no-properties 3))) + (face (read (match-string-no-properties 4)))) + ;; Collect the first assertion on the line (push (list :line-checked linetocheck :line-assert curline :column-checked column-checked :face face :negation negation) - tests)))) + tests) + + ;; Collect all the other line carets (if present) + (goto-char (match-beginning 2)) + (while (equal (following-char) ?^) + (setq column-checked (- (point) (line-beginning-position))) + (push (list :line-checked linetocheck + :line-assert curline + :column-checked column-checked + :face face + :negation negation) + tests) + (forward-char) + (skip-syntax-forward " "))))) ;; next line (setq curline (1+ curline)) (forward-line 1)) + (unless tests + (user-error "No test assertions found")) + (reverse tests))) (defun ert-font-lock--point-at-line-and-column (line column) @@ -307,21 +341,30 @@ The function is meant to be run from within an ERT test." (let* ((line-checked (plist-get test :line-checked)) (line-assert (plist-get test :line-assert)) (column-checked (plist-get test :column-checked)) - (expected-face (intern (plist-get test :face))) + (expected-face (plist-get test :face)) (negation (plist-get test :negation)) (actual-face (get-text-property (ert-font-lock--point-at-line-and-column line-checked column-checked) 'face)) (line-str (ert-font-lock--get-line line-checked)) (line-assert-str (ert-font-lock--get-line line-assert))) - (when (not (eq actual-face expected-face)) + ;; normalize both expected and resulting face - these can be + ;; either symbols, nils or lists of symbols + (when (not (listp actual-face)) + (setq actual-face (list actual-face))) + (when (not (listp expected-face)) + (setq expected-face (list expected-face))) + + ;; fail when lists are not 'equal and the assertion is *not negated* + (when (and (not negation) (not (equal actual-face expected-face))) (ert-fail (list (format "Expected face %S, got %S on line %d column %d" expected-face actual-face line-checked column-checked) :line line-str :assert line-assert-str))) - (when (and negation (eq actual-face expected-face)) + ;; fail when lists are 'equal and the assertion is *negated* + (when (and negation (equal actual-face expected-face)) (ert-fail (list (format "Did not expect face %S face on line %d, column %d" actual-face line-checked column-checked) diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 05da0f1844e..cd60f9f457f 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -540,10 +540,10 @@ The same keyword arguments are supported as in (when (and (featurep 'tramp) (getenv "EMACS_HYDRA_CI")) (add-to-list 'tramp-remote-path 'tramp-own-remote-path)) -;; If this defconst is used in a test file, `tramp' shall be loaded +;; If this defvar is used in a test file, `tramp' shall be loaded ;; prior `ert-x'. There is no default value on w32 systems, which ;; could work out of the box. -(defconst ert-remote-temporary-file-directory +(defvar ert-remote-temporary-file-directory (when (featurep 'tramp) (cond ((getenv "REMOTE_TEMPORARY_FILE_DIRECTORY")) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 353c1bd09d2..8ab57d2b238 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -278,14 +278,6 @@ DATA is displayed to the user and should state the reason for skipping." (when ert--should-execution-observer (funcall ert--should-execution-observer form-description))) -;; See Bug#24402 for why this exists -(defun ert--should-signal-hook (error-symbol data) - "Stupid hack to stop `condition-case' from catching ert signals. -It should only be stopped when ran from inside `ert--run-test-internal'." - (when (and (not (symbolp debugger)) ; only run on anonymous debugger - (memq error-symbol '(ert-test-failed ert-test-skipped))) - (funcall debugger 'error (cons error-symbol data)))) - (defun ert--special-operator-p (thing) "Return non-nil if THING is a symbol naming a special operator." (and (symbolp thing) @@ -324,8 +316,7 @@ It should only be stopped when ran from inside `ert--run-test-internal'." (default-value (gensym "ert-form-evaluation-aborted-"))) `(let* ((,fn (function ,fn-name)) (,args (condition-case err - (let ((signal-hook-function #'ert--should-signal-hook)) - (list ,@arg-forms)) + (list ,@arg-forms) (error (progn (setq ,fn #'signal) (list (car err) (cdr err))))))) @@ -728,78 +719,68 @@ in front of the value of MESSAGE-FORM." ;; value and test execution should be terminated. Should not ;; return. (exit-continuation (cl-assert nil)) - ;; The binding of `debugger' outside of the execution of the test. - next-debugger ;; The binding of `ert-debug-on-error' that is in effect for the ;; execution of the current test. We store it to avoid being ;; affected by any new bindings the test itself may establish. (I ;; don't remember whether this feature is important.) ert-debug-on-error) -(defun ert--run-test-debugger (info args) - "During a test run, `debugger' is bound to a closure that calls this function. +(defun ert--run-test-debugger (info condition debugfun) + "Error handler used during the test run. This function records failures and errors and either terminates the test silently or calls the interactive debugger, as appropriate. -INFO is the ert--test-execution-info corresponding to this test -run. ARGS are the arguments to `debugger'." - (cl-destructuring-bind (first-debugger-arg &rest more-debugger-args) - args - (cl-ecase first-debugger-arg - ((lambda debug t exit nil) - (apply (ert--test-execution-info-next-debugger info) args)) - (error - (let* ((condition (car more-debugger-args)) - (type (cl-case (car condition) - ((quit) 'quit) - ((ert-test-skipped) 'skipped) - (otherwise 'failed))) - ;; We store the backtrace in the result object for - ;; `ert-results-pop-to-backtrace-for-test-at-point'. - ;; This means we have to limit `print-level' and - ;; `print-length' when printing result objects. That - ;; might not be worth while when we can also use - ;; `ert-results-rerun-test-at-point-debugging-errors', - ;; (i.e., when running interactively) but having the - ;; backtrace ready for printing is important for batch - ;; use. - ;; - ;; Grab the frames above the debugger. - (backtrace (cdr (backtrace-get-frames debugger))) - (infos (reverse ert--infos))) - (setf (ert--test-execution-info-result info) - (cl-ecase type - (quit - (make-ert-test-quit :condition condition - :backtrace backtrace - :infos infos)) - (skipped - (make-ert-test-skipped :condition condition - :backtrace backtrace - :infos infos)) - (failed - (make-ert-test-failed :condition condition - :backtrace backtrace - :infos infos)))) - ;; Work around Emacs's heuristic (in eval.c) for detecting - ;; errors in the debugger. - (cl-incf num-nonmacro-input-events) - ;; FIXME: We should probably implement more fine-grained - ;; control a la non-t `debug-on-error' here. - (cond - ((ert--test-execution-info-ert-debug-on-error info) - (apply (ert--test-execution-info-next-debugger info) args)) - (t)) - (funcall (ert--test-execution-info-exit-continuation info))))))) +INFO is the `ert--test-execution-info' corresponding to this test run. +ERR is the error object." + (let* ((type (cl-case (car condition) + ((quit) 'quit) + ((ert-test-skipped) 'skipped) + (otherwise 'failed))) + ;; We store the backtrace in the result object for + ;; `ert-results-pop-to-backtrace-for-test-at-point'. + ;; This means we have to limit `print-level' and + ;; `print-length' when printing result objects. That + ;; might not be worth while when we can also use + ;; `ert-results-rerun-test-at-point-debugging-errors', + ;; (i.e., when running interactively) but having the + ;; backtrace ready for printing is important for batch + ;; use. + ;; + ;; Grab the frames above ourselves. + (backtrace (cdr (backtrace-get-frames debugfun))) + (infos (reverse ert--infos))) + (setf (ert--test-execution-info-result info) + (cl-ecase type + (quit + (make-ert-test-quit :condition condition + :backtrace backtrace + :infos infos)) + (skipped + (make-ert-test-skipped :condition condition + :backtrace backtrace + :infos infos)) + (failed + (make-ert-test-failed :condition condition + :backtrace backtrace + :infos infos)))) + ;; FIXME: We should probably implement more fine-grained + ;; control a la non-t `debug-on-error' here. + (cond + ((ert--test-execution-info-ert-debug-on-error info) + ;; The `debugfun' arg tells `debug' which backtrace frame starts + ;; the "entering the debugger" code so it can hide those frames + ;; from the backtrace. + (funcall debugger 'error condition :backtrace-base debugfun)) + (t)) + (funcall (ert--test-execution-info-exit-continuation info)))) (defun ert--run-test-internal (test-execution-info) "Low-level function to run a test according to TEST-EXECUTION-INFO. This mainly sets up debugger-related bindings." - (setf (ert--test-execution-info-next-debugger test-execution-info) debugger - (ert--test-execution-info-ert-debug-on-error test-execution-info) + (setf (ert--test-execution-info-ert-debug-on-error test-execution-info) ert-debug-on-error) (catch 'ert--pass ;; For now, each test gets its own temp buffer and its own @@ -807,26 +788,14 @@ This mainly sets up debugger-related bindings." ;; too expensive, we can remove it. (with-temp-buffer (save-window-excursion - ;; FIXME: Use `signal-hook-function' instead of `debugger' to - ;; handle ert errors. Once that's done, remove - ;; `ert--should-signal-hook'. See Bug#24402 and Bug#11218 for - ;; details. - (let ((lexical-binding t) - (debugger (lambda (&rest args) - (ert--run-test-debugger test-execution-info - args))) - (debug-on-error t) - ;; Don't infloop if the error being called is erroring - ;; out, and we have `debug-on-error' bound to nil inside - ;; the test. - (backtrace-on-error-noninteractive nil) - (debug-on-quit t) - ;; FIXME: Do we need to store the old binding of this - ;; and consider it in `ert--run-test-debugger'? - (debug-ignored-errors nil) + (let ((lexical-binding t) ;;FIXME: Why? (ert--infos '())) - (funcall (ert-test-body (ert--test-execution-info-test - test-execution-info)))))) + (letrec ((debugfun (lambda (err) + (ert--run-test-debugger test-execution-info + err debugfun)))) + (handler-bind (((error quit) debugfun)) + (funcall (ert-test-body (ert--test-execution-info-test + test-execution-info)))))))) (ert-pass)) (setf (ert--test-execution-info-result test-execution-info) (make-ert-test-passed)) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 63f547ebeb8..411602ef166 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -60,6 +60,7 @@ ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ cl-\\(?:defun\\|defmethod\\|defgeneric\\)\\|\ +transient-define-\\(?:prefix\\|suffix\\|infix\\|argument\\)\\|\ menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)" find-function-space-re "\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)") diff --git a/lisp/emacs-lisp/icons.el b/lisp/emacs-lisp/icons.el index a35a00ec1f3..f9591661688 100644 --- a/lisp/emacs-lisp/icons.el +++ b/lisp/emacs-lisp/icons.el @@ -164,7 +164,7 @@ If OBJECT is an icon, return the icon properties." (defun icon-elements (name) "Return the elements of icon NAME. The elements are represented as a plist where the keys are -`string', `face' and `display'. The `image' element is only +`string', `face' and `image'. The `image' element is only present if the icon is represented by an image." (let ((string (icon-string name))) (list 'face (get-text-property 0 'face string) @@ -187,11 +187,13 @@ present if the icon is represented by an image." merged) (cl-defmethod icons--create ((_type (eql 'image)) icon keywords) - (let ((file (if (file-name-absolute-p icon) - icon - (and (fboundp 'image-search-load-path) - (image-search-load-path icon))))) - (and (display-images-p) + (let* ((file (if (file-name-absolute-p icon) + icon + (and (fboundp 'image-search-load-path) + (image-search-load-path icon)))) + (file-exists (and (stringp file) (file-readable-p file)))) + (and file-exists + (display-images-p) (fboundp 'image-supported-file-p) (image-supported-file-p file) (propertize diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el index c774296084e..ddbd6fdc017 100644 --- a/lisp/emacs-lisp/inline.el +++ b/lisp/emacs-lisp/inline.el @@ -80,7 +80,9 @@ (error "inline-const-p can only be used within define-inline")) (defmacro inline-const-val (_exp) - "Return the value of EXP." + "Return the value of EXP. +During inlining, if the value of EXP is not yet known, this aborts the +inlining and makes us revert to a non-inlined function call." (declare (debug t)) (error "inline-const-val can only be used within define-inline")) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 1bb9c2fdc2e..3475d944337 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -343,7 +343,7 @@ This will generate compile-time constants from BINDINGS." (lisp-vdefs '("defvar")) (lisp-kw '("cond" "if" "while" "let" "let*" "progn" "prog1" "prog2" "lambda" "unwind-protect" "condition-case" - "when" "unless" "with-output-to-string" + "when" "unless" "with-output-to-string" "handler-bind" "ignore-errors" "dotimes" "dolist" "declare")) (lisp-errs '("warn" "error" "signal")) ;; Elisp constructs. Now they are update dynamically @@ -376,7 +376,7 @@ This will generate compile-time constants from BINDINGS." (cl-kw '("block" "break" "case" "ccase" "compiler-let" "ctypecase" "declaim" "destructuring-bind" "do" "do*" "ecase" "etypecase" "eval-when" "flet" "flet*" - "go" "handler-case" "handler-bind" "in-package" ;; "inline" + "go" "handler-case" "in-package" ;; "inline" "labels" "letf" "locally" "loop" "macrolet" "multiple-value-bind" "multiple-value-prog1" "proclaim" "prog" "prog*" "progv" @@ -1346,9 +1346,7 @@ Lisp function does not specify a special indentation." (put 'catch 'lisp-indent-function 1) (put 'condition-case 'lisp-indent-function 2) (put 'handler-case 'lisp-indent-function 1) ;CL -(put 'handler-bind 'lisp-indent-function 1) ;CL (put 'unwind-protect 'lisp-indent-function 1) -(put 'with-output-to-temp-buffer 'lisp-indent-function 1) (put 'closure 'lisp-indent-function 2) (defun indent-sexp (&optional endpos) @@ -1421,14 +1419,15 @@ A prefix argument specifies pretty-printing." ;;;; Lisp paragraph filling commands. -(defcustom emacs-lisp-docstring-fill-column 65 +(defcustom emacs-lisp-docstring-fill-column 72 "Value of `fill-column' to use when filling a docstring. Any non-integer value means do not use a different value of `fill-column' when filling docstrings." :type '(choice (integer) (const :tag "Use the current `fill-column'" t)) :safe (lambda (x) (or (eq x t) (integerp x))) - :group 'lisp) + :group 'lisp + :version "30.1") (defun lisp-fill-paragraph (&optional justify) "Like \\[fill-paragraph], but handle Emacs Lisp comments and docstrings. diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 5f152d3b509..581053f6304 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -183,7 +183,9 @@ expression, in which case we want to handle forms differently." (loaddefs-generate--shorten-autoload `(autoload ,(nth 1 form) ,file ,doc ,interactive ,type)))) - ((and expansion (memq car '(progn prog1))) + ;; Look inside `progn', and `eval-and-compile', since these + ;; are often used in the expansion of things like `pcase-defmacro'. + ((and expansion (memq car '(progn prog1 eval-and-compile))) (let ((end (memq :autoload-end form))) (when end ;Cut-off anything after the :autoload-end marker. (setq form (copy-sequence form)) @@ -199,8 +201,7 @@ expression, in which case we want to handle forms differently." define-globalized-minor-mode defun defmacro easy-mmode-define-minor-mode define-minor-mode define-inline cl-defun cl-defmacro cl-defgeneric - cl-defstruct pcase-defmacro iter-defun cl-iter-defun - transient-define-prefix)) + cl-defstruct pcase-defmacro iter-defun cl-iter-defun)) (macrop car) (setq expand (let ((load-true-file-name file) (load-file-name file)) @@ -216,13 +217,17 @@ expression, in which case we want to handle forms differently." define-globalized-minor-mode easy-mmode-define-minor-mode define-minor-mode cl-defun defun* cl-defmacro defmacro* - define-overloadable-function)) + define-overloadable-function + transient-define-prefix transient-define-suffix + transient-define-infix transient-define-argument)) (let* ((macrop (memq car '(defmacro cl-defmacro defmacro*))) (name (nth 1 form)) (args (pcase car ((or 'defun 'defmacro 'defun* 'defmacro* 'cl-defun 'cl-defmacro - 'define-overloadable-function) + 'define-overloadable-function + 'transient-define-prefix 'transient-define-suffix + 'transient-define-infix 'transient-define-argument) (nth 2 form)) ('define-skeleton '(&optional str arg)) ((or 'define-generic-mode 'define-derived-mode @@ -244,7 +249,11 @@ expression, in which case we want to handle forms differently." define-global-minor-mode define-globalized-minor-mode easy-mmode-define-minor-mode - define-minor-mode)) + define-minor-mode + transient-define-prefix + transient-define-suffix + transient-define-infix + transient-define-argument)) t) (and (eq (car-safe (car body)) 'interactive) ;; List of modes or just t. @@ -378,6 +387,7 @@ don't include." (let ((defs nil) (load-name (loaddefs-generate--file-load-name file main-outfile)) (compute-prefixes t) + read-symbol-shorthands local-outfile inhibit-autoloads) (with-temp-buffer (insert-file-contents file) @@ -399,7 +409,22 @@ don't include." (setq inhibit-autoloads (read (current-buffer))))) (save-excursion (when (re-search-forward "autoload-compute-prefixes: *" nil t) - (setq compute-prefixes (read (current-buffer)))))) + (setq compute-prefixes (read (current-buffer))))) + (save-excursion + ;; Since we're "open-coding", we have to repeat more + ;; complicated logic in `hack-local-variables'. + (when-let ((beg + (re-search-forward "read-symbol-shorthands: *" nil t))) + ;; `read-symbol-shorthands' alist ends with two parens. + (let* ((end (re-search-forward ")[;\n\s]*)")) + (commentless (replace-regexp-in-string + "\n\\s-*;+" "" + (buffer-substring beg end))) + (unsorted-shorthands (car (read-from-string commentless)))) + (setq read-symbol-shorthands + (sort unsorted-shorthands + (lambda (sh1 sh2) + (> (length (car sh1)) (length (car sh2)))))))))) ;; We always return the package version (even for pre-dumped ;; files). @@ -473,27 +498,35 @@ don't include." (when (and autoload-compute-prefixes compute-prefixes) - (when-let ((form (loaddefs-generate--compute-prefixes load-name))) - ;; This output needs to always go in the main loaddefs.el, - ;; regardless of `generated-autoload-file'. - (push (list main-outfile file form) defs))))) + (with-demoted-errors "%S" + (when-let + ((form (loaddefs-generate--compute-prefixes load-name))) + ;; This output needs to always go in the main loaddefs.el, + ;; regardless of `generated-autoload-file'. + (push (list main-outfile file form) defs)))))) defs)) (defun loaddefs-generate--compute-prefixes (load-name) (goto-char (point-min)) - (let ((prefs nil)) + (let ((prefs nil) + (temp-obarray (obarray-make))) ;; Avoid (defvar <foo>) by requiring a trailing space. (while (re-search-forward "^(\\(def[^ \t\n]+\\)[ \t\n]+['(]*\\([^' ()\"\n]+\\)[\n \t]" nil t) (unless (member (match-string 1) autoload-ignored-definitions) - (let ((name (match-string-no-properties 2))) - (when (save-excursion - (goto-char (match-beginning 0)) - (or (bobp) - (progn - (forward-line -1) - (not (looking-at ";;;###autoload"))))) - (push name prefs))))) + (let* ((name (match-string-no-properties 2)) + ;; Consider `read-symbol-shorthands'. + (probe (let ((obarray temp-obarray)) + (car (read-from-string name))))) + (when (symbolp probe) + (setq name (symbol-name probe)) + (when (save-excursion + (goto-char (match-beginning 0)) + (or (bobp) + (progn + (forward-line -1) + (not (looking-at ";;;###autoload"))))) + (push name prefs)))))) (loaddefs-generate--make-prefixes prefs load-name))) (defun loaddefs-generate--rubric (file &optional type feature compile) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 0e4fd3ea521..b87b749dd76 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -42,14 +42,8 @@ condition-case handling a signaled error.") (defmacro macroexp--with-extended-form-stack (expr &rest body) "Evaluate BODY with EXPR pushed onto `byte-compile-form-stack'." (declare (indent 1)) - ;; FIXME: We really should just be using a simple dynamic let-binding here, - ;; but these explicit push and pop make the extended stack value visible - ;; to error handlers. Remove that need for that! - `(progn - (push ,expr byte-compile-form-stack) - (prog1 - (progn ,@body) - (pop byte-compile-form-stack)))) + `(let ((byte-compile-form-stack (cons ,expr byte-compile-form-stack))) + ,@body)) ;; Bound by the top-level `macroexpand-all', and modified to include any ;; macros defined by `defmacro'. diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index ffbb29615da..d3d71a36ee4 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -608,18 +608,30 @@ 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." + ;; It's obsolete in Emacs>29, but `map.el' is distributed via GNU ELPA + ;; for earlier Emacsen. + (declare (obsolete _ "30.1")) `(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 (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))) - (t `(app (pcase--flip map-elt ',elt) ,elt)))) + (mapcar (if (< emacs-major-version 30) + (lambda (elt) + (cond ((consp 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))) + (t `(app (pcase--flip map-elt ',elt) ,elt)))) + (lambda (elt) + (cond ((consp elt) + `(app (map-elt _ ,(car elt) ,(caddr elt)) + ,(cadr elt))) + ((keywordp elt) + (let ((var (intern (substring (symbol-name elt) 1)))) + `(app (map-elt _ ,elt) ,var))) + (t `(app (map-elt _ ',elt) ,elt))))) args)) (defun map--make-pcase-patterns (args) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 0d45b4b95fa..5326c520601 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -189,7 +189,7 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") if (cl-assert (eq 'interactive (car if))) (let ((form (cadr if))) - (if (macroexp-const-p form) + (if (macroexp-const-p form) ;Common case: a string. if ;; The interactive is expected to be run in the static context ;; that the function captured. @@ -539,6 +539,32 @@ Contrary to `remove-function', this also works when SYMBOL is a macro or an autoload and it preserves `fboundp'. Instead of the actual function to remove, FUNCTION can also be the `name' of the piece of advice." + (interactive + (let* ((pred (lambda (sym) (advice--p (advice--symbol-function sym)))) + (default (when-let* ((f (function-called-at-point)) + ((funcall pred f))) + (symbol-name f))) + (prompt (format-prompt "Remove advice from function" default)) + (symbol (intern (completing-read prompt obarray pred t nil nil default))) + advices) + (advice-mapc (lambda (f p) + (let ((k (or (alist-get 'name p) f))) + (push (cons + ;; "name" (string) and 'name (symbol) are + ;; considered different names so we use + ;; `prin1-to-string' even if the name is + ;; a string to distinguish between these + ;; two cases. + (prin1-to-string k) + ;; We use `k' here instead of `f' because + ;; the same advice can have multiple + ;; names. + k) + advices))) + symbol) + (list symbol (cdr (assoc-string + (completing-read "Advice to remove: " advices nil t) + advices))))) (let ((f (symbol-function symbol))) (remove-function (cond ;This is `advice--symbol-function' but as a "place". ((get symbol 'advice--pending) @@ -559,8 +585,8 @@ of the piece of advice." (defmacro define-advice (symbol args &rest body) "Define an advice and add it to function named SYMBOL. See `advice-add' and `add-function' for explanation on the -arguments. Note if NAME is nil the advice is anonymous; -otherwise it is named `SYMBOL@NAME'. +arguments. If NAME is non-nil, the advice is named `SYMBOL@NAME' +and installed with the name NAME; otherwise, the advice is anonymous. \(fn SYMBOL (HOW LAMBDA-LIST &optional NAME DEPTH) &rest BODY)" (declare (indent 2) (doc-string 3) (debug (sexp sexp def-body))) @@ -571,7 +597,9 @@ otherwise it is named `SYMBOL@NAME'. (lambda-list (nth 1 args)) (name (nth 2 args)) (depth (nth 3 args)) - (props (and depth `((depth . ,depth)))) + (props (append + (and depth `((depth . ,depth))) + (and name `((name . ,name))))) (advice (cond ((null name) `(lambda ,lambda-list ,@body)) ((or (stringp name) (symbolp name)) (intern (format "%s@%s" symbol name))) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 26cd8594dfc..4da8e61aaa7 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -139,12 +139,15 @@ (:include cl--class) (:copier nil)) "Metaclass for OClosure classes." + ;; The `allparents' slot is used for the predicate that checks if a given + ;; object is an OClosure of a particular type. (allparents nil :read-only t :type (list-of symbol))) (setf (cl--find-class 'oclosure) (oclosure--class-make 'oclosure - "The root parent of all OClosure classes" - nil nil '(oclosure))) + "The root parent of all OClosure types" + nil (list (cl--find-class 'function)) + '(oclosure))) (defun oclosure--p (oclosure) (not (not (oclosure-type oclosure)))) @@ -434,7 +437,7 @@ This has 2 uses: - For compiled code, this is used as a marker which cconv uses to check that immutable fields are indeed not mutated." (if (byte-code-function-p oclosure) - ;; Actually, this should never happen since the `cconv.el' should have + ;; Actually, this should never happen since `cconv.el' should have ;; optimized away the call to this function. oclosure ;; For byte-coded functions, we store the type as a symbol in the docstring diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index db0cc515e46..ef056c7909b 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -501,8 +501,10 @@ This includes downloading missing dependencies, generating autoloads, generating a package description file (used to identify a package as a VC package later on), building documentation and marking the package as installed." - (let ((pkg-spec (package-vc--desc->spec pkg-desc)) - missing) + (let* ((pkg-spec (package-vc--desc->spec pkg-desc)) + (lisp-dir (plist-get pkg-spec :lisp-dir)) + (lisp-path (file-name-concat pkg-dir lisp-dir)) + missing) ;; In case the package was installed directly from source, the ;; dependency list wasn't know beforehand, and they might have @@ -519,7 +521,7 @@ documentation and marking the package as installed." "\\|") regexp-unmatchable)) (deps '())) - (dolist (file (directory-files pkg-dir t "\\.el\\'" t)) + (dolist (file (directory-files lisp-path t "\\.el\\'" t)) (unless (string-match-p ignored-files file) (with-temp-buffer (insert-file-contents file) @@ -532,6 +534,7 @@ documentation and marking the package as installed." (setq deps)))))) (dolist (dep deps) (cl-callf version-to-list (cadr dep))) + (setf (package-desc-reqs pkg-desc) deps) (setf missing (package-vc-install-dependencies (delete-dups deps))) (setf missing (delq (assq (package-desc-name pkg-desc) missing) @@ -541,10 +544,8 @@ documentation and marking the package as installed." (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir))) ;; Generate autoloads (let* ((name (package-desc-name pkg-desc)) - (auto-name (format "%s-autoloads.el" name)) - (lisp-dir (plist-get pkg-spec :lisp-dir))) - (package-generate-autoloads - name (file-name-concat pkg-dir lisp-dir)) + (auto-name (format "%s-autoloads.el" name))) + (package-generate-autoloads name lisp-path) (when lisp-dir (write-region (with-temp-buffer @@ -938,8 +939,8 @@ for the last released version of the package." (interactive (let* ((name (package-vc--read-package-name "Fetch package source: "))) (list (cadr (assoc name package-archive-contents #'string=)) - (read-file-name "Clone into new or empty directory: " nil nil t nil - (lambda (dir) (or (not (file-exists-p dir)) + (read-directory-name "Clone into new or empty directory: " nil nil + (lambda (dir) (or (not (file-exists-p dir)) (directory-empty-p dir)))) (and current-prefix-arg :last-release)))) (package-vc--archives-initialize) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 80f746d7429..3428b2375d7 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2611,7 +2611,8 @@ This is meant to be used only in the case the byte-compiled files are invalid due to changed byte-code, macros or the like." (interactive) (pcase-dolist (`(_ ,pkg-desc) package-alist) - (package-recompile pkg-desc))) + (with-demoted-errors "Error while recompiling: %S" + (package-recompile pkg-desc)))) ;;;###autoload (defun package-autoremove () @@ -2805,8 +2806,7 @@ 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))) - (maintainers (or (cdr (assoc :maintainers extras)) - (list (cdr (assoc :maintainer extras))))) + (maintainers (cdr (assoc :maintainer extras))) (authors (cdr (assoc :authors extras))) (news (and-let* (pkg-dir ((not built-in)) @@ -2942,7 +2942,7 @@ Helper function for `describe-package'." (insert " ")) (insert "\n")) (when maintainers - (unless (proper-list-p maintainers) + (when (stringp (car maintainers)) (setq maintainers (list maintainers))) (package--print-help-section (if (cdr maintainers) "Maintainers" "Maintainer")) @@ -4071,8 +4071,8 @@ invocations." (defun package-menu--version-predicate (A B) "Predicate to sort \"*Packages*\" buffer by the version column. This is used for `tabulated-list-format' in `package-menu-mode'." - (let ((vA (or (version-to-list (aref (cadr A) 1)) '(0))) - (vB (or (version-to-list (aref (cadr B) 1)) '(0)))) + (let ((vA (or (ignore-error error (version-to-list (aref (cadr A) 1))) '(0))) + (vB (or (ignore-error error (version-to-list (aref (cadr B) 1))) '(0)))) (if (version-list-= vA vB) (package-menu--name-predicate A B) (version-list-< vA vB)))) @@ -4700,18 +4700,23 @@ will be signaled in that case." (let* ((name (package-desc-name pkg-desc)) (extras (package-desc-extras pkg-desc)) (maint (alist-get :maintainer extras))) + (unless (listp (cdr maint)) + (setq maint (list maint))) (cond ((and (null maint) (null no-error)) (user-error "Package `%s' has no explicit maintainer" name)) ((and (not (progn (require 'ietf-drums) - (ietf-drums-parse-address (cdr maint)))) + (ietf-drums-parse-address (cdar maint)))) (null no-error)) (user-error "Package `%s' has no maintainer address" name)) - ((not (null maint)) + (t (with-temp-buffer - (package--print-email-button maint) - (string-trim (substring-no-properties (buffer-string)))))))) + (mapc #'package--print-email-button maint) + (replace-regexp-in-string + "\n" ", " (string-trim + (buffer-substring-no-properties + (point-min) (point-max))))))))) ;;;###autoload (defun package-report-bug (desc) @@ -4721,17 +4726,19 @@ DESC must be a `package-desc' object." package-menu-mode) (let ((maint (package-maintainers desc)) (name (symbol-name (package-desc-name desc))) + (pkgdir (package-desc-dir desc)) vars) - (dolist-with-progress-reporter (group custom-current-group-alist) - "Scanning for modified user options..." - (when (and (car group) - (file-in-directory-p (car group) (package-desc-dir desc))) - (dolist (ent (get (cdr group) 'custom-group)) - (when (and (custom-variable-p (car ent)) - (boundp (car ent)) - (not (eq (custom--standard-value (car ent)) - (default-toplevel-value (car ent))))) - (push (car ent) vars))))) + (when pkgdir + (dolist-with-progress-reporter (group custom-current-group-alist) + "Scanning for modified user options..." + (when (and (car group) + (file-in-directory-p (car group) pkgdir)) + (dolist (ent (get (cdr group) 'custom-group)) + (when (and (custom-variable-p (car ent)) + (boundp (car ent)) + (not (eq (custom--standard-value (car ent)) + (default-toplevel-value (car ent))))) + (push (car ent) vars)))))) (dlet ((reporter-prompt-for-summary-p t)) (reporter-submit-bug-report maint name vars)))) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 5ac4b289a80..23f1bac600c 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -42,6 +42,14 @@ ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to ;; generate a lex-style DFA to decide whether to run E1 or E2. +;; While the first version was written before I knew about Racket's `match' +;; construct, the second version was significantly influenced by it, +;; so a good presentation of the underlying ideas can be found at: +;; +;; Extensible Pattern Matching in an Extensible Language +;; Sam Tobin-Hochstadt, 2010 +;; https://arxiv.org/abs/1106.2578 + ;;; Code: (require 'macroexp) @@ -123,6 +131,8 @@ FUN in `pred' and `app' can take one of the forms: call it with one argument (F ARG1 .. ARGn) call F with ARG1..ARGn and EXPVAL as n+1'th argument + (F ARG1 .. _ .. ARGn) + call F, passing EXPVAL at the _ position. FUN, BOOLEXP, and subsequent PAT can refer to variables bound earlier in the pattern by a SYMBOL pattern. @@ -155,8 +165,12 @@ Emacs Lisp manual for more information and examples." ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2) expansion)))) -(declare-function help-fns--signature "help-fns" - (function doc real-def real-function buffer)) +(defconst pcase--find-macro-def-regexp "(pcase-defmacro[\s\t\n]+%s[\s\t\n]*(") + +(with-eval-after-load 'find-func + (defvar find-function-regexp-alist) + (add-to-list 'find-function-regexp-alist + `(pcase-macro . pcase--find-macro-def-regexp))) ;; FIXME: Obviously, this will collide with nadvice's use of ;; function-documentation if we happen to advise `pcase'. @@ -166,9 +180,10 @@ Emacs Lisp manual for more information and examples." (defun pcase--make-docstring () (let* ((main (documentation (symbol-function 'pcase) 'raw)) (ud (help-split-fundoc main 'pcase))) - ;; So that eg emacs -Q -l cl-lib --eval "(documentation 'pcase)" works, - ;; where cl-lib is anything using pcase-defmacro. (require 'help-fns) + (declare-function help-fns-short-filename "help-fns" (filename)) + (declare-function help-fns--signature "help-fns" + (function doc real-def real-function buffer)) (with-temp-buffer (insert (or (cdr ud) main)) ;; Presentation Note: For conceptual continuity, we guarantee @@ -189,11 +204,20 @@ Emacs Lisp manual for more information and examples." (let* ((pair (pop more)) (symbol (car pair)) (me (cdr pair)) - (doc (documentation me 'raw))) + (doc (documentation me 'raw)) + (filename (find-lisp-object-file-name me 'defun))) (insert "\n\n-- ") (setq doc (help-fns--signature symbol doc me (indirect-function me) nil)) + (when filename + (save-excursion + (forward-char -1) + (insert (format-message " in `")) + (help-insert-xref-button (help-fns-short-filename filename) + 'help-function-def symbol filename + 'pcase-macro) + (insert (format-message "'.")))) (insert "\n" (or doc "Not documented."))))) (let ((combined-doc (buffer-string))) (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) @@ -261,8 +285,8 @@ As with `pcase-let', BINDINGS are of the form (PATTERN EXP), but the EXP in each binding in BINDINGS can use the results of the destructuring bindings that precede it in BINDINGS' order. -Each EXP should match (i.e. be of compatible structure) to its -respective PATTERN; a mismatch may signal an error or may go +Each EXP should match its respective PATTERN (i.e. be of structure +compatible to PATTERN); a mismatch may signal an error or may go undetected, binding variables to arbitrary values, such as nil." (declare (indent 1) (debug ((&rest (pcase-PAT &optional form)) body))) @@ -283,8 +307,8 @@ All EXPs are evaluated first, and then used to perform destructuring bindings by matching each EXP against its respective PATTERN. Then BODY is evaluated with those bindings in effect. -Each EXP should match (i.e. be of compatible structure) to its -respective PATTERN; a mismatch may signal an error or may go +Each EXP should match its respective PATTERN (i.e. be of structure +compatible to PATTERN); a mismatch may signal an error or may go undetected, binding variables to arbitrary values, such as nil." (declare (indent 1) (debug pcase-let*)) (if (null (cdr bindings)) @@ -599,62 +623,84 @@ recording whether the var has been referenced by earlier parts of the match." (defun pcase--and (match matches) (if matches `(and ,match ,@matches) match)) -(defconst pcase-mutually-exclusive-predicates - '((symbolp . integerp) - (symbolp . numberp) - (symbolp . consp) - (symbolp . arrayp) - (symbolp . vectorp) - (symbolp . stringp) - (symbolp . byte-code-function-p) - (symbolp . compiled-function-p) - (symbolp . recordp) - (null . integerp) - (null . numberp) - (null . numberp) - (null . consp) - (null . arrayp) - (null . vectorp) - (null . stringp) - (null . byte-code-function-p) - (null . compiled-function-p) - (null . recordp) - (integerp . consp) - (integerp . arrayp) - (integerp . vectorp) - (integerp . stringp) - (integerp . byte-code-function-p) - (integerp . compiled-function-p) - (integerp . recordp) - (numberp . consp) - (numberp . arrayp) - (numberp . vectorp) - (numberp . stringp) - (numberp . byte-code-function-p) - (numberp . compiled-function-p) - (numberp . recordp) - (consp . arrayp) - (consp . atom) - (consp . vectorp) - (consp . stringp) - (consp . byte-code-function-p) - (consp . compiled-function-p) - (consp . recordp) - (arrayp . byte-code-function-p) - (arrayp . compiled-function-p) - (vectorp . byte-code-function-p) - (vectorp . compiled-function-p) - (vectorp . recordp) - (stringp . vectorp) - (stringp . recordp) - (stringp . byte-code-function-p) - (stringp . compiled-function-p))) - +(defun pcase--subtype-bitsets () + (let ((built-in-types ())) + (mapatoms (lambda (sym) + (let ((class (get sym 'cl--class))) + (when (and (built-in-class-p class) + (get sym 'cl-deftype-satisfies)) + (push (list sym + (get sym 'cl-deftype-satisfies) + (cl--class-allparents class)) + built-in-types))))) + ;; The "true" predicate for `function' type is `cl-functionp'. + (setcar (nthcdr 1 (assq 'function built-in-types)) 'cl-functionp) + ;; Sort the types from deepest in the hierarchy so all children + ;; are processed before their parent. It also gives lowest + ;; numbers to those types that are subtypes of the largest number + ;; of types, which minimize the need to use bignums. + (setq built-in-types (sort built-in-types + (lambda (x y) + (> (length (nth 2 x)) (length (nth 2 y)))))) + + (let ((bitsets (make-hash-table)) + (i 1)) + (dolist (x built-in-types) + ;; Don't dedicate any bit to those predicates which already + ;; have a bitset, since it means they're already represented + ;; by their subtypes. + (unless (and (nth 1 x) (gethash (nth 1 x) bitsets)) + (dolist (parent (nth 2 x)) + (let ((pred (nth 1 (assq parent built-in-types)))) + (unless (or (eq parent t) (null pred)) + (puthash pred (+ i (gethash pred bitsets 0)) + bitsets)))) + (setq i (+ i i)))) + + ;; Extra predicates that don't have matching types. + (dolist (pred-types '((functionp cl-functionp consp symbolp) + (keywordp symbolp) + (characterp fixnump) + (natnump integerp) + (facep symbolp stringp) + (plistp listp) + (cl-struct-p recordp) + ;; ;; FIXME: These aren't quite in the same + ;; ;; category since they'll signal errors. + (fboundp symbolp) + )) + (puthash (car pred-types) + (apply #'logior + (mapcar (lambda (pred) + (gethash pred bitsets)) + (cdr pred-types))) + bitsets)) + bitsets))) + +(defconst pcase--subtype-bitsets + (if (fboundp 'built-in-class-p) + (pcase--subtype-bitsets) + ;; Early bootstrap: we don't have the built-in classes yet, so just + ;; use an empty table for now. + (prog1 (make-hash-table) + ;; The empty table leads to significantly worse code, so upgrade + ;; to the real table as soon as possible (most importantly: before we + ;; start compiling code, and hence baking the result into files). + (with-eval-after-load 'cl-preloaded + (defconst pcase--subtype-bitsets (pcase--subtype-bitsets))))) + "Hash table mapping type predicates to their sets of types. +The table maps each type predicate, such as `numberp' and `stringp', +to the set of built-in types for which the predicate may return non-nil. +The sets are represented as bitsets (integers) where each bit represents +a specific leaf type. Which bit represents which type is unspecified.") + +;; Extra predicates (defun pcase--mutually-exclusive-p (pred1 pred2) - (or (member (cons pred1 pred2) - pcase-mutually-exclusive-predicates) - (member (cons pred2 pred1) - pcase-mutually-exclusive-predicates))) + (let ((subtypes1 (gethash pred1 pcase--subtype-bitsets))) + (when subtypes1 + (let ((subtypes2 (gethash pred2 pcase--subtype-bitsets))) + (when subtypes2 + (zerop (logand subtypes1 subtypes2))))))) (defun pcase--split-match (sym splitter match) (cond @@ -790,12 +836,13 @@ A and B can be one of: ((vectorp (cadr pat)) #'vectorp) ((compiled-function-p (cadr pat)) #'compiled-function-p)))) - (pcase--mutually-exclusive-p (cadr upat) otherpred)) + (and otherpred + (pcase--mutually-exclusive-p (cadr upat) otherpred))) '(:pcase--fail . nil)) - ;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c)))) + ;; Since we turn (or 'a 'b 'c) into (pred (memq _ '(a b c))) ;; try and preserve the info we get from that memq test. - ((and (eq 'pcase--flip (car-safe (cadr upat))) - (memq (cadr (cadr upat)) '(memq member memql)) + ((and (memq (car-safe (cadr upat)) '(memq member memql)) + (eq (cadr (cadr upat)) '_) (eq 'quote (car-safe (nth 2 (cadr upat)))) (eq 'quote (car-safe pat))) (let ((set (cadr (nth 2 (cadr upat))))) @@ -843,7 +890,7 @@ A and B can be one of: (defmacro pcase--flip (fun arg1 arg2) "Helper function, used internally to avoid (funcall (lambda ...) ...)." - (declare (debug (sexp body))) + (declare (debug (sexp body)) (obsolete _ "30.1")) `(,fun ,arg2 ,arg1)) (defun pcase--funcall (fun arg vars) @@ -864,9 +911,13 @@ A and B can be one of: (let ((newsym (gensym "x"))) (push (list newsym arg) env) (setq arg newsym))) - (if (or (functionp fun) (not (consp fun))) - `(funcall #',fun ,arg) - `(,@fun ,arg))))) + (cond + ((or (functionp fun) (not (consp fun))) + `(funcall #',fun ,arg)) + ((memq '_ fun) + (mapcar (lambda (x) (if (eq '_ x) arg x)) fun)) + (t + `(,@fun ,arg)))))) (if (null env) call ;; Let's not replace `vars' in `fun' since it's @@ -927,7 +978,7 @@ Otherwise, it defers to REST which is a list of branches of the form ;; Yes, we can use `memql' (or `member')! ((> (length simples) 1) (pcase--u1 (cons `(match ,var - . (pred (pcase--flip ,mem-fun ',simples))) + . (pred (,mem-fun _ ',simples))) (cdr matches)) code vars (if (null others) rest @@ -1074,12 +1125,13 @@ The predicate is the logical-AND of: (declare (debug (pcase-QPAT))) (cond ((eq (car-safe qpat) '\,) (cadr qpat)) + ((eq (car-safe qpat) '\,@) (error "Unsupported QPAT: %S" qpat)) ((vectorp qpat) `(and (pred vectorp) (app length ,(length qpat)) ,@(let ((upats nil)) (dotimes (i (length qpat)) - (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i))) + (push `(app (aref _ ,i) ,(list '\` (aref qpat i))) upats)) (nreverse upats)))) ((consp qpat) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 1d722051406..d586fc59939 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -166,12 +166,19 @@ 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))))) + (let* ((end (copy-marker end t)) + (avoid-unbreakable + (lambda () + (and (memq (char-before) '(?# ?s ?f)) + (memq (char-after) '(?\[ ?\()) + (looking-back "#[sf]?" (- (point) 2)) + (goto-char (match-beginning 0))))) + (newline (lambda () + (skip-chars-forward ")]}") + (unless (save-excursion (skip-chars-forward " \t") (eolp)) + (funcall avoid-unbreakable) + (insert "\n") + (indent-according-to-mode))))) (while (progn (forward-comment (point-max)) (< (point) end)) (let ((beg (point)) @@ -193,11 +200,18 @@ it inserts and pretty-prints that arg at point." (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") + ;; We skip backward over open parens because cutting + ;; the line right after an open paren does not help + ;; reduce the indentation depth. + ;; Similarly, we prefer to cut before a "." than after + ;; it because it reduces the indentation depth. + (while + (progn + (funcall avoid-unbreakable) + (not (zerop (skip-chars-backward " \t({[',."))))) + (if (bolp) + ;; The sexp already starts on its own line. + (progn (goto-char beg) nil) (setq beg (copy-marker beg t)) (if paired (setq paired (copy-marker paired t))) ;; We could try to undo this insertion if it @@ -346,6 +360,23 @@ after OUT-BUFFER-NAME." (setq buffer-read-only nil) (setq-local font-lock-verbose nil))))) +(defun pp-insert-short-sexp (sexp &optional width) + "Insert a short description of SEXP in the current buffer. +WIDTH is the maximum width to use for it and it defaults to the +space available between point and the window margin." + (let ((printed (format "%S" sexp))) + (if (and (not (string-search "\n" printed)) + (<= (string-width printed) + (or width (- (window-width) (current-column))))) + (insert printed) + (insert-text-button + "[Show]" + 'follow-link t + 'action (lambda (&rest _ignore) + ;; FIXME: Why "eval output"? + (pp-display-expression sexp "*Pp Eval Output*")) + 'help-echo "mouse-2, RET: pretty print value in another buffer")))) + ;;;###autoload (defun pp-eval-expression (expression) "Evaluate EXPRESSION and pretty-print its value. @@ -430,23 +461,33 @@ the bounds of a region containing Lisp code to pretty-print." (replace-match "")) (insert-into-buffer obuf))))) +(defvar pp--quoting-syntaxes + `((quote . "'") + (function . "#'") + (,backquote-backquote-symbol . "`") + (,backquote-unquote-symbol . ",") + (,backquote-splice-symbol . ",@"))) + +(defun pp--quoted-or-unquoted-form-p (cons) + ;; Return non-nil when CONS has one of the forms 'X, `X, ,X or ,@X + (let ((head (car cons))) + (and (symbolp head) + (assq head pp--quoting-syntaxes) + (let ((rest (cdr cons))) + (and (consp rest) (null (cdr rest))))))) + (defun pp--insert-lisp (sexp) (cl-case (type-of sexp) (vector (pp--format-vector sexp)) (cons (cond ((consp (cdr sexp)) - (if (and (length= sexp 2) - (memq (car sexp) '(quote function))) - (cond - ((symbolp (cadr sexp)) - (let ((print-quoted t)) - (prin1 sexp (current-buffer)))) - ((consp (cadr sexp)) - (insert (if (eq (car sexp) 'quote) - "'" "#'")) - (pp--format-list (cadr sexp) - (set-marker (make-marker) (1- (point)))))) - (pp--format-list sexp))) + (let ((head (car sexp))) + (if-let (((null (cddr sexp))) + (syntax-entry (assq head pp--quoting-syntaxes))) + (progn + (insert (cdr syntax-entry)) + (pp--insert-lisp (cadr sexp))) + (pp--format-list sexp)))) (t (prin1 sexp (current-buffer))))) ;; Print some of the smaller integers as characters, perhaps? @@ -458,6 +499,8 @@ the bounds of a region containing Lisp code to pretty-print." (string (let ((print-escape-newlines t)) (prin1 sexp (current-buffer)))) + (symbol + (prin1 sexp (current-buffer))) (otherwise (princ sexp (current-buffer))))) (defun pp--format-vector (sexp) @@ -468,15 +511,29 @@ the bounds of a region containing Lisp code to pretty-print." (insert "]")) (defun pp--format-list (sexp &optional start) - (if (and (symbolp (car sexp)) - (not pp--inhibit-function-formatting) - (not (keywordp (car sexp)))) + (if (not (let ((head (car sexp))) + (or pp--inhibit-function-formatting + (not (symbolp head)) + (keywordp head) + (let ((l sexp)) + (catch 'not-funcall + (while l + (when (or + (atom l) ; SEXP is a dotted list + ;; Does SEXP have a form like (ELT... . ,X) ? + (pp--quoted-or-unquoted-form-p l)) + (throw 'not-funcall t)) + (setq l (cdr l))) + nil))))) (pp--format-function sexp) (insert "(") (pp--insert start (pop sexp)) (while sexp (if (consp sexp) - (pp--insert " " (pop sexp)) + (if (not (pp--quoted-or-unquoted-form-p sexp)) + (pp--insert " " (pop sexp)) + (pp--insert " . " sexp) + (setq sexp nil)) (pp--insert " . " sexp) (setq sexp nil))) (insert ")"))) diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 0a47cca0231..c5307f70d08 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -825,7 +825,7 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (defun reb-restart-font-lock () "Restart `font-lock-mode' to fit current regexp format." - (with-current-buffer (get-buffer reb-buffer) + (with-current-buffer reb-buffer (let ((font-lock-is-on font-lock-mode)) (font-lock-mode -1) (kill-local-variable 'font-lock-set-defaults) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 4c6553972c2..a20cff16982 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -362,8 +362,7 @@ the result. The result is a sequence of the same type as SEQUENCE." (seq-concatenate - (let ((type (type-of sequence))) - (if (eq type 'cons) 'list type)) + (if (listp sequence) 'list (type-of sequence)) (seq-subseq sequence 0 n) (seq-subseq sequence (1+ n)))) @@ -619,12 +618,12 @@ SEQUENCE must be a sequence of numbers or markers." (unless rest-marker (pcase name (`&rest - (progn (push `(app (pcase--flip seq-drop ,index) + (progn (push `(app (seq-drop _ ,index) ,(seq--elt-safe args (1+ index))) bindings) (setq rest-marker t))) (_ - (push `(app (pcase--flip seq--elt-safe ,index) ,name) bindings)))) + (push `(app (seq--elt-safe _ ,index) ,name) bindings)))) (setq index (1+ index))) bindings)) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 17cbf6b2d31..a1e49b50510 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -51,6 +51,17 @@ "Face used for a section.") ;;;###autoload +(defun shortdoc--check (group functions) + (let ((keywords '( :no-manual :args :eval :no-eval :no-value :no-eval* + :result :result-string :eg-result :eg-result-string :doc))) + (dolist (f functions) + (when (consp f) + (dolist (x f) + (when (and (keywordp x) (not (memq x keywords))) + (error "Shortdoc %s function `%s': bad keyword `%s'" + group (car f) x))))))) + +;;;###autoload (progn (defvar shortdoc--groups nil) @@ -118,6 +129,7 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), `:no-eval*', `:result', `:result-string', `:eg-result' and `:eg-result-string' properties." (declare (indent defun)) + (shortdoc--check group functions) `(progn (setq shortdoc--groups (delq (assq ',group shortdoc--groups) shortdoc--groups)) @@ -572,10 +584,7 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :result-string "#s(hash-table ...)") (hash-table-count :no-eval (hash-table-count table) - :eg-result 15) - (hash-table-size - :no-eval (hash-table-size table) - :eg-result 65)) + :eg-result 15)) (define-short-documentation-group list "Making Lists" @@ -718,7 +727,7 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (plist-get '(a 1 b 2 c 3) 'b)) (plist-put :no-eval (setq plist (plist-put plist 'd 4)) - :eq-result (a 1 b 2 c 3 d 4)) + :eg-result (a 1 b 2 c 3 d 4)) (plist-member :eval (plist-member '(a 1 b 2 c 3) 'b)) "Data About Lists" @@ -738,9 +747,13 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (intern :eval (intern "abc")) (intern-soft + :eval (intern-soft "list") :eval (intern-soft "Phooey!")) (make-symbol :eval (make-symbol "abc")) + (gensym + :no-eval (gensym) + :eg-result g37) "Comparing symbols" (eq :eval (eq 'abc 'abc) @@ -751,7 +764,20 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (equal 'abc 'abc)) "Name" (symbol-name - :eval (symbol-name 'abc))) + :eval (symbol-name 'abc)) + "Obarrays" + (obarray-make + :eval (obarray-make)) + (obarrayp + :eval (obarrayp (obarray-make)) + :eval (obarrayp nil)) + (unintern + :no-eval (unintern "abc" my-obarray) + :eg-result t) + (mapatoms + :no-eval (mapatoms (lambda (symbol) (print symbol)) my-obarray)) + (obarray-clear + :no-eval (obarray-clear my-obarray))) (define-short-documentation-group comparison "General-purpose" @@ -1755,7 +1781,7 @@ With prefix numeric argument ARG, do it that many times." (interactive) (save-excursion (goto-char (pos-bol)) - (when-let* ((re (rx bol "(" (group (+ (not (in " ")))))) + (when-let* ((re (rx bol "(" (group (+ (not (in " )")))))) (string (and (or (looking-at re) (re-search-backward re nil t)) diff --git a/lisp/emacs-lisp/shorthands.el b/lisp/emacs-lisp/shorthands.el index 6348aaccf93..379fb0baec9 100644 --- a/lisp/emacs-lisp/shorthands.el +++ b/lisp/emacs-lisp/shorthands.el @@ -52,38 +52,26 @@ :version "28.1" :group 'font-lock-faces) -(defun shorthands--mismatch-from-end (str1 str2) - "Tell index of first mismatch in STR1 and STR2, from end. -The index is a valid 0-based index on STR1. Returns nil if STR1 -equals STR2. Return 0 if STR1 is a suffix of STR2." - (cl-loop with l1 = (length str1) with l2 = (length str2) - for i from 1 - for i1 = (- l1 i) for i2 = (- l2 i) - while (eq (aref str1 i1) (aref str2 i2)) - if (zerop i2) return (if (zerop i1) nil i1) - if (zerop i1) return 0 - finally (return i1))) - (defun shorthands-font-lock-shorthands (limit) + "Font lock until LIMIT considering `read-symbol-shorthands'." (when read-symbol-shorthands (while (re-search-forward (concat "\\_<\\(" (rx lisp-mode-symbol) "\\)\\_>") limit t) (let* ((existing (get-text-property (match-beginning 1) 'face)) + (print-name (match-string 1)) (probe (and (not (memq existing '(font-lock-comment-face font-lock-string-face))) - (intern-soft (match-string 1)))) - (sname (and probe (symbol-name probe))) - (mismatch (and sname (shorthands--mismatch-from-end - (match-string 1) sname))) - (guess (and mismatch (1+ mismatch)))) - (when guess - (when (and (< guess (1- (length (match-string 1)))) - ;; In bug#67390 we allow other separators - (eq (char-syntax (aref (match-string 1) guess)) ?_)) - (setq guess (1+ guess))) + (intern-soft print-name))) + (symbol-name (and probe (symbol-name probe))) + (prefix (and symbol-name + (not (string-equal print-name symbol-name)) + (car (assoc print-name + read-symbol-shorthands + #'string-prefix-p))))) + (when prefix (add-face-text-property (match-beginning 1) - (+ (match-beginning 1) guess) + (+ (match-beginning 1) (length prefix)) 'elisp-shorthand-font-lock-face)))))) (font-lock-add-keywords 'emacs-lisp-mode '((shorthands-font-lock-shorthands)) t) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 9884a2fc24b..c86e3f9c5df 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -139,6 +139,21 @@ If `tabulated-list-entries' is a function, it is called with no arguments and must return a list of the above form.") (put 'tabulated-list-entries 'permanent-local t) +(defvar-local tabulated-list-groups nil + "Groups displayed in the current Tabulated List buffer. +This should be either a function, or a list. +If a list, each element has the form (GROUP-NAME ENTRIES), +where: + + - GROUP-NAME is a group name as a string, which is displayed + at the top line of each group. + + - ENTRIES is a list described in `tabulated-list-entries'. + +If `tabulated-list-groups' is a function, it is called with no +arguments and must return a list of the above form.") +(put 'tabulated-list-groups 'permanent-local t) + (defvar-local tabulated-list-padding 0 "Number of characters preceding each Tabulated List mode entry. By default, lines are padded with spaces, but you can use the @@ -362,15 +377,17 @@ Do nothing if `tabulated-list--header-string' is nil." (if tabulated-list--header-overlay (move-overlay tabulated-list--header-overlay (point-min) (point)) (setq-local tabulated-list--header-overlay - (make-overlay (point-min) (point)))) - (overlay-put tabulated-list--header-overlay - 'face 'tabulated-list-fake-header)))) + (make-overlay (point-min) (point))) + (overlay-put tabulated-list--header-overlay 'fake-header t) + (overlay-put tabulated-list--header-overlay + 'face 'tabulated-list-fake-header))))) (defsubst tabulated-list-header-overlay-p (&optional pos) "Return non-nil if there is a fake header. Optional arg POS is a buffer position where to look for a fake header; defaults to `point-min'." - (overlays-at (or pos (point-min)))) + (seq-find (lambda (o) (overlay-get o 'fake-header)) + (overlays-at (or pos (point-min))))) (defun tabulated-list-revert (&rest _ignored) "The `revert-buffer-function' for `tabulated-list-mode'. @@ -427,6 +444,9 @@ This sorts the `tabulated-list-entries' list if sorting is specified by `tabulated-list-sort-key'. It then erases the buffer and inserts the entries with `tabulated-list-printer'. +If `tabulated-list-groups' is non-nil, each group of entries +is printed and sorted separately. + Optional argument REMEMBER-POS, if non-nil, means to move point to the entry with the same ID element as the current line. @@ -437,6 +457,9 @@ be removed from entries that haven't changed (see `tabulated-list-put-tag'). Don't use this immediately after changing `tabulated-list-sort-key'." (let ((inhibit-read-only t) + (groups (if (functionp tabulated-list-groups) + (funcall tabulated-list-groups) + tabulated-list-groups)) (entries (if (functionp tabulated-list-entries) (funcall tabulated-list-entries) tabulated-list-entries)) @@ -447,7 +470,14 @@ changing `tabulated-list-sort-key'." (setq saved-col (current-column))) ;; Sort the entries, if necessary. (when sorter - (setq entries (sort entries sorter))) + (if groups + (setq groups + (mapcar (lambda (group) + (cons (car group) (sort (cdr group) sorter))) + groups)) + (setq entries (sort entries sorter)))) + (unless (functionp tabulated-list-groups) + (setq tabulated-list-groups groups)) (unless (functionp tabulated-list-entries) (setq tabulated-list-entries entries)) ;; Without a sorter, we have no way to just update. @@ -459,6 +489,25 @@ changing `tabulated-list-sort-key'." (unless tabulated-list-use-header-line (tabulated-list-print-fake-header))) ;; Finally, print the resulting list. + (if groups + (dolist (group groups) + (insert (car group) ?\n) + (when-let ((saved-pt-new (tabulated-list-print-entries + (cdr group) sorter update entry-id))) + (setq saved-pt saved-pt-new))) + (setq saved-pt (tabulated-list-print-entries + entries sorter update entry-id))) + (when update + (delete-region (point) (point-max))) + (set-buffer-modified-p nil) + ;; If REMEMBER-POS was specified, move to the "old" location. + (if saved-pt + (progn (goto-char saved-pt) + (move-to-column saved-col)) + (goto-char (point-min))))) + +(defun tabulated-list-print-entries (entries sorter update entry-id) + (let (saved-pt) (while entries (let* ((elt (car entries)) (tabulated-list--near-rows @@ -495,14 +544,7 @@ changing `tabulated-list-sort-key'." (forward-line 1) (delete-region old (point)))))) (setq entries (cdr entries))) - (when update - (delete-region (point) (point-max))) - (set-buffer-modified-p nil) - ;; If REMEMBER-POS was specified, move to the "old" location. - (if saved-pt - (progn (goto-char saved-pt) - (move-to-column saved-col)) - (goto-char (point-min))))) + saved-pt)) (defun tabulated-list-print-entry (id cols) "Insert a Tabulated List entry at point. diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index 2c8b913ec33..1ed1528c6d5 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -156,44 +156,43 @@ (defun trace-values (&rest values) "Helper function to get internal values. You can call this function to add internal values in the trace buffer." - (unless inhibit-trace - (with-current-buffer (get-buffer-create trace-buffer) - (goto-char (point-max)) - (insert - (trace-entry-message - 'trace-values trace-level values ""))))) + (trace--entry-message + 'trace-values trace-level values (lambda () ""))) -(defun trace-entry-message (function level args context) +(defun trace--entry-message (function level args context) "Generate a string that describes that FUNCTION has been entered. -LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION, -and CONTEXT is a string describing the dynamic context (e.g. values of -some global variables)." - (let ((print-circle t) - (print-escape-newlines t)) - (format "%s%s%d -> %s%s\n" - (mapconcat #'char-to-string (make-string (max 0 (1- level)) ?|) " ") - (if (> level 1) " " "") - level - ;; FIXME: Make it so we can click the function name to jump to its - ;; definition and/or untrace it. - (cl-prin1-to-string (cons function args)) - context))) - -(defun trace-exit-message (function level value context) +LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION." + (unless inhibit-trace + (trace--insert + (let ((ctx (funcall context)) + (print-circle t) + (print-escape-newlines t)) + (format "%s%s%d -> %s%s\n" + (mapconcat #'char-to-string + (make-string (max 0 (1- level)) ?|) " ") + (if (> level 1) " " "") + level + ;; FIXME: Make it so we can click the function name to + ;; jump to its definition and/or untrace it. + (cl-prin1-to-string (cons function args)) + ctx))))) + +(defun trace--exit-message (function level value context) "Generate a string that describes that FUNCTION has exited. -LEVEL is the trace level, VALUE value returned by FUNCTION, -and CONTEXT is a string describing the dynamic context (e.g. values of -some global variables)." - (let ((print-circle t) - (print-escape-newlines t)) - (format "%s%s%d <- %s: %s%s\n" - (mapconcat 'char-to-string (make-string (1- level) ?|) " ") - (if (> level 1) " " "") - level - function - ;; Do this so we'll see strings: - (cl-prin1-to-string value) - context))) +LEVEL is the trace level, VALUE value returned by FUNCTION." + (unless inhibit-trace + (trace--insert + (let ((ctx (funcall context)) + (print-circle t) + (print-escape-newlines t)) + (format "%s%s%d <- %s: %s%s\n" + (mapconcat 'char-to-string (make-string (1- level) ?|) " ") + (if (> level 1) " " "") + level + function + ;; Do this so we'll see strings: + (cl-prin1-to-string value) + ctx))))) (defvar trace--timer nil) @@ -208,43 +207,40 @@ some global variables)." (setq trace--timer nil) (display-buffer buf nil 0)))))) +(defun trace--insert (msg) + (if noninteractive + (message "%s" (if (eq ?\n (aref msg (1- (length msg)))) + (substring msg 0 -1) msg)) + (with-current-buffer trace-buffer + (setq-local window-point-insertion-type t) + (goto-char (point-max)) + (let ((deactivate-mark nil)) ;Protect deactivate-mark. + (insert msg))))) (defun trace-make-advice (function buffer background context) "Build the piece of advice to be added to trace FUNCTION. FUNCTION is the name of the traced function. BUFFER is the buffer where the trace should be printed. BACKGROUND if nil means to display BUFFER. -CONTEXT if non-nil should be a function that returns extra info that should -be printed along with the arguments in the trace." +CONTEXT should be a function that returns extra text that should +be printed after the arguments in the trace." (lambda (body &rest args) (let ((trace-level (1+ trace-level)) - (trace-buffer (get-buffer-create buffer)) - (deactivate-mark nil) ;Protect deactivate-mark. - (ctx (funcall context))) + (trace-buffer (get-buffer-create buffer))) + ;; Insert a separator from previous trace output: (unless inhibit-trace - (with-current-buffer trace-buffer - (setq-local window-point-insertion-type t) - (unless background (trace--display-buffer trace-buffer)) - (goto-char (point-max)) - ;; Insert a separator from previous trace output: - (if (= trace-level 1) (insert trace-separator)) - (insert - (trace-entry-message - function trace-level args ctx)))) + (unless background (trace--display-buffer trace-buffer)) + (if (= trace-level 1) (trace--insert trace-separator))) + (trace--entry-message + function trace-level args context) (let ((result)) (unwind-protect (setq result (list (apply body args))) - (unless inhibit-trace - (let ((ctx (funcall context))) - (with-current-buffer trace-buffer - (unless background (trace--display-buffer trace-buffer)) - (goto-char (point-max)) - (insert - (trace-exit-message - function - trace-level - (if result (car result) '\!non-local\ exit\!) - ctx)))))) + (trace--exit-message + function + trace-level + (if result (car result) '\!non-local\ exit\!) + context)) (car result))))) (defun trace-function-internal (function buffer background context) diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 02020552e7f..d8e5136c666 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -283,8 +283,16 @@ If it can't be found, return nil and don't move point." (goto-char (prop-match-beginning match)) (end-of-line))) -(defun vtable-update-object (table object old-object) - "Replace OLD-OBJECT in TABLE with OBJECT." +(defun vtable-update-object (table object &optional old-object) + "Update OBJECT's representation in TABLE. +If OLD-OBJECT is non-nil, replace OLD-OBJECT with OBJECT and display it. +In either case, if the existing object is not found in the table (being +compared with `equal'), signal an error. Note a limitation: if TABLE's +buffer is not in a visible window, or if its window has changed width +since it was updated, updating the TABLE is not possible, and an error +is signaled." + (unless old-object + (setq old-object object)) (let* ((objects (vtable-objects table)) (inhibit-read-only t)) ;; First replace the object in the object storage. @@ -300,26 +308,31 @@ If it can't be found, return nil and don't move point." (error "Can't find the old object")) (setcar (cdr objects) object)) ;; Then update the cache... - (let* ((line-number (seq-position old-object (car (vtable--cache table)))) - (line (elt (car (vtable--cache table)) line-number))) - (unless line - (error "Can't find cached object")) - (setcar line object) - (setcdr line (vtable--compute-cached-line table object)) - ;; ... and redisplay the line in question. - (save-excursion - (vtable-goto-object old-object) - (let ((keymap (get-text-property (point) 'keymap)) - (start (point))) - (delete-line) - (vtable--insert-line table line line-number - (nth 1 (vtable--cache table)) - (vtable--spacer table)) - (add-text-properties start (point) (list 'keymap keymap - 'vtable table)))) - ;; We may have inserted a non-numerical value into a previously - ;; all-numerical table, so recompute. - (vtable--recompute-numerical table (cdr line))))) + ;; FIXME: If the table's buffer has no visible window, or if its + ;; width has changed since the table was updated, the cache key will + ;; not match and the object can't be updated. (Bug #69837). + (if-let ((line-number (seq-position (car (vtable--cache table)) old-object + (lambda (a b) + (equal (car a) b)))) + (line (elt (car (vtable--cache table)) line-number))) + (progn + (setcar line object) + (setcdr line (vtable--compute-cached-line table object)) + ;; ... and redisplay the line in question. + (save-excursion + (vtable-goto-object old-object) + (let ((keymap (get-text-property (point) 'keymap)) + (start (point))) + (delete-line) + (vtable--insert-line table line line-number + (nth 1 (vtable--cache table)) + (vtable--spacer table)) + (add-text-properties start (point) (list 'keymap keymap + 'vtable table)))) + ;; We may have inserted a non-numerical value into a previously + ;; all-numerical table, so recompute. + (vtable--recompute-numerical table (cdr line))) + (error "Can't find cached object in vtable")))) (defun vtable-remove-object (table object) "Remove OBJECT from TABLE. @@ -741,7 +754,7 @@ If NEXT, do the next column." (seq-do-indexed (lambda (elem index) (when (and (vtable-column--numerical (elt columns index)) - (not (numberp elem))) + (not (numberp (car elem)))) (setq recompute t))) line) (when recompute |