From 1faeef7924c535e9003b617b723b85567a821f5c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 14 Aug 2022 12:28:37 -0400 Subject: [PATCH] (compiled-function-p): New function (bug#56648) * lisp/subr.el (compiled-function-p): New function. * test/lisp/international/ucs-normalize-tests.el (ucs-normalize-part1): * lisp/gnus/gnus.el (gnus): * lisp/mh-e/mh-e.el (mh-version): * lisp/emacs-lisp/macroexp.el (emacs-startup-hook): * lisp/emacs-lisp/cl-macs.el (compiled-function): * lisp/emacs-lisp/bytecomp.el (byte-compile-fdefinition) (byte-compile, display-call-tree): * lisp/emacs-lisp/byte-opt.el (): * lisp/emacs-lisp/advice.el (ad-compiled-p): * lisp/cedet/semantic/bovine.el (semantic-bovinate-stream): * lisp/loadup.el (macroexpand-all): * admin/unidata/unidata-gen.el (unidata--ensure-compiled): Use it. * lisp/emacs-lisp/pcase.el (pcase-mutually-exclusive-predicates): Add entries for it. (pcase--split-pred): Use it. * lisp/help-fns.el (help-fns-function-description-header): Use `functionp`. (help-fns--var-safe-local): Use `compiled-function-p`. --- admin/unidata/unidata-gen.el | 4 ++-- doc/lispref/functions.texi | 5 ++++ doc/lispref/objects.texi | 3 +++ etc/NEWS | 3 +++ lisp/cedet/semantic/bovine.el | 4 ++-- lisp/emacs-lisp/advice.el | 14 +++++------ lisp/emacs-lisp/byte-opt.el | 3 +-- lisp/emacs-lisp/bytecomp.el | 24 +++++++++---------- lisp/emacs-lisp/cl-macs.el | 2 +- lisp/emacs-lisp/macroexp.el | 2 +- lisp/emacs-lisp/pcase.el | 13 +++++++--- lisp/gnus/gnus.el | 3 +-- lisp/help-fns.el | 10 ++++---- lisp/loadup.el | 3 +-- lisp/mh-e/mh-e.el | 4 ++-- lisp/subr.el | 6 +++++ .../lisp/international/ucs-normalize-tests.el | 2 +- 17 files changed, 63 insertions(+), 42 deletions(-) diff --git a/admin/unidata/unidata-gen.el b/admin/unidata/unidata-gen.el index 0a9fd5108ce..78dd1c37288 100644 --- a/admin/unidata/unidata-gen.el +++ b/admin/unidata/unidata-gen.el @@ -1083,8 +1083,8 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (defun unidata--ensure-compiled (&rest funcs) (dolist (fun funcs) - (or (byte-code-function-p (symbol-function fun)) - (byte-compile fun)))) + (unless (compiled-function-p (symbol-function fun)) + (byte-compile fun)))) (defun unidata-gen-table-name (prop index &rest _ignore) (let* ((table (unidata-gen-table-word-list prop index 'unidata-split-name)) diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index 8265e58210e..a7ce3270f5f 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -217,6 +217,11 @@ function. For example: @end example @end defun +@defun compiled-function-p object +This function returns @code{t} if @var{object} is a function object +implemented in byte-code or machine code. +@end defun + @defun subr-arity subr This works like @code{func-arity}, but only for built-in functions and without symbol indirection. It signals an error for non-built-in diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index 1bae1924557..7b5e9adee29 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -2022,6 +2022,9 @@ with references to further information. @item byte-code-function-p @xref{Byte-Code Type, byte-code-function-p}. +@item compiled-function-p +@xref{Byte-Code Type, compiled-function-p}. + @item case-table-p @xref{Case Tables, case-table-p}. diff --git a/etc/NEWS b/etc/NEWS index a455b88f6bb..0584403d8c7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2571,6 +2571,9 @@ patcomp.el, pc-mode.el, pc-select.el, s-region.el, and sregex.el. * Lisp Changes in Emacs 29.1 ++++ +** New function 'compile-function-p'. + --- ** 'deactivate-mark' can have new value 'dont-save'. This value means that Emacs should deactivate the mark as usual, but diff --git a/lisp/cedet/semantic/bovine.el b/lisp/cedet/semantic/bovine.el index 1e52b1f8504..a6cf8d89a4f 100644 --- a/lisp/cedet/semantic/bovine.el +++ b/lisp/cedet/semantic/bovine.el @@ -143,14 +143,14 @@ list of semantic tokens found." cvl nil ;re-init the collected value list. lte (car matchlist) ;Get the local matchlist entry. ) - (if (or (byte-code-function-p (car lte)) + (if (or (compiled-function-p (car lte)) (listp (car lte))) ;; In this case, we have an EMPTY match! Make ;; stuff up. (setq cvl (list nil)))) (while (and lte - (not (byte-code-function-p (car lte))) + (not (compiled-function-p (car lte))) (not (listp (car lte)))) ;; GRAMMAR SOURCE DEBUGGING! diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 391743d7156..d383650f4e5 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1054,9 +1054,9 @@ ;; (print "Let's clean up now!")) ;; foo ;; -;; Now `foo's advice is byte-compiled: +;; Now `foo's advice is compiled: ;; -;; (byte-code-function-p 'ad-Advice-foo) +;; (compiled-function-p 'ad-Advice-foo) ;; t ;; ;; (foo 3) @@ -1298,7 +1298,7 @@ ;; constructed during preactivation was used, even though we did not specify ;; the `compile' flag: ;; -;; (byte-code-function-p 'ad-Advice-fum) +;; (compiled-function-p 'ad-Advice-fum) ;; t ;; ;; (fum 2) @@ -1329,7 +1329,7 @@ ;; ;; A new uncompiled advised definition got constructed: ;; -;; (byte-code-function-p 'ad-Advice-fum) +;; (compiled-function-p 'ad-Advice-fum) ;; nil ;; ;; (fum 2) @@ -2116,9 +2116,9 @@ the cache-id will clear the cache." (defsubst ad-compiled-p (definition) "Return non-nil if DEFINITION is a compiled byte-code object." - (or (byte-code-function-p definition) - (and (macrop definition) - (byte-code-function-p (ad-lambdafy definition))))) + (or (compiled-function-p definition) + (and (macrop definition) + (compiled-function-p (ad-lambdafy definition))))) (defsubst ad-compiled-code (compiled-definition) "Return the byte-code object of a COMPILED-DEFINITION." diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index fdeb5db0ece..52e00952846 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -2479,8 +2479,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; itself, compile some of its most used recursive functions (at load time). ;; (eval-when-compile - (or (byte-code-function-p (symbol-function 'byte-optimize-form)) - (subr-native-elisp-p (symbol-function 'byte-optimize-form)) + (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)) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 9d5f6682b5a..907015eb48e 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1395,7 +1395,7 @@ when printing the error message." (or (symbolp (symbol-function fn)) (consp (symbol-function fn)) (and (not macro-p) - (byte-code-function-p (symbol-function fn))))) + (compiled-function-p (symbol-function fn))))) (setq fn (symbol-function fn))) (let ((advertised (gethash (if (and (symbolp fn) (fboundp fn)) ;; Could be a subr. @@ -1407,7 +1407,7 @@ when printing the error message." (if macro-p `(macro lambda ,advertised) `(lambda ,advertised))) - ((and (not macro-p) (byte-code-function-p fn)) fn) + ((and (not macro-p) (compiled-function-p fn)) fn) ((not (consp fn)) nil) ((eq 'macro (car fn)) (cdr fn)) (macro-p nil) @@ -2946,11 +2946,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." (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 tune down the complaint from an - ;; error to a simple message for the known case where signaling an error - ;; causes problems. - ((byte-code-function-p fun) + ;; 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) @@ -3527,7 +3527,7 @@ lambda-expression." (byte-compile-out-tag endtag))) (defun byte-compile-unfold-bcf (form) - "Inline call to byte-code-functions." + "Inline call to byte-code function." (let* ((byte-compile-bound-variables byte-compile-bound-variables) (fun (car form)) (fargs (aref fun 0)) @@ -5254,11 +5254,13 @@ invoked interactively." ((not (consp f)) "") ((eq 'macro (car f)) - (if (or (byte-code-function-p (cdr f)) + (if (or (compiled-function-p (cdr f)) + ;; FIXME: Can this still happen? (assq 'byte-code (cdr (cdr (cdr f))))) " " " ")) ((assq 'byte-code (cdr (cdr f))) + ;; FIXME: Can this still happen? "") ((eq 'lambda (car f)) "") @@ -5507,9 +5509,7 @@ and corresponding effects." ;; itself, compile some of its most used recursive functions (at load time). ;; (eval-when-compile - (or (byte-code-function-p (symbol-function 'byte-compile-form)) - (subr-native-elisp-p (symbol-function 'byte-compile-form)) - (assq 'byte-code (symbol-function 'byte-compile-form)) + (or (compiled-function-p (symbol-function 'byte-compile-form)) (let ((byte-optimize nil) ; do it fast (byte-compile-warnings nil)) (mapc (lambda (x) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index eefaa36b911..80ca43c902a 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3411,7 +3411,7 @@ Of course, we really can't know that for sure, so it's just a heuristic." (character . natnump) (char-table . char-table-p) (command . commandp) - (compiled-function . byte-code-function-p) + (compiled-function . compiled-function-p) (hash-table . hash-table-p) (cons . consp) (fixnum . fixnump) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 6a193a56d2d..5ae9d8368f0 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -823,7 +823,7 @@ test of free variables in the following ways: (eval-when-compile (add-hook 'emacs-startup-hook (lambda () - (and (not (byte-code-function-p + (and (not (compiled-function-p (symbol-function 'macroexpand-all))) (locate-library "macroexp.elc") (load "macroexp.elc"))))) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 07443dabfef..10bd4bc6886 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -607,31 +607,38 @@ recording whether the var has been referenced by earlier parts of the match." (symbolp . vectorp) (symbolp . stringp) (symbolp . byte-code-function-p) + (symbolp . compiled-function-p) (symbolp . 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 . byte-code-function-p) + (stringp . compiled-function-p))) (defun pcase--mutually-exclusive-p (pred1 pred2) (or (member (cons pred1 pred2) @@ -771,8 +778,8 @@ A and B can be one of: ((consp (cadr pat)) #'consp) ((stringp (cadr pat)) #'stringp) ((vectorp (cadr pat)) #'vectorp) - ((byte-code-function-p (cadr pat)) - #'byte-code-function-p)))) + ((compiled-function-p (cadr pat)) + #'compiled-function-p)))) (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)))) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index b036978efa8..0afd873a5df 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -4166,8 +4166,7 @@ prompt the user for the name of an NNTP server to use." ;; file. (unless (string-match "^Gnus" gnus-version) (load "gnus-load" nil t)) - (unless (or (byte-code-function-p (symbol-function 'gnus)) - (subr-native-elisp-p (symbol-function 'gnus))) + (unless (compiled-function-p (symbol-function 'gnus)) (message "You should compile Gnus") (sit-for 2)) (let ((gnus-action-message-log (list nil))) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 59a509b2215..74e18285e64 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -1005,9 +1005,9 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (help-fns--analyze-function function)) (file-name (find-lisp-object-file-name function (if aliased 'defun def))) - (beg (if (and (or (byte-code-function-p def) + (beg (if (and (or (functionp def) (keymapp def) - (memq (car-safe def) '(macro lambda closure))) + (eq (car-safe def) 'macro)) (stringp file-name) (help-fns--autoloaded-p function)) (concat @@ -1040,7 +1040,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (t "Lisp function")))) ((or (eq (car-safe def) 'macro) ;; For advised macros, def is a lambda - ;; expression or a byte-code-function-p, so we + ;; expression or a compiled-function-p, so we ;; need to check macros before functions. (macrop function)) (concat beg "Lisp macro")) @@ -1534,8 +1534,8 @@ This cancels value editing without updating the value." (when safe-var (princ " This variable is safe as a file local variable ") (princ "if its value\n satisfies the predicate ") - (princ (if (byte-code-function-p safe-var) - "which is a byte-compiled expression.\n" + (princ (if (compiled-function-p safe-var) + "which is a compiled expression.\n" (format-message "`%s'.\n" safe-var)))))) (add-hook 'help-fns-describe-variable-functions #'help-fns--var-risky) diff --git a/lisp/loadup.el b/lisp/loadup.el index 8dad382ac0d..17e82cc0c49 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -154,8 +154,7 @@ ;; Load-time macro-expansion can only take effect after setting ;; load-source-file-function because of where it is called in lread.c. (load "emacs-lisp/macroexp") -(if (or (byte-code-function-p (symbol-function 'macroexpand-all)) - (subr-native-elisp-p (symbol-function 'macroexpand-all))) +(if (compiled-function-p (symbol-function 'macroexpand-all)) nil ;; Since loaddefs is not yet loaded, macroexp's uses of pcase will simply ;; fail until pcase is explicitly loaded. This also means that we have to diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el index 93af525e39d..a61620b2761 100644 --- a/lisp/mh-e/mh-e.el +++ b/lisp/mh-e/mh-e.el @@ -388,11 +388,11 @@ gnus-version) (insert "MH-E " mh-version "\n\n") ;; MH-E compilation details. (insert "MH-E compilation details:\n") - (let* ((compiled-mhe (byte-code-function-p (symbol-function 'mh-version))) + (let* ((compiled-mhe (compiled-function-p (symbol-function 'mh-version))) (gnus-compiled-version (if compiled-mhe (mh-macro-expansion-time-gnus-version) "N/A"))) - (insert " Byte compiled:\t\t" (if compiled-mhe "yes" "no") "\n" + (insert " Compiled:\t\t" (if compiled-mhe "yes" "no") "\n" " Gnus (compile-time):\t" gnus-compiled-version "\n" " Gnus (run-time):\t" (mh-run-time-gnus-version) "\n\n")) ;; Emacs version. diff --git a/lisp/subr.el b/lisp/subr.el index 4b1fc832da1..42ce9148a90 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4077,6 +4077,12 @@ Otherwise, return nil." (or (eq 'macro (car def)) (and (autoloadp def) (memq (nth 4 def) '(macro t))))))) +(defun compiled-function-p (object) + "Return non-nil if OBJECT is a function that has been compiled. +Does not distinguish between functions implemented in machine code +or byte-code." + (or (subrp object) (byte-code-function-p object))) + (defun field-at-pos (pos) "Return the field at position POS, taking stickiness etc into account." (let ((raw-field (get-char-property (field-beginning pos) 'field))) diff --git a/test/lisp/international/ucs-normalize-tests.el b/test/lisp/international/ucs-normalize-tests.el index 27a4e70c78e..774a3ea7ec9 100644 --- a/test/lisp/international/ucs-normalize-tests.el +++ b/test/lisp/international/ucs-normalize-tests.el @@ -246,7 +246,7 @@ must be true for all conformant implementations: ucs-normalize-tests--rule1-failing-for-partX ucs-normalize-tests--rule1-holds-p ucs-normalize-tests--rule2-holds-p)) - (or (byte-code-function-p (symbol-function fun)) + (or (compiled-function-p (symbol-function fun)) (byte-compile fun))) (let ((ucs-normalize-tests--chars-part1 (make-char-table 'ucs-normalize-tests t))) (setq ucs-normalize-tests--part1-rule1-failed-lines -- 2.39.5