master: Make FDEFINITION not strip encapsulation
melisgl via Sbcl-commits <[email protected]> Sat, 30 May 2026 10:17:56 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via d9b4878a31c6dee5561f0df1f5c533bef65289aa (commit)
from 6f4581f924cc164a7e9754036841421e57666b8b (commit)
- Log -----------------------------------------------------------------
commit d9b4878a31c6dee5561f0df1f5c533bef65289aa
Author: Gabor Melis <[email protected]>
Date: Thu May 21 09:54:34 2026 +0200
Make FDEFINITION not strip encapsulation
This fixes the ANSI non-compliance passed down from early
CMUCL (1991-10-31). The bug was that FDEFINITION did not return the
same value as SYMBOL-FUNCTION for symbols (lp#799533). The fix is an
incompatible change but only affects encapsulated (e.g. TRACEd and
SP-PROFILE:PROFILEd) non-generic functions.
However, encapsulations belong to the definition (the name) and not to
the function associated with the name, so (SETF (FDEFINITION NAME) FN)
strips encapsulations from FN and keeps the encapsulations of NAME.
- SB-EXT:UNENCAPSULATED-FUNCTION was added.
- Encapsulated functions are printed as
#<FUNCTION FOO ENCAPSULATED>
or, if they have no proper name, as
#<FUNCTION FOO ENCAPSULATED {B1782332}>
This is the same as for unencapsulated functions except for the
additional " ENCAPSULATED".
- Unused slots were removed from SB-PROFILE:PROFILE-INFO.
- Since generic function identity is stable in face of encapsulation,
CLOS is largely unaffected by this change.
---
NEWS | 4 ++
TODO | 5 +-
contrib/sb-introspect/introspect.lisp | 7 +--
doc/manual/beyond-ansi.texinfo | 1 +
src/code/fdefinition.lisp | 83 +++++++++++++---------------
src/code/full-eval.lisp | 6 --
src/code/ntrace.lisp | 4 +-
src/code/print.lisp | 15 +++--
src/code/profile.lisp | 27 ++++-----
src/code/symbol.lisp | 16 +-----
src/cold/exports.lisp | 1 +
src/pcl/defs.lisp | 7 +--
src/pcl/documentation.lisp | 3 +-
tests/ansi-tests.sh | 2 +-
tests/trace.impure.lisp | 101 +++++++++++++++++++++++++++++++++-
15 files changed, 176 insertions(+), 106 deletions(-)
diff --git a/NEWS b/NEWS
index 7f4cc04bc..e8178a80e 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,9 @@
;;;; -*- coding: utf-8; fill-column: 78 -*-
+changes relative to sbcl-2.6.5:
+ * minor incompatible change: FDEFINITION now returns the outermost wrapper
+ (added e.g. by TRACE, PROFILE) like SYMBOL-FUNCTION. (lp#799533)
+
changes in sbcl-2.6.5 relative to sbcl-2.6.4:
* minor incompatible change: the condition signalled when an accessed slot
is missing from an object is no longer a TYPE-ERROR.
diff --git a/TODO b/TODO
index 1c88ea5e7..fd349ea58 100644
--- a/TODO
+++ b/TODO
@@ -65,10 +65,7 @@ ADVICE/FWRAP
SBCL has an internal function encapsulation mechanism, and is able to
install breakpoint to function start/end -- this is used to implement
the instrumentation based profiler and tracing. It would be good to
- have this as an exported interface, and it would be good if the
- SYMBOL-FUNCTION / FDEFINITION confusion was fixed: currently the
- latter returns the underlying definition, whereas the first returns
- the encapsulation.
+ have this as an exported interface.
POLICY MADNESS
diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index 2b3536c92..fb2c5c420 100644
--- a/contrib/sb-introspect/introspect.lisp
+++ b/contrib/sb-introspect/introspect.lisp
@@ -256,12 +256,7 @@ will return NIL."
(and (symbolp name)
(find-class name nil)))
(real-fdefinition (name)
- ;; for getting the real function object, even if the
- ;; function is being profiled
- (let ((profile-info (gethash name sb-profile::*profiled-fun-name->info*)))
- (if profile-info
- (sb-profile::profile-info-encapsulated-fun profile-info)
- (fdefinition name)))))
+ (sb-ext:unencapsulated-function name)))
(ensure-list
(case type
((:variable)
diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo
index 5cf2b8461..6ffb2cbfe 100644
--- a/doc/manual/beyond-ansi.texinfo
+++ b/doc/manual/beyond-ansi.texinfo
@@ -1435,6 +1435,7 @@ and its context.
@include fun-sb-ext-delete-directory.texinfo
@include fun-sb-ext-get-time-of-day.texinfo
@include fun-sb-ext-assert-version-gt=.texinfo
+@include fun-sb-ext-unencapsulated-function.texinfo
@node Stale Extensions
@comment node-name, next, previous, up
diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp
index 8b5ab06b3..3bdb4b5c2 100644
--- a/src/code/fdefinition.lisp
+++ b/src/code/fdefinition.lisp
@@ -140,9 +140,8 @@
(clear-info :function :type name))))
;;; Return the fdefn-fun of NAME's fdefinition including any
-;;; encapsulations. This is the core of the implementation of the standard
-;;; FDEFINITION function, but as we've defined FDEFINITION, that
-;;; strips encapsulations.
+;;; encapsulations. This is the core of the implementation of the
+;;; standard FDEFINITION function.
(defun %coerce-name-to-fun (name)
(typecase name
((and symbol (not null))
@@ -202,7 +201,11 @@
(setf (symbol-function '%coerce-callable-for-call) (symbol-function '%coerce-callable-to-fun))
-;;;; definition encapsulation
+;;;; Function definition encapsulation
+;;;;
+;;;; The API is based on names to allow the associated function object
+;;;; to be changed. We do this for normal functions. For generic
+;;;; functions, we mutate the object.
(defstruct (encapsulation-info (:constructor make-encapsulation-info
(type definition))
@@ -303,55 +306,45 @@
(when specialized-xep
(fset (%fun-name specialized-xep) specialized-xep)))))))))
+(defun unencapsulated-function (function)
+ "Return the innermost function within any encapsulations of the
+ function designated by FUNCTION. The identity of the returned
+ function is not affected by encapsulations.
+
+ Note that the unencapsulated function may be EQ to the designated
+ function even in the presence of encapsulations. For generic
+ functions, this is currently always the case."
+ (let ((fun (if (functionp function)
+ function
+ (fdefinition function))))
+ (loop
+ (let ((encap-info (encapsulation-info fun)))
+ (if encap-info
+ (setf fun (encapsulation-info-definition encap-info))
+ (return fun))))))
;;;; FDEFINITION
-;;; KLUDGE: Er, it looks as though this means that
-;;; (FUNCALL (FDEFINITION 'FOO))
-;;; doesn't do the same thing as
-;;; (FUNCALL 'FOO),
-;;; and (SYMBOL-FUNCTION 'FOO) isn't in general the same thing
-;;; as (FDEFINITION 'FOO). That doesn't look like ANSI behavior to me.
-;;; Look e.g. at the ANSI definition of TRACE: "Whenever a traced
-;;; function is invoked, information about the call, ..". Try this:
-;;; (DEFUN FOO () (PRINT "foo"))
-;;; (TRACE FOO)
-;;; (FUNCALL 'FOO)
-;;; (FUNCALL (FDEFINITION 'FOO))
-;;; What to do? ANSI says TRACE "Might change the definitions of the
-;;; functions named by function-names." Might it be OK to just get
-;;; punt all this encapsulation stuff and go back to a simple but
-;;; correct implementation of TRACE? We'd lose the ability to redefine
-;;; a TRACEd function and keep the trace in place, but that seems
-;;; tolerable to me. (Is the wrapper stuff needed for anything else
-;;; besides TRACE?)
-;;;
-;;; The only problem I can see with not having a wrapper: If tracing
-;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change,
-;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests
-;;; on those function values. But given the ANSI statement about
-;;; TRACE causing things to change, that doesn't seem too unreasonable;
-;;; and we might even be able to forbid tracing these functions.
-;;; -- WHN 2001-11-02
(defun fdefinition (name)
- "Return name's global function definition taking care to respect any
- encapsulations and to return the innermost encapsulated definition.
- This is SETF'able."
+ "Return the global function associated with NAME. SETFable.
+
+ Note that encapsulations (e.g. by TRACE and SB-PROFILE:PROFILE)
+ can change the global function definition. FDEFINITION always returns
+ outermost encapsulation. SB-EXT:UNENCAPSULATED-FUNCTION may be used
+ to get the innermost function.
+
+ When SETFed, NAME's encapsulations are kept and the innermost
+ encapsulated function is replaced by the new value (stripped from
+ any encapsulations)."
(declare (explicit-check))
;; %COERCE-NAME-TO-FUN signals an error for macros and special operators,
;; but FDEFINITION should not, so pick off symbols using %SYMBOL-FUNCTION.
- (strip-encapsulation (or (and (symbolp name) (%symbol-function name))
- (%coerce-name-to-fun name))))
-(defun strip-encapsulation (fun)
- (loop
- (let ((encap-info (encapsulation-info fun)))
- (if encap-info
- (setf fun (encapsulation-info-definition encap-info))
- (return fun)))))
+ (or (and (symbolp name) (%symbol-function name))
+ (%coerce-name-to-fun name)))
(define-load-time-global *setf-fdefinition-hook* nil
"A list of functions that (SETF FDEFINITION) invokes before storing the
- new value. The functions take the function name and the new value.")
+ new value. The functions take the function name and the new value.")
;; Reject any "object of implementation-dependent nature" that
;; so happens to be a function in SBCL, but which must not be
@@ -379,8 +372,7 @@
(defun setf-fdefinition (new-value name clear-specialized-xep)
(declare (type function new-value) (optimize (safety 1)))
(declare (explicit-check))
- (err-if-unacceptable-function new-value '(setf fdefinition))
- (setq new-value (strip-encapsulation new-value))
+ (setq new-value (unencapsulated-function new-value))
(with-single-package-locked-error (:symbol name "setting fdefinition of ~A")
(maybe-clobber-ftype name new-value)
@@ -420,6 +412,7 @@
"Set NAME's global function definition."
(declare (type function new-value) (optimize (safety 1)))
(declare (explicit-check))
+ (err-if-unacceptable-function new-value '(setf fdefinition))
(setf-fdefinition new-value name t))
;;;; FBOUNDP and FMAKUNBOUND
diff --git a/src/code/full-eval.lisp b/src/code/full-eval.lisp
index 9ab5b10f7..5def39e28 100644
--- a/src/code/full-eval.lisp
+++ b/src/code/full-eval.lisp
@@ -622,12 +622,6 @@
(interpreted-apply function args)))
function))
-(defmethod print-object ((obj interpreted-function) stream)
- (print-unreadable-object (obj stream
- :identity (not (interpreted-function-name obj)))
- (format stream "~A ~A" '#:interpreted-function
- (interpreted-function-name obj))))
-
;;; Create an interpreted function from the lambda-form EXP evaluated
;;; in the environment ENV.
(defun eval-lambda (exp env)
diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp
index 49a9effbd..5f4934a54 100644
--- a/src/code/ntrace.lisp
+++ b/src/code/ntrace.lisp
@@ -151,7 +151,9 @@
(cond ((not valid)
(warn "~S is not a valid function name, not tracing." x))
((fboundp x)
- (values (or definition (fdefinition x)) block-name :function))
+ (values (sb-ext:unencapsulated-function
+ (or definition (fdefinition x)))
+ block-name :function))
(t
(warn "~/sb-ext:print-symbol-with-prefix/ is ~
undefined, not tracing." x)))))))
diff --git a/src/code/print.lisp b/src/code/print.lisp
index c7499cf24..9ba59ba2c 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -2084,16 +2084,21 @@ variable: an unreadable object representing the error is printed instead.")
(when (unprintable-instance-p object)
(return-from print-object
(print-unreadable-object (object stream :type t :identity t)))))
- (let* ((name (%fun-name object))
+ (let* ((unencapsulated (sb-ext:unencapsulated-function object))
+ (name (%fun-name unencapsulated))
(proper-name-p (and (legal-fun-name-p name) (fboundp name)
(eq (fdefinition name) object))))
;; ":TYPE T" is no good, since CLOSURE doesn't have full-fledged status.
(print-unreadable-object (object stream :identity (not proper-name-p))
- (format stream "~A~@[ ~S~]"
- ;; CLOSURE and SIMPLE-FUN should print as #<FUNCTION>
+ (format stream "~A~@[ ~S~]~:[ ENCAPSULATED~;~]"
+ ;; CLOSURE and SIMPLE-FUN should print as #<FUNCTION>,
;; but anything else prints as its exact type.
- (if (funcallable-instance-p object) (type-of object) 'function)
- name))))
+ (if (or (funcallable-instance-p object)
+ (typep object 'sb-kernel:interpreted-function))
+ (type-of object)
+ 'function)
+ name
+ (eq unencapsulated object)))))
;;;; catch-all for unknown things
diff --git a/src/code/profile.lisp b/src/code/profile.lisp
index 6478ab893..3af48279f 100644
--- a/src/code/profile.lisp
+++ b/src/code/profile.lisp
@@ -88,8 +88,6 @@
:synchronized t))
(defstruct (profile-info (:copier nil))
(name (missing-arg) :read-only t)
- (encapsulated-fun (missing-arg) :type function :read-only t)
- (encapsulation-fun (missing-arg) :type function :read-only t)
(read-stats-fun (missing-arg) :type function :read-only t)
(clear-stats-fun (missing-arg) :type function :read-only t))
(declaim (freeze-type profile-info))
@@ -144,8 +142,8 @@
;;; Return a collection of closures over the same lexical context,
;;; (VALUES ENCAPSULATION-FUN READ-STATS-FUN CLEAR-STATS-FUN).
;;;
-;;; ENCAPSULATION-FUN is a plug-in replacement for ENCAPSULATED-FUN,
-;;; which updates statistics whenever it's called.
+;;; ENCAPSULATION-FUN is function similar to APPLY, but it also
+;;; updates statistics whenever it's called.
;;;
;;; READ-STATS-FUN returns the statistics:
;;; (VALUES COUNT TIME CONSING PROFILE).
@@ -265,18 +263,15 @@
;;; Profile the named function, which should exist and not be profiled
;;; already.
(defun profile-1-unprofiled-fun (name)
- (let ((encapsulated-fun (fdefinition name)))
- (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
- (profile-encapsulation-lambdas)
- (without-package-locks
- (encapsulate name 'profile encapsulation-fun))
- (setf (gethash name *profiled-fun-name->info*)
- (make-profile-info :name name
- :encapsulated-fun encapsulated-fun
- :encapsulation-fun encapsulation-fun
- :read-stats-fun read-stats-fun
- :clear-stats-fun clear-stats-fun))
- (values))))
+ (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
+ (profile-encapsulation-lambdas)
+ (without-package-locks
+ (encapsulate name 'profile encapsulation-fun))
+ (setf (gethash name *profiled-fun-name->info*)
+ (make-profile-info :name name
+ :read-stats-fun read-stats-fun
+ :clear-stats-fun clear-stats-fun))
+ (values)))
;;; Profile the named function. If already profiled, unprofile first.
(defun profile-1-fun (name)
diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp
index 6d1abac2e..83dcdd9ed 100644
--- a/src/code/symbol.lisp
+++ b/src/code/symbol.lisp
@@ -119,7 +119,8 @@ distinct from the global value. Can also be SETF."
(defun (setf %symbol-function) (newval symbol) (fset symbol newval))
(defun symbol-function (symbol)
- "Return SYMBOL's current function definition. Settable with SETF."
+ "Return SYMBOL's current function definition. SETFable. Behaves
+ identically to FDEFINITION for symbol arguments."
(truly-the function (or (%symbol-function symbol) ; fast way
(%coerce-name-to-fun symbol)))) ; fallback w/restart
@@ -133,22 +134,11 @@ distinct from the global value. Can also be SETF."
;; 2. (SETF (SYMBOL-FUNCTION 'I-ONCE-WAS-A-MACRO) #'CONS)
;; should _probably_ make I-ONCE-WAS-A-MACRO not a macro
(defun (setf symbol-function) (new-value symbol)
- (declare (type symbol symbol) (type function new-value))
;; (SYMBOL-FUNCTION symbol) == (FDEFINITION symbol) according to the writeup
;; on SYMBOL-FUNCTION. It doesn't say that SETF behaves the same, but let's
;; assume it does, and that we can't assign our macro/special guard funs.
(err-if-unacceptable-function new-value '(setf symbol-function))
- (setq new-value (strip-encapsulation new-value))
- (with-single-package-locked-error
- (:symbol symbol "setting the symbol-function of ~A")
- ;; This code is a little "surprising" in that it is not just a limited
- ;; case of (SETF FDEFINITION), but instead a different thing.
- ;; I really think the code paths should be reconciled.
- ;; e.g. what's up with *USER-HASH-TABLE-TESTS* being checked
- ;; in %SET-FDEFINITION but not here?
- (remove-specialized-xep symbol)
- (maybe-clobber-ftype symbol new-value)
- (fset symbol new-value)))
+ (setf-fdefinition new-value symbol t))
;;; Incredibly bogus kludge: the :CAS-TRANS option in objdef makes no indication
;;; that you can not use it on certain platforms, so then you do try to use it,
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index c252c5bc1..58a953d25 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -362,6 +362,7 @@
"*PRINT-VECTOR-LENGTH*"
"*PRINT-CIRCLE-NOT-SHARED*"
"DECIMAL-WITH-GROUPED-DIGITS-WIDTH"
+ "UNENCAPSULATED-FUNCTION"
;;"OBJECT-SIZE"
;; stepping interface
diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index 0aac93473..42386a7c0 100644
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -40,14 +40,9 @@
(declaim (inline gdefinition))
(defun gdefinition (spec)
- ;; This is null layer right now, but once FDEFINITION stops bypasssing
- ;; fwrappers/encapsulations we can do that here.
- (fdefinition spec))
+ (sb-ext:unencapsulated-function spec))
(defun (setf gdefinition) (new-value spec)
- ;; This is almost a null layer right now, but once (SETF
- ;; FDEFINITION) stops bypasssing fwrappers/encapsulations we can do
- ;; that here.
(sb-c::note-name-defined spec :function) ; FIXME: do we need this? Why?
(setf (fdefinition spec) new-value))
diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp
index 7afe9216e..3fc91eff5 100644
--- a/src/pcl/documentation.lisp
+++ b/src/pcl/documentation.lisp
@@ -231,7 +231,8 @@
((and (symbolp name) (special-operator-p name))
(fdefinition name))
((and (symbolp name) (macro-function name)))
- ((fdefinition name))))))))
+ ((fdefinition name)
+ (sb-ext:unencapsulated-function name))))))))
(defmethod documentation ((x function) (doc-type (eql 't)))
(fun-doc x))
diff --git a/tests/ansi-tests.sh b/tests/ansi-tests.sh
index 2480981f5..6bb4c16a3 100755
--- a/tests/ansi-tests.sh
+++ b/tests/ansi-tests.sh
@@ -67,7 +67,7 @@ rm -fr sandbox/scratch
(if (member :sb-fasteval sb-impl:+internal-features+)
(list "INTERSECTION.FOLD.1" "UNION.FOLD.1" "SET-DIFFERENCE.FOLD.1"
"SET-EXCLUSIVE-OR.FOLD.1"
- "ALL-STRUCTURE-CLASSES-ARE-SUBTYPES-OF-STRUCTURE-OBJECT.2" "TRACE.8")
+ "ALL-STRUCTURE-CLASSES-ARE-SUBTYPES-OF-STRUCTURE-OBJECT.2")
(list "MAP.48" "SYMBOL-FUNCTION.ERROR.5"
"SUBSTITUTE-IF-NOT.FOLD.4" "REMOVE-IF.FOLD.2"
"REMOVE-IF-NOT.FOLD.1" "REMOVE-IF-NOT.FOLD.3" "REMOVE-IF-NOT.FOLD.4"))
diff --git a/tests/trace.impure.lisp b/tests/trace.impure.lisp
index 072017d62..4722bad00 100644
--- a/tests/trace.impure.lisp
+++ b/tests/trace.impure.lisp
@@ -1,4 +1,3 @@
-
;;; Consider the following definitions in which we assign F2 and F3
;;; the function binding of F1.
;;; Even if we were to agree that tracing of F2 and F3 should happen
@@ -18,9 +17,26 @@
(defparameter *count* 0)
(defun f1 () (incf *count*))
+
+(test-util:with-test (:name (:print-object-function-name :untraced))
+ ;; The SEARCH allows for SB-KERNEL:INTERPRETED-FUNCTION as well.
+ (assert (search "FUNCTION F1>" (prin1-to-string #'f1))))
+
+(defvar *f1/base* #'f1)
(trace f1)
+(defvar *f1/traced* #'f1)
(setf (symbol-function 'f2) #'f1)
(setf (fdefinition 'f3) #'f1)
+(defun f4 ())
+(trace f4)
+(defun f5 ())
+(trace f5)
+(setf (symbol-function 'f4) #'f1)
+(setf (fdefinition 'f5) #'f1)
+
+(test-util:with-test (:name :symbol-function-vs-fdefinition)
+ (assert (not (eq *f1/base* *f1/traced*)))
+ (assert (eq (symbol-function 'f1) (fdefinition 'f1))))
(test-util:with-test (:name :strip-encap)
(let ((s (with-output-to-string (*trace-output*)
@@ -31,7 +47,38 @@
(assert (= (length s) 0)))
(let ((s (with-output-to-string (*trace-output*)
(f3))))
- (assert (= (length s) 0))))
+ (assert (= (length s) 0)))
+ (let ((s (with-output-to-string (*trace-output*)
+ (f4))))
+ (assert (search "F4 returned 4" s)))
+ (let ((s (with-output-to-string (*trace-output*)
+ (f5))))
+ (assert (search "F5 returned 5" s))))
+
+(test-util:with-test (:name (:printed-function-name :traced))
+ (assert (search "FUNCTION F1 ENCAPSULATED>"
+ (prin1-to-string (symbol-function 'f1))))
+ (assert (search "FUNCTION F1 ENCAPSULATED>"
+ (prin1-to-string (fdefinition 'f1))))
+ (let ((sub (if (typep #'f2 'sb-kernel:interpreted-function)
+ "FUNCTION F1"
+ "FUNCTION F1 {")))
+ (dolist (name '(f2 f3))
+ (assert (search sub (prin1-to-string (symbol-function name)))
+ () "(SYMBOL-FUNCTION ~S) printed as ~S"
+ name (prin1-to-string (symbol-function name)))
+ (assert (search sub (prin1-to-string (fdefinition name)))
+ () "(FDEFINITION ~S) printed as ~S"
+ name (prin1-to-string (fdefinition name)))))
+ (dolist (name '(f4 f5))
+ (assert (search "FUNCTION F1 ENCAPSULATED {"
+ (prin1-to-string (symbol-function name)))
+ () "(SYMBOL-FUNCTION ~S) printed as ~S"
+ name (prin1-to-string (symbol-function name)))
+ (assert (search "FUNCTION F1 ENCAPSULATED {"
+ (prin1-to-string (fdefinition name)))
+ () "(FDEFINITION ~S) printed as ~S"
+ name (prin1-to-string (fdefinition name)))))
(defvar *foo*)
;; this should keep the tracing encapsulation
@@ -40,3 +87,53 @@
(let ((s (with-output-to-string (*trace-output*)
(f1))))
(assert (search "F1 returned INVOKED" s))))
+
+
+;;;; Same thing for generic functions
+
+(defparameter *count* 0)
+(defgeneric g1 ()
+ (:method ()
+ (incf *count*)))
+(defvar *g1/base* #'g1)
+(trace g1)
+(defvar *g1/traced* #'g1)
+(setf (symbol-function 'g2) #'g1)
+(setf (fdefinition 'g3) #'g1)
+(defun g4 ())
+(trace g4)
+(defun g5 ())
+(trace g5)
+(setf (symbol-function 'g4) #'g1)
+(setf (fdefinition 'g5) #'g1)
+
+(test-util:with-test (:name (:symbol-function-vs-fdefinition :generic-function))
+ (assert (eq *g1/base* *g1/traced*))
+ (assert (eq (symbol-function 'g1) (fdefinition 'g1))))
+
+(test-util:with-test (:name (:strip-encap :generic-function))
+ (let ((s (with-output-to-string (*trace-output*)
+ (g1))))
+ (assert (search "G1 returned 1" s)))
+ (let ((s (with-output-to-string (*trace-output*)
+ (f2))))
+ (assert (= (length s) 0)))
+ (let ((s (with-output-to-string (*trace-output*)
+ (f3))))
+ (assert (= (length s) 0)))
+ (let ((s (with-output-to-string (*trace-output*)
+ (f4))))
+ (assert (search "F4 returned 4" s)))
+ (let ((s (with-output-to-string (*trace-output*)
+ (f5))))
+ (assert (search "F5 returned 5" s))))
+
+(defvar *foo*)
+;; this should keep the tracing encapsulation
+(defgeneric g1 ()
+ (:method ()
+ (setq *foo* 'invoked)))
+(test-util:with-test (:name (:no-strip-encap :generic-function))
+ (let ((s (with-output-to-string (*trace-output*)
+ (g1))))
+ (assert (search "G1 returned INVOKED" s))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL