common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Accept a non-FBOUNDP function in ENCAPSULATE

Browse source 
Makes no difference to TRACE (the predominant use of ENCAPSULATE) which
checks for a defined function, but has other uses as explained.
This commit is contained in:
Douglas Katzman 2025-06-30 03:07:51 +00:00
parent 9a657fa5d5
commit ad0067a9e1
2 changed files with 51 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
src/code/fdefinition.lisp
View file

@ -250,16 +250,25 @@
;;; otherwise the new encapsulation goes to the front of the chain.
(defun encapsulate (name type function)
(let ((underlying-fun (name->fun name)))
(when (macro/special-guard-fun-p underlying-fun)
;; No error is signaled when encapsulating a nonexistent function, however
;; the wrapper will receive as its first arg a function that signals an error.
(when (or (and underlying-fun (macro/special-guard-fun-p underlying-fun))
(not name))
(error "~S can not be encapsulated" name))
(when (typep underlying-fun 'generic-function)
(return-from encapsulate
(encapsulate-generic-function underlying-fun type function)))
(multiple-value-bind (existing predecessor) (has-encap underlying-fun type)
;; If TYPE existed, the new DEFINITION comes from the existing
(when existing
(setf underlying-fun (encapsulation-info-definition existing)))
(let* ((info (make-encapsulation-info type underlying-fun))
(let* ((info (if (not existing)
(make-encapsulation-info
type
(or underlying-fun
(lambda (&rest args)
(declare (sb-c::lambda-list ($undef$)))
(declare (ignore args))
(error "~S is undefined" name))))
(copy-structure existing)))
(specialized-xep (info :function :specialized-xep name))
(closure (named-lambda encapsulation (&rest args)
(apply function (encapsulation-info-definition info)
@ -286,10 +295,11 @@
(when existing
(let* ((next (encapsulation-info-definition existing))
(specialized-xep (encapsulation-info-specialized-xep existing)))
(if predecessor
(setf (encapsulation-info-definition predecessor) next)
;; It's the first one, so change the fdefn object.
(fset name next))
(cond (predecessor
(setf (encapsulation-info-definition predecessor) next))
;; It's the first one, so change the fdefn object.
((equal (%fun-lambda-list next) '($undef$)) (fmakunbound name))
(t (fset name next)))
(when specialized-xep
(fset (%fun-name specialized-xep) specialized-xep)))))))))

33
tests/encap.impure.lisp
View file

@ -59,3 +59,36 @@
(sb-int:encapsulate 'thing 'encap.a
(lambda (realfun arg) (cons :new-a (funcall realfun arg))))
(assert (equal (thing :x) '(:new-a :b :c "D" :hi :x))))
;;; Check that ENCAPSULATE on an undefined functions works, and that
;;; UNENCAPSULATE can make it undefined. The use-case it to allow test-related
;;; mocks to be agnostic of whether a required function in two loosely coupled
;;; modules exists. e.g. module A calls into module B, and A expects that B exposes
;;; a certain global function F. You would like to unit-test A and B separately
;;; and together. To test together, can mock (via encapsulation) F to observe
;;; inputs and outputs of the interface. To test A alone, you can similarly mock F
;;; despite that it had no global definition, as B is not loaded.
;;; This feature of encapsulate is strictly more useful than just erring when a
;;; function to be encapsulated has no global definition.
(with-test (:name :encapsulate-undef)
(sb-int:encapsulate 'this-function-is-not-defined 'testing
(lambda (realfun) (declare (ignore realfun)) 'ok))
(assert (eq (funcall 'this-function-is-not-defined) 'ok))
(sb-int:unencapsulate 'this-function-is-not-defined 'testing)
(assert (not (fboundp 'this-function-is-not-defined)))
;; furthermore, it works to create two encapsulations on the
;; undefined function, and regardless of which order the
;; encapsulations are stripped off, the function becomes undefined.
(assert (not (fboundp 'beeboh)))
(sb-int:encapsulate 'beeboh 'inner (lambda (realfun) realfun 'this-is-inner))
(sb-int:encapsulate 'beeboh 'outer (lambda (realfun) realfun 'this-is-outer))
(sb-int:unencapsulate 'beeboh 'outer)
(eq (funcall 'beeboh) 'this-is-inner)
(sb-int:unencapsulate 'beeboh 'inner)
(assert (not (fboundp 'beeboh)))
(sb-int:encapsulate 'beeboh 'inner (lambda (realfun) realfun 'this-is-inner))
(sb-int:encapsulate 'beeboh 'outer (lambda (realfun) realfun 'this-is-outer))
(sb-int:unencapsulate 'beeboh 'inner)
(eq (funcall 'beeboh) 'this-is-outer)
(sb-int:unencapsulate 'beeboh 'outer)
(assert (not (fboundp 'beeboh))))