mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
d9b4878a31
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.
140 lines
5.2 KiB
Common Lisp
140 lines
5.2 KiB
Common Lisp
;;; 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
|
||
;;; (which I think is wrong in itself), then what about SB-DEBUG::*TRACED-FUNS* ?
|
||
;;; It doesn't know that F2 and F3 are traced, which seems like a metadata bug.
|
||
;;; So then when we UNTRACE F1, we don't know that we're supposed to UNTRACE
|
||
;;; F2 and F3, so they continue to print the tracing output.
|
||
;;; And aside from that, when F2 or F3 would get invoked, the tracing output
|
||
;;; would suggest that F1 was called by name, which doesn't make a ton of sense,
|
||
;;; because first of all tracing is supposed to print the name of what was
|
||
;;; actually called - which coincidentally is bound to the same function object
|
||
;;; as some other global name - and secondly we just explicitly UNTRACEd the very
|
||
;;; name that it said was called.
|
||
;;; A reasonable solution to these bugs is to remove the tracing encapsulation
|
||
;;; when assigning SYMBOL-FUNCTION or FDEFINITION. Granted there are other
|
||
;;; encapsulations (profiling, e.g.) but this entire area is unspecified.
|
||
|
||
(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*)
|
||
(f1))))
|
||
(assert (search "F1 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))))
|
||
|
||
(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
|
||
(defun f1 () (setq *foo* 'invoked))
|
||
(test-util:with-test (:name :no-strip-encap)
|
||
(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))))
|