better encapsulation support in generic functions

[sbcl.git] / src / code / fdefinition.lisp

diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp
index f4bd831..f004d2d 100644 (file)
--- a/src/code/fdefinition.lisp
+++ b/src/code/fdefinition.lisp
@@ -60,6 +60,10 @@
         (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
 ;;; something. SETFable.
@@ -69,6 +73,7 @@
     (or (and fdefn (fdefn-fun fdefn))
         (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)))
 
@@ -101,6 +106,9 @@
   (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
@@ -120,18 +128,16 @@
 
 ;;; 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
@@ -150,6 +156,9 @@
   (let* ((fdefn (fdefinition-object name nil))
          (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.
            )
@@ -176,6 +185,9 @@
 ;;; 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))))
@@ -235,6 +247,24 @@
   "Set NAME's global function definition."
   (declare (type function new-value) (optimize (safety 1)))
   (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))))))
+
+    ;; 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.