From: Christophe Rhodes Date: Thu, 7 Nov 2002 18:08:49 +0000 (+0000) Subject: 0.7.9.36: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=8e1eb3714554b8b93455895756787f6c4f63afc5;p=sbcl.git 0.7.9.36: Implement internal counter for SXHASH on PCL instances (more-or-less as per Gerd Moellman cmucl-imp) entomotomy: sxhash-on-pcl-instances-returns-42 ... 3 not 2 for %funcallable-instance-info, apparently ... add extra arg to BOA-constructor call ... add generic-function clause to SXHASH definition Minor doc/ frob (claiming MOP support, modulo bugs) --- diff --git a/NEWS b/NEWS index 08ea6a0..4a3381a 100644 --- a/NEWS +++ b/NEWS @@ -1365,6 +1365,10 @@ changes in sbcl-0.7.10 relative to sbcl-0.7.9: FORWARD-REFERENCED-CLASSes; error reporting on CLASS-DEFAULT-INITARGS, CLASS-PRECEDENCE-LIST and CLASS-SLOTS has been improved; + ** SXHASH on CLOS instances now uses a slot internal to the + instance to return different numbers on distinct instances, + while preserving the same return value through invocations of + CHANGE-CLASS; * fixed some bugs shown by Paul Dietz' test suite: ** DOLIST puts its body in TAGBODY ** SET-EXCLUSIVE-OR sends arguments to :TEST function in the diff --git a/doc/beyond-ansi.sgml b/doc/beyond-ansi.sgml index 3ede78f..e175fa4 100644 --- a/doc/beyond-ansi.sgml +++ b/doc/beyond-ansi.sgml @@ -116,6 +116,14 @@ GCed. whose instances can be used as Lisp streams (e.g. passed as the first argument to format). +&SBCL; supports a MetaObject Protocol which is intended to be +compatible with &AMOP;; exceptions to this (as distinct from current +bugs) are that +compute-effective-method only returns one value, not +two. + Support For Unix</> diff --git a/doc/user-manual.sgml b/doc/user-manual.sgml index 208b299..1afac1c 100644 --- a/doc/user-manual.sgml +++ b/doc/user-manual.sgml @@ -1,6 +1,7 @@ <!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook V3.1//EN" [ <!-- markup for common expressions --> + <!ENTITY AMOP "<acronym>AMOP</>"> <!ENTITY ANSI "<acronym>ANSI</>"> <!ENTITY CMUCL "<application>CMU CL</>"> <!ENTITY IEEE "<acronym>IEEE</>"> diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp index 347fc5c..5e7b3d9 100644 --- a/src/code/target-sxhash.lisp +++ b/src/code/target-sxhash.lisp @@ -145,14 +145,7 @@ (logxor 422371266 (sxhash ; through DEFTRANSFORM (class-name (layout-class (%instance-layout x))))) - ;; Nice though it might be to return a nontrivial - ;; hash value for other instances (especially - ;; STANDARD-OBJECTs) there seems to be no good way - ;; to do so. We can't even do the CLASS-NAME trick - ;; (as used above for STRUCTURE-OBJECT) because - ;; then CHANGE-CLASS would cause SXHASH values to - ;; change, ouch! -- WHN recording wisdom of CSR - 309518995)) + (sxhash-instance x))) (symbol (sxhash x)) ; through DEFTRANSFORM (array (typecase x @@ -169,6 +162,7 @@ (sxhash (char-code x)))) ; through DEFTRANSFORM ;; general, inefficient case of NUMBER (number (sxhash-number x)) + (generic-function (sxhash-instance x)) (t 42)))) (sxhash-recurse x))) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 548252e..b2ed047 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -33,7 +33,7 @@ (defun allocate-standard-instance (wrapper &optional (slots-init nil slots-init-p)) - (let ((instance (%make-standard-instance nil)) + (let ((instance (%make-standard-instance nil (get-instance-hash-code))) (no-of-slots (wrapper-no-of-instance-slots wrapper))) (setf (std-instance-wrapper instance) wrapper) (setf (std-instance-slots instance) @@ -63,7 +63,8 @@ (defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p)) - (let ((fin (%make-pcl-funcallable-instance nil nil))) + (let ((fin (%make-pcl-funcallable-instance nil nil + (get-instance-hash-code)))) (set-funcallable-instance-fun fin #'(sb-kernel:instance-lambda (&rest args) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index dd2295d..073228d 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -80,7 +80,7 @@ ;; 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) + :slot-names (clos-slots name hash-code) :boa-constructor %make-pcl-funcallable-instance :superclass-name sb-kernel:funcallable-instance :metaclass-name sb-kernel:random-pcl-class @@ -105,8 +105,15 @@ `(funcallable-instance-p ,fin)) (defmacro fsc-instance-wrapper (fin) `(sb-kernel:%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) `(sb-kernel:%funcallable-instance-info ,fin 0)) +(defmacro fsc-instance-hash (fin) + `(sb-kernel:%funcallable-instance-info ,fin 3)) (declaim (inline clos-slots-ref (setf clos-slots-ref))) (declaim (ftype (function (simple-vector index) t) clos-slots-ref)) @@ -250,7 +257,7 @@ (slots nil)) |# (sb-kernel:!defstruct-with-alternate-metaclass standard-instance - :slot-names (slots) + :slot-names (slots hash-code) :boa-constructor %make-standard-instance :superclass-name sb-kernel:instance :metaclass-name cl:standard-class @@ -262,6 +269,9 @@ ;;; weakening of STD-INSTANCE-P. (defmacro std-instance-slots (x) `(sb-kernel:%instance-ref ,x 1)) (defmacro std-instance-wrapper (x) `(sb-kernel:%instance-layout ,x)) +;;; KLUDGE: This one doesn't "work" on structures. However, we +;;; ensure, in SXHASH and friends, never to call it on structures. +(defmacro std-instance-hash (x) `(sb-kernel:%instance-ref ,x 2)) ;;; FIXME: These functions are called every place we do a ;;; CALL-NEXT-METHOD, and probably other places too. It's likely worth @@ -294,6 +304,20 @@ ,wrapper nil))) +;;;; support for useful hashing of PCL instances +(let ((hash-code 0)) + (declare (fixnum hash-code)) + (defun get-instance-hash-code () + (if (< hash-code most-positive-fixnum) + (incf hash-code) + (setq hash-code 0)))) + +(defun sb-impl::sxhash-instance (x) + (cond + ((std-instance-p x) (std-instance-hash x)) + ((fsc-instance-p x) (fsc-instance-hash x)) + (t (bug "SXHASH-INSTANCE called on some weird thing: ~S" x)))) + ;;;; structure-instance stuff ;;;; ;;;; FIXME: Now that the code is SBCL-only, this extra layer of diff --git a/tests/hash.impure.lisp b/tests/hash.impure.lisp index f2874dc..5a461ab 100644 --- a/tests/hash.impure.lisp +++ b/tests/hash.impure.lisp @@ -51,7 +51,9 @@ (complex 1.0 2.0) (complex 1.0d0 2.0) (complex 1.5 -3/2) (complex 1.5 -1.5d0) - #\x #\X #\*)) + #\x #\X #\* + + #'allocate-instance #'no-applicable-method)) (make-psxhash-extra-subtests () (list (copy-seq "") (copy-seq #*) diff --git a/version.lisp-expr b/version.lisp-expr index 26ebe00..3991fe8 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.9.35" +"0.7.9.36"