[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master 1faeef7924 1/2: (compiled-function-p): New function (bug#56648)
|
From: |
Stefan Monnier |
|
Subject: |
master 1faeef7924 1/2: (compiled-function-p): New function (bug#56648) |
|
Date: |
Sun, 14 Aug 2022 12:30:10 -0400 (EDT) |
branch: master
commit 1faeef7924c535e9003b617b723b85567a821f5c
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
(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 (<toplevel-end>):
* 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 ++++++
test/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 0a9fd5108c..78dd1c3728 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 8265e58210..a7ce3270f5 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 1bae192455..7b5e9adee2 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 a455b88f6b..0584403d8c 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 1e52b1f850..a6cf8d89a4 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 391743d715..d383650f4e 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 fdeb5db0ec..52e0095284 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 9d5f6682b5..907015eb48 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))
"<malformed function>")
((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)))))
" <compiled macro>"
" <macro>"))
((assq 'byte-code (cdr (cdr f)))
+ ;; FIXME: Can this still happen?
"<compiled lambda>")
((eq 'lambda (car f))
"<function>")
@@ -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 eefaa36b91..80ca43c902 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 6a193a56d2..5ae9d8368f 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 07443dabfe..10bd4bc688 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 b036978efa..0afd873a5d 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 59a509b221..74e18285e6 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 8dad382ac0..17e82cc0c4 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 93af525e39..a61620b276 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 4b1fc832da..42ce9148a9 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 27a4e70c78..774a3ea7ec 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