From 3a2e34d8ed1293f2cecb5c2c6ea359b622e3f4f8 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sat, 6 Aug 2005 11:31:08 +0000 Subject: [PATCH] 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. --- NEWS | 13 ++++-- src/code/coerce.lisp | 5 +- src/compiler/alpha/alloc.lisp | 1 + src/compiler/generic/objdef.lisp | 43 +++++++++++++++++ src/compiler/hppa/alloc.lisp | 12 +++++ src/compiler/ir1tran-lambda.lisp | 9 ++-- src/compiler/ir2tran.lisp | 5 +- src/compiler/mips/alloc.lisp | 12 +++++ src/compiler/ppc/alloc.lisp | 3 +- src/compiler/sparc/alloc.lisp | 1 + src/compiler/x86-64/alloc.lisp | 3 +- src/compiler/x86/alloc.lisp | 1 + src/pcl/boot.lisp | 4 +- src/pcl/braid.lisp | 2 +- src/pcl/ctor.lisp | 8 ++-- src/pcl/dfun.lisp | 12 ++--- src/pcl/dlisp.lisp | 2 +- src/pcl/dlisp2.lisp | 4 +- src/pcl/methods.lisp | 4 +- tests/mop-4.impure-cload.lisp | 96 ++++++++++++++++++++++++++++++++++++++ tests/mop-5.impure-cload.lisp | 55 ++++++++++++++++++++++ version.lisp-expr | 2 +- 22 files changed, 264 insertions(+), 33 deletions(-) create mode 100644 tests/mop-4.impure-cload.lisp create mode 100644 tests/mop-5.impure-cload.lisp diff --git a/NEWS b/NEWS index b42c442..8b6b726 100644 --- 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) + * 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 @@ -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) + * 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. - * 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 diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index 37721ff..f23440b 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -69,10 +69,13 @@ (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))) + ((instance-lambda) + (deprecation-warning 'instance-lambda 'lambda) + (eval `(function ,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 --- 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)) + (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. diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 7bfbb4c..dd3105f 100644 --- 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) + ;; 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 diff --git a/src/compiler/hppa/alloc.lisp b/src/compiler/hppa/alloc.lisp index cddfdc7..f532c76 100644 --- 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") @@ -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))) + (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. diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 81d98c6..decdfce 100644 --- 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) - (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)))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 30041ce..5adc631 100644 --- 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) - (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))))) diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp index 2948a83..55ef4a7 100644 --- 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") @@ -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)) + (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. diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp index 07bd340..29be679 100644 --- 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. @@ -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 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. diff --git a/src/compiler/sparc/alloc.lisp b/src/compiler/sparc/alloc.lisp index f4d092d..f743dfe 100644 --- 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)) + (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. diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp index 2744168..457d4f7 100644 --- 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. @@ -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)) + (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)))) diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp index d111557..6b3453a 100644 --- 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)) + (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)))) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 4114110..8cc6e51 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -1852,10 +1852,10 @@ bootstrapping. 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"))) - #'(instance-lambda (&rest args) + #'(lambda (&rest args) (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 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -67,7 +67,7 @@ (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))) diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 92965bf..c926918 100644 --- 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) - #'(instance-lambda (&rest args) + #'(lambda (&rest args) (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) + ;; + ;; FIXME: INSTANCE-LAMBDA is no more. We could change this. (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)) - `(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, @@ -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) - `(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)))) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 39f0b5c..ac1234f 100644 --- 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 - #'(instance-lambda (&rest args) + #'(lambda (&rest args) (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 - (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)))) - (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)))))) - (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))))))) @@ -938,7 +938,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 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))) @@ -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)) - #'(instance-lambda (&rest args) + #'(lambda (&rest args) (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 --- 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)))) - #'(instance-lambda ,args + #'(lambda ,args (let () (declare #.*optimize-speed*) ,form))))) diff --git a/src/pcl/dlisp2.lisp b/src/pcl/dlisp2.lisp index cfe0489..504c540 100644 --- 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)) - #'(instance-lambda (&rest args) + #'(lambda (&rest args) (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)) - #'(instance-lambda (&rest args) + #'(lambda (&rest args) (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 --- 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) - (get-fun1 `(,(if function-p - 'instance-lambda - 'lambda) + (get-fun1 `(lambda ,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 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 ( + + (set-funcallable-instance-function + gf + (compute-discriminating-function gf)) + (funcall gf arg)) + (t + )))) + +|# + +#| + +;;; 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 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 --- 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".) -"0.9.3.31" +"0.9.3.32" -- 1.7.10.4