0.9.3.32:

	Fix bug 343: No more need for INSTANCE-LAMBDA.  What happened
	to four-line patches?
	... port to all architectures;
	... remove use of INSTANCE-LAMBDA from pcl;
	... give a deprecation warning for uses of INSTANCE-LAMBDA;
	... write long explanatory comment;
	... add test cases.

diff --git a/NEWS b/NEWS
index b42c442..8b6b726 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,12 @@
 changes in sbcl-0.9.4 relative to sbcl-0.9.3:
   * enhancement: SBCL on MIPS platforms now has a much larger dynamic
     space for its heap.  (thanks to Thiemo Seufer)
 changes in sbcl-0.9.4 relative to sbcl-0.9.3:
   * enhancement: SBCL on MIPS platforms now has a much larger dynamic
     space for its heap.  (thanks to Thiemo Seufer)

+  * minor incompatible change: eof selects abort in the debugger.
+  * minor incompatible change: *INVOKE-DEBUGGER-HOOK* is run before
+    *DEBUGGER-HOOK* => *DEBUGGER-HOOK* is not run when the debugger
+    is disabled.
+  * minor incompatible change: SB-KERNEL:INSTANCE-LAMBDA is
+    deprecated, and will go away in a future revision of SBCL.

   * bug fix: discriminating functions for generic function classes
     with non-standard methods for COMPUTE-APPLICABLE-METHODS no longer
     make invalid assumptions about method precedence order.  (reported
   * bug fix: discriminating functions for generic function classes
     with non-standard methods for COMPUTE-APPLICABLE-METHODS no longer
     make invalid assumptions about method precedence order.  (reported

@@ -11,14 +17,13 @@ changes in sbcl-0.9.4 relative to sbcl-0.9.3:
     (thanks to Kevin Reid)
   * bug fix: complex VOP definitions in "user-space" no longer trigger
     package locks.  (reported by Zach Beane)
     (thanks to Kevin Reid)
   * bug fix: complex VOP definitions in "user-space" no longer trigger
     package locks.  (reported by Zach Beane)

+  * fixed bug 343: SB-KERNEL:INSTANCE-LAMBDA is no longer necessary
+    for funcallable-instance functions, and is no different from
+    regular LAMBDA.

   * optimizations: REMOVE-DUPLICATES now runs in linear time on
     lists in some cases.  This partially fixes bug 384.
   * flush all standard streams before prompting in the REPL and the
     debugger.
   * optimizations: REMOVE-DUPLICATES now runs in linear time on
     lists in some cases.  This partially fixes bug 384.
   * flush all standard streams before prompting in the REPL and the
     debugger.

-  * minor incompatible change: eof selects abort in the debugger.
-  * minor incompatible change: *INVOKE-DEBUGGER-HOOK* is run before
-    *DEBUGGER-HOOK* => *DEBUGGER-HOOK* is not run when the debugger
-    is disabled.

   * threads
     ** bug fix: RELEASE-FOREGROUND doesn't choke on session lock if
        there is only one thread in the session
   * threads
     ** bug fix: RELEASE-FOREGROUND doesn't choke on session lock if
        there is only one thread in the session

diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp
index 37721ff..f23440b 100644 (file)
--- a/src/code/coerce.lisp
+++ b/src/code/coerce.lisp
@@ -69,10 +69,13 @@
      (case (first object)
        ((setf)
         (fdefinition object))
      (case (first object)
        ((setf)
         (fdefinition object))

-       ((lambda instance-lambda)
+       ((lambda)

         ;; FIXME: If we go to a compiler-only implementation, this can
         ;; become COMPILE instead of EVAL, which seems nicer to me.
         (eval `(function ,object)))
         ;; FIXME: If we go to a compiler-only implementation, this can
         ;; become COMPILE instead of EVAL, which seems nicer to me.
         (eval `(function ,object)))

+       ((instance-lambda)
+        (deprecation-warning 'instance-lambda 'lambda)
+        (eval `(function ,object)))

        (t
         (error 'simple-type-error
                :datum object
        (t
         (error 'simple-type-error
                :datum object

diff --git a/src/compiler/alpha/alloc.lisp b/src/compiler/alpha/alloc.lisp
index 78c3b89..9da5c6d 100644 (file)
--- a/src/compiler/alpha/alloc.lisp
+++ b/src/compiler/alpha/alloc.lisp
@@ -142,6 +142,7 @@
               (t
                (inst bis alloc-tn fun-pointer-lowtag result)))
         (storew temp result 0 fun-pointer-lowtag))
               (t
                (inst bis alloc-tn fun-pointer-lowtag result)))
         (storew temp result 0 fun-pointer-lowtag))

+      (storew result result closure-self-slot fun-pointer-lowtag)

       (storew function result closure-fun-slot fun-pointer-lowtag))))
 
 ;;; The compiler likes to be able to directly make value cells.
       (storew function result closure-fun-slot fun-pointer-lowtag))))
 
 ;;; The compiler likes to be able to directly make value cells.

diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp
index 7bfbb4c..dd3105f 100644 (file)
--- a/src/compiler/generic/objdef.lisp
+++ b/src/compiler/generic/objdef.lisp
@@ -221,6 +221,49 @@
 (define-primitive-object (closure :lowtag fun-pointer-lowtag
                                   :widetag closure-header-widetag)
   (fun :init :arg :ref-trans %closure-fun)
 (define-primitive-object (closure :lowtag fun-pointer-lowtag
                                   :widetag closure-header-widetag)
   (fun :init :arg :ref-trans %closure-fun)

+  ;; This SELF slot needs explanation.
+  ;;
+  ;; Ordinary closures did not need this slot before version 0.9.3.xx,
+  ;; as the closure object was already in some dedicated register --
+  ;; EAX/RAX on x86(-64), reg_LEXENV on register-rich platforms -- and
+  ;; consequently setting up the environment (from the INFO slot,
+  ;; below) was easy.
+  ;;
+  ;; However, it is not easy to support calling FUNCALLABLE-INSTANCEs
+  ;; in the same way; in a FUNCALLABLE-INSTANCE, there are
+  ;; conceptually two variable-length data areas: the closure
+  ;; environment, if any, and the slots of the instance.
+  ;;
+  ;; Until sbcl-0.9.3.xx, it was required that closures to be set as a
+  ;; FUNCALLABLE-INSTANCE-FUNCTION be defined using the magical
+  ;; keyword SB-KERNEL:INSTANCE-LAMBDA, rather than ordinary LAMBDA;
+  ;; this caused an extra indirection to be compiled into the closure
+  ;; code to load the closure from the FUNCALLABLE-INSTANCE-LEXENV
+  ;; slot before setting up the environment for the function body.
+  ;; Failure to obey this protocol yielded confusing error messages as
+  ;; either INSTANCE-LAMBDAs tried to dereference environments that
+  ;; weren't there, or ordinary LAMBDAs got hold of the LAYOUT and
+  ;; LEXENV slots of a FUNCALLABLE-INSTANCE.
+  ;;
+  ;; By adding this SELF slot, which is at the same offset in a
+  ;; regular CLOSURE as the LEXENV slot is in a FUNCALLABLE-INSTANCE,
+  ;; we enable the extra indirection (VOP FUNCALLABLE-INSTANCE-LEXENV,
+  ;; in src/compiler/ir2tran.lisp) to be compiled unconditionally
+  ;; (provided that we set this slot to the closure object itself).
+  ;; Relative to the code before, this adds a word to the space
+  ;; requirements of a closure, and one instruction (a memory fetch)
+  ;; to the body of a closure function.
+  ;;
+  ;; There are potentially other implementation strategies which would
+  ;; remove the need for this extra indirection in regular closures,
+  ;; such as setting up a trampoline for funcallable instances (though
+  ;; it was not clear to me that there are enough registers free in
+  ;; the x86 backend to permit this).  This indirection should not be
+  ;; too disastrous, given that for regular closures the fetch is from
+  ;; memory which is known to be active.
+  ;;
+  ;; CSR, 2005-08-05
+  (self) ; KLUDGE (see above comment)

   (info :rest-p t))
 
 (define-primitive-object (funcallable-instance
   (info :rest-p t))
 
 (define-primitive-object (funcallable-instance

diff --git a/src/compiler/hppa/alloc.lisp b/src/compiler/hppa/alloc.lisp
index cddfdc7..f532c76 100644 (file)
--- a/src/compiler/hppa/alloc.lisp
+++ b/src/compiler/hppa/alloc.lisp
@@ -1,3 +1,14 @@
+;;;; allocation VOPs for the HPPA
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+

 (in-package "SB!VM")
 
 \f
 (in-package "SB!VM")
 
 \f

@@ -115,6 +126,7 @@
         (inst dep fun-pointer-lowtag 31 3 result)
         (inst li (logior (ash (1- size) n-widetag-bits) closure-header-widetag) temp)
         (storew temp result 0 fun-pointer-lowtag)))
         (inst dep fun-pointer-lowtag 31 3 result)
         (inst li (logior (ash (1- size) n-widetag-bits) closure-header-widetag) temp)
         (storew temp result 0 fun-pointer-lowtag)))

+    (storew result result closure-self-slot fun-pointer-lowtag)

     (storew function result closure-fun-slot fun-pointer-lowtag)))
 
 ;;; The compiler likes to be able to directly make value cells.
     (storew function result closure-fun-slot fun-pointer-lowtag)))
 
 ;;; The compiler likes to be able to directly make value cells.

diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index 81d98c6..decdfce 100644 (file)
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -922,11 +922,10 @@
                          :source-name source-name
                          :debug-name debug-name))
     ((instance-lambda)
                          :source-name source-name
                          :debug-name debug-name))
     ((instance-lambda)

-     (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))
-                                    :source-name source-name
-                                    :debug-name debug-name)))
-       (setf (getf (functional-plist res) :fin-function) t)
-       res))
+     (deprecation-warning 'instance-lambda 'lambda)
+     (ir1-convert-lambda `(lambda ,@(cdr thing))
+                         :source-name source-name
+                         :debug-name debug-name))

     ((named-lambda)
      (let ((name (cadr thing))
            (lambda-expression `(lambda ,@(cddr thing))))
     ((named-lambda)
      (let ((name (cadr thing))
            (lambda-expression `(lambda ,@(cddr thing))))

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 30041ce..5adc631 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -1138,8 +1138,9 @@
       (if (ir2-physenv-closure env)
           (let ((closure (make-normal-tn *backend-t-primitive-type*)))
             (vop setup-closure-environment node block start-label closure)
       (if (ir2-physenv-closure env)
           (let ((closure (make-normal-tn *backend-t-primitive-type*)))
             (vop setup-closure-environment node block start-label closure)

-            (when (getf (functional-plist ef) :fin-function)
-              (vop funcallable-instance-lexenv node block closure closure))
+            ;; KLUDGE: see the comment around the definition of
+            ;; CLOSURE objects in src/compiler/objdef.lisp
+            (vop funcallable-instance-lexenv node block closure closure)

             (let ((n -1))
               (dolist (loc (ir2-physenv-closure env))
                 (vop closure-ref node block closure (incf n) (cdr loc)))))
             (let ((n -1))
               (dolist (loc (ir2-physenv-closure env))
                 (vop closure-ref node block closure (incf n) (cdr loc)))))

diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp
index 2948a83..55ef4a7 100644 (file)
--- a/src/compiler/mips/alloc.lisp
+++ b/src/compiler/mips/alloc.lisp
@@ -1,3 +1,14 @@
+;;;; allocation VOPs for Mips
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+

 (in-package "SB!VM")
 
 \f
 (in-package "SB!VM")
 
 \f

@@ -119,6 +130,7 @@
       (pseudo-atomic (pa-flag :extra (pad-data-block size))
         (inst or result alloc-tn fun-pointer-lowtag)
         (storew temp result 0 fun-pointer-lowtag))
       (pseudo-atomic (pa-flag :extra (pad-data-block size))
         (inst or result alloc-tn fun-pointer-lowtag)
         (storew temp result 0 fun-pointer-lowtag))

+      (storew result result closure-self-slot fun-pointer-lowtag)

       (storew function result closure-fun-slot fun-pointer-lowtag))))
 
 ;;; The compiler likes to be able to directly make value cells.
       (storew function result closure-fun-slot fun-pointer-lowtag))))
 
 ;;; The compiler likes to be able to directly make value cells.

diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp
index 07bd340..29be679 100644 (file)
--- a/src/compiler/ppc/alloc.lisp
+++ b/src/compiler/ppc/alloc.lisp
@@ -1,4 +1,4 @@
-;;;; allocation VOPs
+;;;; allocation VOPs for the PPC

 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.

@@ -144,6 +144,7 @@
         (storew temp result 0 fun-pointer-lowtag)))
     ;(inst lis temp (ash 18 10))
     ;(storew temp result closure-jump-insn-slot function-pointer-type)
         (storew temp result 0 fun-pointer-lowtag)))
     ;(inst lis temp (ash 18 10))
     ;(storew temp result closure-jump-insn-slot function-pointer-type)

+    (storew result result closure-self-slot fun-pointer-lowtag)

     (storew function result closure-fun-slot fun-pointer-lowtag)))
 
 ;;; The compiler likes to be able to directly make value cells.
     (storew function result closure-fun-slot fun-pointer-lowtag)))
 
 ;;; The compiler likes to be able to directly make value cells.

diff --git a/src/compiler/sparc/alloc.lisp b/src/compiler/sparc/alloc.lisp
index f4d092d..f743dfe 100644 (file)
--- a/src/compiler/sparc/alloc.lisp
+++ b/src/compiler/sparc/alloc.lisp
@@ -143,6 +143,7 @@
                (inst or result fun-pointer-lowtag)))
         (inst li temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
         (storew temp result 0 fun-pointer-lowtag))
                (inst or result fun-pointer-lowtag)))
         (inst li temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
         (storew temp result 0 fun-pointer-lowtag))

+      (storew result result closure-self-slot fun-pointer-lowtag)

       (storew function result closure-fun-slot fun-pointer-lowtag))))
 
 ;;; The compiler likes to be able to directly make value cells.
       (storew function result closure-fun-slot fun-pointer-lowtag))))
 
 ;;; The compiler likes to be able to directly make value cells.

diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp
index 2744168..457d4f7 100644 (file)
--- a/src/compiler/x86-64/alloc.lisp
+++ b/src/compiler/x86-64/alloc.lisp
@@ -1,4 +1,4 @@
-;;;; allocation VOPs for the x86
+;;;; allocation VOPs for the x86-64

 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.

@@ -128,6 +128,7 @@
             (make-ea :byte :base result :disp fun-pointer-lowtag))
       (storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
               result 0 fun-pointer-lowtag))
             (make-ea :byte :base result :disp fun-pointer-lowtag))
       (storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
               result 0 fun-pointer-lowtag))

+    (storew result result closure-self-slot fun-pointer-lowtag)

     (loadw temp function closure-fun-slot fun-pointer-lowtag)
     (storew temp result closure-fun-slot fun-pointer-lowtag))))
 
     (loadw temp function closure-fun-slot fun-pointer-lowtag)
     (storew temp result closure-fun-slot fun-pointer-lowtag))))
 

diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp
index d111557..6b3453a 100644 (file)
--- a/src/compiler/x86/alloc.lisp
+++ b/src/compiler/x86/alloc.lisp
@@ -216,6 +216,7 @@
              (make-ea :byte :base result :disp fun-pointer-lowtag))
        (storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
                result 0 fun-pointer-lowtag))
              (make-ea :byte :base result :disp fun-pointer-lowtag))
        (storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
                result 0 fun-pointer-lowtag))

+    (storew result result closure-self-slot fun-pointer-lowtag)

     (loadw temp function closure-fun-slot fun-pointer-lowtag)
     (storew temp result closure-fun-slot fun-pointer-lowtag))))
 
     (loadw temp function closure-fun-slot fun-pointer-lowtag)
     (storew temp result closure-fun-slot fun-pointer-lowtag))))
 

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 4114110..8cc6e51 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -1852,10 +1852,10 @@ bootstrapping.
      fin
      (or function
          (if (eq spec 'print-object)
      fin
      (or function
          (if (eq spec 'print-object)

-             #'(instance-lambda (instance stream)
+             #'(lambda (instance stream)

                  (print-unreadable-object (instance stream :identity t)
                    (format stream "std-instance")))
                  (print-unreadable-object (instance stream :identity t)
                    (format stream "std-instance")))

-             #'(instance-lambda (&rest args)
+             #'(lambda (&rest args)

                  (declare (ignore args))
                  (error "The function of the funcallable-instance ~S~
                          has not been set." fin)))))
                  (declare (ignore args))
                  (error "The function of the funcallable-instance ~S~
                          has not been set." fin)))))

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index a3cabbb..98c0c8f 100644 (file)
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -67,7 +67,7 @@
                                              (get-instance-hash-code))))
     (set-funcallable-instance-function
      fin
                                              (get-instance-hash-code))))
     (set-funcallable-instance-function
      fin

-     #'(instance-lambda (&rest args)
+     #'(lambda (&rest args)

          (declare (ignore args))
          (error "The function of the funcallable-instance ~S has not been set."
                 fin)))
          (declare (ignore args))
          (error "The function of the funcallable-instance ~S has not been set."
                 fin)))

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 92965bf..c926918 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -128,7 +128,7 @@
   (when (or force-p (ctor-class ctor))
     (setf (ctor-class ctor) nil)
     (setf (funcallable-instance-fun ctor)
   (when (or force-p (ctor-class ctor))
     (setf (ctor-class ctor) nil)
     (setf (funcallable-instance-fun ctor)

-          #'(instance-lambda (&rest args)
+          #'(lambda (&rest args)

               (install-optimized-constructor ctor)
               (apply ctor args)))
     (setf (%funcallable-instance-info ctor 1)
               (install-optimized-constructor ctor)
               (apply ctor args)))
     (setf (%funcallable-instance-info ctor 1)

@@ -253,6 +253,8 @@
           ;;
           ;; (except maybe for optimization qualities? -- CSR,
           ;; 2004-07-12)
           ;;
           ;; (except maybe for optimization qualities? -- CSR,
           ;; 2004-07-12)

+          ;;
+          ;; FIXME: INSTANCE-LAMBDA is no more.  We could change this.

           (eval `(function ,(constructor-function-form ctor))))))
 
 (defun constructor-function-form (ctor)
           (eval `(function ,(constructor-function-form ctor))))))
 
 (defun constructor-function-form (ctor)

@@ -351,7 +353,7 @@
 
 (defun fallback-generator (ctor ii-methods si-methods)
   (declare (ignore ii-methods si-methods))
 
 (defun fallback-generator (ctor ii-methods si-methods)
   (declare (ignore ii-methods si-methods))

-  `(instance-lambda ,(make-ctor-parameter-list ctor)
+  `(lambda ,(make-ctor-parameter-list ctor)

      ;; The CTOR MAKE-INSTANCE optimization only kicks in when the
      ;; first argument to MAKE-INSTANCE is a constant symbol: by
      ;; calling it with a class, as here, we inhibit the optimization,
      ;; The CTOR MAKE-INSTANCE optimization only kicks in when the
      ;; first argument to MAKE-INSTANCE is a constant symbol: by
      ;; calling it with a class, as here, we inhibit the optimization,

@@ -362,7 +364,7 @@
 (defun optimizing-generator (ctor ii-methods si-methods)
   (multiple-value-bind (body before-method-p)
       (fake-initialization-emf ctor ii-methods si-methods)
 (defun optimizing-generator (ctor ii-methods si-methods)
   (multiple-value-bind (body before-method-p)
       (fake-initialization-emf ctor ii-methods si-methods)

-    `(instance-lambda ,(make-ctor-parameter-list ctor)
+    `(lambda ,(make-ctor-parameter-list ctor)

        (declare #.*optimize-speed*)
        ,(wrap-in-allocate-forms ctor body before-method-p))))
 
        (declare #.*optimize-speed*)
        ,(wrap-in-allocate-forms ctor body before-method-p))))
 

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 39f0b5c..ac1234f 100644 (file)
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -789,7 +789,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 
 (defun make-initial-dfun (gf)
   (let ((initial-dfun
 
 (defun make-initial-dfun (gf)
   (let ((initial-dfun

-         #'(instance-lambda (&rest args)
+         #'(lambda (&rest args)

              (initial-dfun gf args))))
     (multiple-value-bind (dfun cache info)
         (cond
              (initial-dfun gf args))))
     (multiple-value-bind (dfun cache info)
         (cond

@@ -834,17 +834,17 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
   (let* ((methods (early-gf-methods gf))
          (slot-name (early-method-standard-accessor-slot-name (car methods))))
     (ecase type
   (let* ((methods (early-gf-methods gf))
          (slot-name (early-method-standard-accessor-slot-name (car methods))))
     (ecase type

-      (reader #'(instance-lambda (instance)
+      (reader #'(lambda (instance)

                   (let* ((class (class-of instance))
                          (class-name (!bootstrap-get-slot 'class class 'name)))
                     (!bootstrap-get-slot class-name instance slot-name))))
                   (let* ((class (class-of instance))
                          (class-name (!bootstrap-get-slot 'class class 'name)))
                     (!bootstrap-get-slot class-name instance slot-name))))

-      (boundp #'(instance-lambda (instance)
+      (boundp #'(lambda (instance)

                   (let* ((class (class-of instance))
                          (class-name (!bootstrap-get-slot 'class class 'name)))
                     (not (eq +slot-unbound+
                              (!bootstrap-get-slot class-name
                                                   instance slot-name))))))
                   (let* ((class (class-of instance))
                          (class-name (!bootstrap-get-slot 'class class 'name)))
                     (not (eq +slot-unbound+
                              (!bootstrap-get-slot class-name
                                                   instance slot-name))))))

-      (writer #'(instance-lambda (new-value instance)
+      (writer #'(lambda (new-value instance)

                   (let* ((class (class-of instance))
                          (class-name (!bootstrap-get-slot 'class class 'name)))
                     (!bootstrap-set-slot class-name instance slot-name new-value)))))))
                   (let* ((class (class-of instance))
                          (class-name (!bootstrap-get-slot 'class class 'name)))
                     (!bootstrap-set-slot class-name instance slot-name new-value)))))))

@@ -938,7 +938,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
         specls all-same-p)
     (cond ((null methods)
            (values
         specls all-same-p)
     (cond ((null methods)
            (values

-            #'(instance-lambda (&rest args)
+            #'(lambda (&rest args)

                 (apply #'no-applicable-method gf args))
             nil
             (no-methods-dfun-info)))
                 (apply #'no-applicable-method gf args))
             nil
             (no-methods-dfun-info)))

@@ -1670,7 +1670,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
       (if function-p
           (lambda (method-alist wrappers)
             (declare (ignore method-alist wrappers))
       (if function-p
           (lambda (method-alist wrappers)
             (declare (ignore method-alist wrappers))

-            #'(instance-lambda (&rest args)
+            #'(lambda (&rest args)

                 (apply #'no-applicable-method gf args)))
           (lambda (method-alist wrappers)
             (declare (ignore method-alist wrappers))
                 (apply #'no-applicable-method gf args)))
           (lambda (method-alist wrappers)
             (declare (ignore method-alist wrappers))

diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp
index 99bb789..26419ce 100644 (file)
--- a/src/pcl/dlisp.lisp
+++ b/src/pcl/dlisp.lisp
@@ -123,7 +123,7 @@
          (lambda `(lambda ,closure-variables
                     ,@(when (member 'miss-fn closure-variables)
                         `((declare (type function miss-fn))))
          (lambda `(lambda ,closure-variables
                     ,@(when (member 'miss-fn closure-variables)
                         `((declare (type function miss-fn))))

-                    #'(instance-lambda ,args
+                    #'(lambda ,args

                         (let ()
                           (declare #.*optimize-speed*)
                           ,form)))))
                         (let ()
                           (declare #.*optimize-speed*)
                           ,form)))))

diff --git a/src/pcl/dlisp2.lisp b/src/pcl/dlisp2.lisp
index cfe0489..504c540 100644 (file)
--- a/src/pcl/dlisp2.lisp
+++ b/src/pcl/dlisp2.lisp
@@ -89,7 +89,7 @@
   (if cached-emf-p
       (lambda (cache miss-fn)
         (declare (type function miss-fn))
   (if cached-emf-p
       (lambda (cache miss-fn)
         (declare (type function miss-fn))

-        #'(instance-lambda (&rest args)
+        #'(lambda (&rest args)

             (declare #.*optimize-speed*)
             (with-dfun-wrappers (args metatypes)
               (dfun-wrappers invalid-wrapper-p)
             (declare #.*optimize-speed*)
             (with-dfun-wrappers (args metatypes)
               (dfun-wrappers invalid-wrapper-p)

@@ -104,7 +104,7 @@
                             (invoke-emf emf args))))))))
       (lambda (cache emf miss-fn)
         (declare (type function miss-fn))
                             (invoke-emf emf args))))))))
       (lambda (cache emf miss-fn)
         (declare (type function miss-fn))

-        #'(instance-lambda (&rest args)
+        #'(lambda (&rest args)

             (declare #.*optimize-speed*)
             (with-dfun-wrappers (args metatypes)
               (dfun-wrappers invalid-wrapper-p)
             (declare #.*optimize-speed*)
             (with-dfun-wrappers (args metatypes)
               (dfun-wrappers invalid-wrapper-p)

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 91e746e..9f181f7 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -1359,9 +1359,7 @@
                         (make-dfun-lambda-list metatypes applyp)
                         (make-fast-method-call-lambda-list metatypes applyp))))
       (multiple-value-bind (cfunction constants)
                         (make-dfun-lambda-list metatypes applyp)
                         (make-fast-method-call-lambda-list metatypes applyp))))
       (multiple-value-bind (cfunction constants)

-          (get-fun1 `(,(if function-p
-                           'instance-lambda
-                           'lambda)
+          (get-fun1 `(lambda

                       ,arglist
                       ,@(unless function-p
                           `((declare (ignore .pv-cell.
                       ,arglist
                       ,@(unless function-p
                           `((declare (ignore .pv-cell.

diff --git a/tests/mop-4.impure-cload.lisp b/tests/mop-4.impure-cload.lisp
new file mode 100644 (file)
index 0000000..157424c
--- /dev/null
+++ b/tests/mop-4.impure-cload.lisp
@@ -0,0 +1,96 @@
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; This file contains tests for COMPUTE-DISCRIMINATING-FUNCTION on
+;;; subclasses of generic functions.  However, at present it is
+;;; impossible to have more than one of these in the same image,
+;;; because of a vicious metacircle.  Once the vicious metacircle is
+;;; dealt with, uncomment the test cases.
+
+(defpackage "MOP-4"
+  (:use "CL" "SB-MOP"))
+
+(in-package "MOP-4")
+
+;;; bug 343
+(defclass my-generic-function1 (standard-generic-function) ()
+  (:metaclass funcallable-standard-class))
+
+(defmethod compute-discriminating-function ((gf my-generic-function1))
+  (let ((dfun (call-next-method)))
+    (lambda (&rest args)
+      (1+ (apply dfun args)))))
+
+(defgeneric foo (x)
+  (:generic-function-class my-generic-function1))
+
+(defmethod foo (x) (+ x x))
+
+(assert (= (foo 5) 11))
+
+#|
+
+;;; from PCL sources
+
+(defmethod compute-discriminating-function ((gf my-generic-function))
+  (let ((std (call-next-method)))
+    (lambda (arg)
+      (print (list 'call-to-gf gf arg))
+      (funcall std arg))))
+
+and
+
+(defmethod compute-discriminating-function ((gf my-generic-function))
+  (lambda (arg)
+   (cond (<some condition>
+          <store some info in the generic function>
+          (set-funcallable-instance-function
+            gf
+            (compute-discriminating-function gf))
+          (funcall gf arg))
+         (t
+          <call-a-method-of-gf>))))
+
+|#
+
+#|
+
+;;; from clisp's test suite
+
+(progn
+  (defclass traced-generic-function (standard-generic-function)
+    ()
+    (:metaclass clos:funcallable-standard-class))
+  (defvar *last-traced-arguments* nil)
+  (defvar *last-traced-values* nil)
+  (defmethod clos:compute-discriminating-function ((gf traced-generic-function))    (let ((orig-df (call-next-method))
+          (name (clos:generic-function-name gf)))
+      #'(lambda (&rest arguments)
+          (declare (compile))
+          (format *trace-output* "~%=> ~S arguments: ~:S" name arguments)
+          (setq *last-traced-arguments* arguments)
+          (let ((values (multiple-value-list (apply orig-df arguments))))
+            (format *trace-output* "~%<= ~S values: ~:S" name values)
+            (setq *last-traced-values* values)
+            (values-list values)))))
+  (defgeneric testgf15 (x) (:generic-function-class traced-generic-function)
+     (:method ((x number)) (values x (- x) (* x x) (/ x))))
+  (testgf15 5)
+  (list *last-traced-arguments* *last-traced-values*))
+
+;;; also we might be in a position to run the "application example"
+;;; from mop.tst in clisp's test suite
+
+|#
+
+(sb-ext:quit :unix-status 104)

diff --git a/tests/mop-5.impure-cload.lisp b/tests/mop-5.impure-cload.lisp
new file mode 100644 (file)
index 0000000..213d5fd
--- /dev/null
+++ b/tests/mop-5.impure-cload.lisp
@@ -0,0 +1,55 @@
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; This file contains simple tests for
+;;; SET-FUNCALLABLE-INSTANCE-FUNCTION on FUNCALLABLE-INSTANCEs
+
+
+;;; from Justin Dubs on comp.lang.lisp
+(defclass fn ()
+  ()
+  (:metaclass sb-mop:funcallable-standard-class))
+
+(defvar *fn*)
+
+(defmethod initialize-instance :after ((fn fn) &rest initargs &key
+                                       &allow-other-keys)
+  (declare (ignore initargs))
+  (sb-mop:set-funcallable-instance-function fn
+                                            (lambda (x)
+                                              (setf *fn* fn)
+                                              (1+ x))))
+
+(let ((fun (make-instance 'fn)))
+  (assert (= (funcall fun 42) 43))
+  (assert (eq *fn* fun)))
+
+;;; from Tony Martinez sbcl-devel
+(defclass counter ()
+  ((number :initarg :start :accessor counter))
+  (:metaclass sb-pcl::funcallable-standard-class))
+
+(defun make-counter (&key (start 0))
+  (let ((instance (make-instance 'counter :start start)))
+    (sb-mop:set-funcallable-instance-function
+     instance
+     ;; When run, this function doesn't print the instance, but (what
+     ;; I think is) itself.
+     (lambda () (print instance)))
+    instance))
+
+(defparameter *counter* (make-counter :start 666))
+
+(assert (eq (funcall *counter*) *counter*))
+
+(sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index ffe235b..41894ba 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)

-"0.9.3.31"
+"0.9.3.32"