X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Flow.lisp;h=a825d5c6c427f19b2cc99b70b376ce9b2b80d1dc;hb=8cd045dfd24638b1958f1507f944f249d2d2ccde;hp=8105d2dd28b0eb40ac31f1491e0190785fd58dc5;hpb=81ce38f2e03e4f569d7a95bb18efb25bb16fc269;p=sbcl.git

diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp
index 8105d2d..a825d5c 100644
--- a/src/pcl/low.lisp
+++ b/src/pcl/low.lisp
@@ -67,7 +67,6 @@
                       ;; to find out, I just overrode the LAYOUT
                       ;; default here. -- WHN 19991204
                       (invalid nil))
-            (:conc-name %wrapper-)
             (:constructor make-wrapper-internal)
             (:copier nil))
   (instance-slots-layout nil :type list)
@@ -76,15 +75,15 @@
 
 ;;;; PCL's view of funcallable instances
 
-(!defstruct-with-alternate-metaclass pcl-funcallable-instance
+(!defstruct-with-alternate-metaclass standard-funcallable-instance
   ;; KLUDGE: Note that neither of these slots is ever accessed by its
   ;; accessor name as of sbcl-0.pre7.63. Presumably everything works
   ;; by puns based on absolute locations. Fun fun fun.. -- WHN 2001-10-30
   :slot-names (clos-slots name hash-code)
-  :boa-constructor %make-pcl-funcallable-instance
-  :superclass-name funcallable-instance
-  :metaclass-name random-pcl-classoid
-  :metaclass-constructor make-random-pcl-classoid
+  :boa-constructor %make-standard-funcallable-instance
+  :superclass-name function
+  :metaclass-name standard-classoid
+  :metaclass-constructor make-standard-classoid
   :dd-type funcallable-structure
   ;; Only internal implementation code will access these, and these
   ;; accesses (slot readers in particular) could easily be a
@@ -101,17 +100,16 @@
   (declare (type function new-value))
   (aver (funcallable-instance-p fin))
   (setf (funcallable-instance-fun fin) new-value))
+;;; FIXME: these macros should just go away.  It's not clear whether
+;;; the inline functions defined by
+;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS are as efficient as they could
+;;; be; ordinary defstruct accessors are defined as source transforms.
 (defmacro fsc-instance-p (fin)
   `(funcallable-instance-p ,fin))
 (defmacro fsc-instance-wrapper (fin)
   `(%funcallable-instance-layout ,fin))
-;;; FIXME: This seems to bear no relation at all to the CLOS-SLOTS
-;;; slot in the FUNCALLABLE-INSTANCE structure, above, which
-;;; (bizarrely) seems to be set to the NAME of the
-;;; FUNCALLABLE-INSTANCE. At least, the index 1 seems to return the
-;;; NAME, and the index 2 NIL.  Weird.  -- CSR, 2002-11-07
 (defmacro fsc-instance-slots (fin)
-  `(%funcallable-instance-info ,fin 0))
+  `(%funcallable-instance-info ,fin 1))
 (defmacro fsc-instance-hash (fin)
   `(%funcallable-instance-info ,fin 3))
 
@@ -179,12 +177,18 @@
   (declare (special *boot-state* *the-class-standard-generic-function*))
   (when (valid-function-name-p fun)
     (setq fun (fdefinition fun)))
-  (when (funcallable-instance-p fun)
-    (if (if (eq *boot-state* 'complete)
-                 (typep fun 'generic-function)
-                 (eq (class-of fun) *the-class-standard-generic-function*))
-             (setf (%funcallable-instance-info fun 1) new-name)
-             (bug "unanticipated function type")))
+  (typecase fun
+    (%method-function (setf (%method-function-name fun) new-name))
+    #+sb-eval
+    (sb-eval:interpreted-function
+     (setf (sb-eval:interpreted-function-name fun) new-name))
+    (funcallable-instance ;; KLUDGE: probably a generic function...
+     (cond ((if (eq *boot-state* 'complete)
+                (typep fun 'generic-function)
+                (eq (class-of fun) *the-class-standard-generic-function*))
+            (setf (%funcallable-instance-info fun 2) new-name))
+           (t
+            (bug "unanticipated function type")))))
   ;; Fixup name-to-function mappings in cases where the function
   ;; hasn't been defined by DEFUN.  (FIXME: is this right?  This logic
   ;; comes from CMUCL).  -- CSR, 2004-12-31
@@ -223,7 +227,7 @@
 (!defstruct-with-alternate-metaclass standard-instance
   :slot-names (slots hash-code)
   :boa-constructor %make-standard-instance
-  :superclass-name instance
+  :superclass-name t
   :metaclass-name standard-classoid
   :metaclass-constructor make-standard-classoid
   :dd-type structure
@@ -256,8 +260,6 @@
   (when (pcl-instance-p instance)
     (get-slots instance)))
 
-(defmacro built-in-or-structure-wrapper (x) `(layout-of ,x))
-
 (defmacro get-wrapper (inst)
   (once-only ((wrapper `(wrapper-of ,inst)))
     `(progn
@@ -301,11 +303,8 @@
 
 ;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp.
 
-(defun get-structure-dd (type)
-  (layout-info (classoid-layout (find-classoid type))))
-
 (defun structure-type-included-type-name (type)
-  (let ((include (dd-include (get-structure-dd type))))
+  (let ((include (dd-include (find-defstruct-description type))))
     (if (consp include)
         (car include)
         include)))
@@ -313,8 +312,8 @@
 (defun structure-type-slot-description-list (type)
   (nthcdr (length (let ((include (structure-type-included-type-name type)))
                     (and include
-                         (dd-slots (get-structure-dd include)))))
-          (dd-slots (get-structure-dd type))))
+                         (dd-slots (find-defstruct-description include)))))
+          (dd-slots (find-defstruct-description type))))
 
 (defun structure-slotd-name (slotd)
   (dsd-name slotd))
@@ -327,7 +326,7 @@
 
 (defun structure-slotd-writer-function (type slotd)
   (if (dsd-read-only slotd)
-      (let ((dd (get-structure-dd type)))
+      (let ((dd (find-defstruct-description type)))
         (coerce (slot-setter-lambda-form dd slotd) 'function))
       (fdefinition `(setf ,(dsd-accessor-name slotd)))))
 
@@ -336,7 +335,35 @@
 
 (defun structure-slotd-init-form (slotd)
   (dsd-default slotd))
-
+
+;;; method function stuff.
+;;;
+;;; PCL historically included a so-called method-fast-function, which
+;;; is essentially a method function but with (a) a precomputed
+;;; continuation for CALL-NEXT-METHOD and (b) a permutation vector for
+;;; slot access.  [ FIXME: see if we can understand these two
+;;; optimizations before commit. ]  However, the presence of the
+;;; fast-function meant that we violated AMOP and the effect of the
+;;; :FUNCTION initarg, and furthermore got to potentially confusing
+;;; situations where the function and the fast-function got out of
+;;; sync, so that calling (method-function method) with the defined
+;;; protocol would do different things from (call-method method) in
+;;; method combination.
+;;;
+;;; So we define this internal method function structure, which we use
+;;; when we create a method function ourselves.  This means that we
+;;; can hang the various bits of information that we want off the
+;;; method function itself, and also that if a user overrides method
+;;; function creation there is no danger of having the system get
+;;; confused.
+(!defstruct-with-alternate-metaclass %method-function
+  :slot-names (fast-function name)
+  :boa-constructor %make-method-function
+  :superclass-name function
+  :metaclass-name static-classoid
+  :metaclass-constructor make-static-classoid
+  :dd-type funcallable-structure)
+
 ;;; WITH-PCL-LOCK is used around some forms that were previously
 ;;; protected by WITHOUT-INTERRUPTS, but in a threaded SBCL we don't
 ;;; have a useful WITHOUT-INTERRUPTS.  In an unthreaded SBCL I'm not