(defun fdefn-fun (fdefn)
(declare (type fdefn fdefn)
- (values (or function null)))
+ (values (or function null)))
(fdefn-fun fdefn))
(defun (setf fdefn-fun) (fun fdefn)
(declare (type function fun)
- (type fdefn fdefn)
- (values function))
+ (type fdefn fdefn)
+ (values function))
(setf (fdefn-fun fdefn) fun))
(defun fdefn-makunbound (fdefn)
(legal-fun-name-or-type-error name)
(let ((fdefn (info :function :definition name)))
(if (and (null fdefn) create)
- (setf (info :function :definition name) (make-fdefn name))
- fdefn)))
+ (setf (info :function :definition name) (make-fdefn name))
+ fdefn)))
+
+(defun maybe-clobber-ftype (name)
+ (unless (eq :declared (info :function :where-from name))
+ (clear-info :function :type name)))
;;; Return the fdefinition of NAME, including any encapsulations.
-;;; The compiler emits calls to this when someone tries to FUNCALL
+;;; The compiler emits calls to this when someone tries to FUNCALL
;;; something. SETFable.
#!-sb-fluid (declaim (inline %coerce-name-to-fun))
(defun %coerce-name-to-fun (name)
(let ((fdefn (fdefinition-object name nil)))
(or (and fdefn (fdefn-fun fdefn))
- (error 'undefined-function :name name))))
+ (error 'undefined-function :name name))))
(defun (setf %coerce-name-to-fun) (function name)
+ (maybe-clobber-ftype name)
(let ((fdefn (fdefinition-object name t)))
(setf (fdefn-fun fdefn) function)))
;;;; definition encapsulation
(defstruct (encapsulation-info (:constructor make-encapsulation-info
- (type definition))
- (:copier nil))
+ (type definition))
+ (:copier nil))
;; This is definition's encapsulation type. The encapsulated
;; definition is in the previous ENCAPSULATION-INFO element or
;; installed as the global definition of some function name.
(let ((fdefn (fdefinition-object name nil)))
(unless (and fdefn (fdefn-fun fdefn))
(error 'undefined-function :name name))
+ (when (typep (fdefn-fun fdefn) 'generic-function)
+ (return-from encapsulate
+ (encapsulate-generic-function (fdefn-fun fdefn) type body)))
;; We must bind and close over INFO. Consider the case where we
;; encapsulate (the second) an encapsulated (the first)
;; definition, and later someone unencapsulates the encapsulated
;; an encapsulation that no longer exists.
(let ((info (make-encapsulation-info type (fdefn-fun fdefn))))
(setf (fdefn-fun fdefn)
- (named-lambda encapsulate (&rest arg-list)
- (declare (special arg-list))
- (let ((basic-definition (encapsulation-info-definition info)))
- (declare (special basic-definition))
- (eval body)))))))
+ (named-lambda encapsulation (&rest arg-list)
+ (declare (special arg-list))
+ (let ((basic-definition (encapsulation-info-definition info)))
+ (declare (special basic-definition))
+ (eval body)))))))
;;; This is like FIND-IF, except that we do it on a compiled closure's
;;; environment.
-(defun find-if-in-closure (test fun)
- (declare (type function test))
- (dotimes (index (1- (get-closure-length fun)))
- (let ((elt (%closure-index-ref fun index)))
- (when (funcall test elt)
- (return elt)))))
+(defun find-if-in-closure (test closure)
+ (declare (closure closure))
+ (do-closure-values (value closure)
+ (when (funcall test value)
+ (return value))))
;;; Find the encapsulation info that has been closed over.
(defun encapsulation-info (fun)
- (and (functionp fun)
- (= (widetag-of fun) sb!vm:closure-header-widetag)
- (find-if-in-closure #'encapsulation-info-p fun)))
+ (when (closurep fun)
+ (find-if-in-closure #'encapsulation-info-p fun)))
;;; When removing an encapsulation, we must remember that
;;; encapsulating definitions close over a reference to the
#!+sb-doc
"Removes NAME's most recent encapsulation of the specified TYPE."
(let* ((fdefn (fdefinition-object name nil))
- (encap-info (encapsulation-info (fdefn-fun fdefn))))
+ (encap-info (encapsulation-info (fdefn-fun fdefn))))
(declare (type (or encapsulation-info null) encap-info))
+ (when (and fdefn (typep (fdefn-fun fdefn) 'generic-function))
+ (return-from unencapsulate
+ (unencapsulate-generic-function (fdefn-fun fdefn) type)))
(cond ((not encap-info)
- ;; It disappeared on us, so don't worry about it.
- )
- ((eq (encapsulation-info-type encap-info) type)
- ;; It's the first one, so change the fdefn object.
- (setf (fdefn-fun fdefn)
- (encapsulation-info-definition encap-info)))
- (t
- ;; It must be an interior one, so find it.
- (loop
- (let ((next-info (encapsulation-info
- (encapsulation-info-definition encap-info))))
- (unless next-info
- ;; Not there, so don't worry about it.
- (return))
- (when (eq (encapsulation-info-type next-info) type)
- ;; This is it, so unlink us.
- (setf (encapsulation-info-definition encap-info)
- (encapsulation-info-definition next-info))
- (return))
- (setf encap-info next-info))))))
+ ;; It disappeared on us, so don't worry about it.
+ )
+ ((eq (encapsulation-info-type encap-info) type)
+ ;; It's the first one, so change the fdefn object.
+ (setf (fdefn-fun fdefn)
+ (encapsulation-info-definition encap-info)))
+ (t
+ ;; It must be an interior one, so find it.
+ (loop
+ (let ((next-info (encapsulation-info
+ (encapsulation-info-definition encap-info))))
+ (unless next-info
+ ;; Not there, so don't worry about it.
+ (return))
+ (when (eq (encapsulation-info-type next-info) type)
+ ;; This is it, so unlink us.
+ (setf (encapsulation-info-definition encap-info)
+ (encapsulation-info-definition next-info))
+ (return))
+ (setf encap-info next-info))))))
t)
;;; Does NAME have an encapsulation of the given TYPE?
(defun encapsulated-p (name type)
(let ((fdefn (fdefinition-object name nil)))
+ (when (and fdefn (typep (fdefn-fun fdefn) 'generic-function))
+ (return-from encapsulated-p
+ (encapsulated-generic-function-p (fdefn-fun fdefn) type)))
(do ((encap-info (encapsulation-info (fdefn-fun fdefn))
- (encapsulation-info
- (encapsulation-info-definition encap-info))))
- ((null encap-info) nil)
+ (encapsulation-info
+ (encapsulation-info-definition encap-info))))
+ ((null encap-info) nil)
(declare (type (or encapsulation-info null) encap-info))
(when (eq (encapsulation-info-type encap-info) type)
- (return t)))))
+ (return t)))))
\f
;;;; FDEFINITION
(loop
(let ((encap-info (encapsulation-info fun)))
(if encap-info
- (setf fun (encapsulation-info-definition encap-info))
- (return fun))))))
+ (setf fun (encapsulation-info-definition encap-info))
+ (return fun))))))
(defvar *setf-fdefinition-hook* nil
#!+sb-doc
#!+sb-doc
"Set NAME's global function definition."
(declare (type function new-value) (optimize (safety 1)))
- (let ((fdefn (fdefinition-object name t)))
- ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running
- ;; top level forms in the kernel core startup.
- (when (boundp '*setf-fdefinition-hook*)
- (dolist (f *setf-fdefinition-hook*)
- (declare (type function f))
- (funcall f name new-value)))
+ (with-single-package-locked-error (:symbol name "setting fdefinition of ~A")
+ (maybe-clobber-ftype name)
+
+ ;; Check for hash-table stuff. Woe onto him that mixes encapsulation
+ ;; with this.
+ (when (and (symbolp name) (fboundp name)
+ (boundp '*user-hash-table-tests*))
+ (let ((old (symbol-function name)))
+ (declare (special *user-hash-table-tests*))
+ (dolist (spec *user-hash-table-tests*)
+ (cond ((eq old (second spec))
+ ;; test-function
+ (setf (second spec) new-value))
+ ((eq old (third spec))
+ ;; hash-function
+ (setf (third spec) new-value))))))
- (let ((encap-info (encapsulation-info (fdefn-fun fdefn))))
- (cond (encap-info
- (loop
- (let ((more-info
- (encapsulation-info
- (encapsulation-info-definition encap-info))))
- (if more-info
- (setf encap-info more-info)
- (return
- (setf (encapsulation-info-definition encap-info)
- new-value))))))
- (t
- (setf (fdefn-fun fdefn) new-value))))))
+ ;; FIXME: This is a good hook to have, but we should probably
+ ;; reserve it for users.
+ (let ((fdefn (fdefinition-object name t)))
+ ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running
+ ;; top level forms in the kernel core startup.
+ (when (boundp '*setf-fdefinition-hook*)
+ (dolist (f *setf-fdefinition-hook*)
+ (declare (type function f))
+ (funcall f name new-value)))
+
+ (let ((encap-info (encapsulation-info (fdefn-fun fdefn))))
+ (cond (encap-info
+ (loop
+ (let ((more-info
+ (encapsulation-info
+ (encapsulation-info-definition encap-info))))
+ (if more-info
+ (setf encap-info more-info)
+ (return
+ (setf (encapsulation-info-definition encap-info)
+ new-value))))))
+ (t
+ (setf (fdefn-fun fdefn) new-value)))))))
\f
;;;; FBOUNDP and FMAKUNBOUND
(defun fmakunbound (name)
#!+sb-doc
"Make NAME have no global function definition."
- (let ((fdefn (fdefinition-object name nil)))
- (when fdefn
- (fdefn-makunbound fdefn)))
- (sb!kernel:undefine-fun-name name)
- name)
+ (with-single-package-locked-error
+ (:symbol name "removing the function or macro definition of ~A")
+ (let ((fdefn (fdefinition-object name nil)))
+ (when fdefn
+ (fdefn-makunbound fdefn)))
+ (sb!kernel:undefine-fun-name name)
+ name))
projects / sbcl.git / blobdiff