0.9.16.25: build fix for CMUCL and older SBCLs

[sbcl.git] / src / pcl / low.lisp

diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp
index ed2d9b8..aa65f9e 100644 (file)
--- a/src/pcl/low.lisp
+++ b/src/pcl/low.lisp
@@ -76,15 +76,15 @@
 \f
 ;;;; 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
+  :boa-constructor %make-standard-funcallable-instance
   :superclass-name function
-  :metaclass-name random-pcl-classoid
-  :metaclass-constructor make-random-pcl-classoid
+  :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
@@ -179,11 +179,15 @@
   (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 2) new-name)
-             (bug "unanticipated function type")))
+    ;; HACK
+    (case (classoid-name (classoid-of fun))
+      (%method-function (setf (%method-function-name fun) new-name))
+      (t ;; KLUDGE: probably a generic function...
+       (if (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)
+           (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
@@ -335,7 +339,35 @@
 
 (defun structure-slotd-init-form (slotd)
   (dsd-default slotd))
-
+\f
+;;; 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 random-pcl-classoid
+  :metaclass-constructor make-random-pcl-classoid
+  :dd-type funcallable-structure)
+\f
 ;;; 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