1;; https://sourceforge.net/p/clisp/bugs/286/ 2;; user-defined :allocation :hash 3 4(defpackage #:hash-classes 5 (:use #:common-lisp 6 #+allegro #:clos 7 #+clisp #:clos 8 #+cmu #:clos-mop 9 #+lispworks #:clos 10 #+(and mcl (not openmcl)) #:mcl-mop 11 #+openmcl #:openmcl-mop 12 #+sbcl #:sb-mop) 13 (:export #:hash-class)) 14 15(in-package #:hash-classes) 16 17(defclass hash-class (standard-class) 18 ()) 19 20(defclass hash-object (standard-object) 21 ((hash-slots :initform (make-hash-table :test #'eq)))) 22 23(defmethod validate-superclass ((class hash-class) (superclass standard-class)) 24 t) 25 26(defmethod initialize-instance :around 27 ((class hash-class) &rest initargs &key direct-superclasses) 28 (declare (dynamic-extent initargs)) 29 (if (loop for class in direct-superclasses 30 thereis (subtypep class (find-class 'hash-object))) 31 (call-next-method) 32 (apply #'call-next-method 33 class 34 :direct-superclasses 35 (append direct-superclasses 36 (list (find-class 'hash-object))) 37 initargs))) 38 39(defmethod reinitialize-instance :around 40 ((class hash-class) &rest initargs 41 &key (direct-superclasses '() direct-superclasses-p)) 42 (declare (dynamic-extent initargs)) 43 (if (or (not direct-superclasses-p) 44 (loop for class in direct-superclasses 45 thereis (subtypep class (find-class 'hash-object)))) 46 (call-next-method) 47 (apply #'call-next-method 48 class 49 :direct-superclasses 50 (append direct-superclasses 51 (list (find-class 'hash-object))) 52 initargs))) 53 54(defclass hash-direct-slot-definition (standard-direct-slot-definition) 55 ()) 56 57(defmethod direct-slot-definition-class ((class hash-class) &rest initargs) 58 (declare (ignore initargs)) 59 (find-class 'hash-direct-slot-definition)) 60 61(defclass hash-effective-slot-definition (standard-effective-slot-definition) 62 ()) 63 64(defvar *effective-slot-definition-class*) 65 66(defmethod compute-effective-slot-definition 67 ((class hash-class) (name t) direct-slot-definitions) 68 (let ((*effective-slot-definition-class* 69 (if (eq (slot-definition-allocation (first direct-slot-definitions)) 70 :hash) 71 (find-class 'hash-effective-slot-definition) 72 (find-class 'standard-effective-slot-definition)))) 73 (call-next-method))) 74 75(defmethod effective-slot-definition-class ((class hash-class) &rest initargs) 76 (declare (ignore initargs)) 77 *effective-slot-definition-class*) 78 79(defmethod shared-initialize :before 80 ((object hash-object) slot-names &rest initargs) 81 (declare (ignore slot-names initargs)) 82 (unless (slot-boundp object 'hash-slots) 83 (setf (slot-value object 'hash-slots) 84 (make-hash-table :test #'eq)))) 85 86(defmethod slot-value-using-class 87 ((class hash-class) object (slot hash-effective-slot-definition)) 88 (multiple-value-bind (value present-p) 89 (gethash (slot-definition-name slot) 90 (slot-value object 'hash-slots)) 91 (if present-p value 92 (slot-unbound class object (slot-definition-name slot))))) 93 94(defmethod (setf slot-value-using-class) 95 (value (class hash-class) object (slot hash-effective-slot-definition)) 96 (setf (gethash (slot-definition-name slot) 97 (slot-value object 'hash-slots)) 98 value)) 99 100(defmethod slot-boundp-using-class 101 ((class hash-class) object (slot hash-effective-slot-definition)) 102 (nth-value 1 (gethash (slot-definition-name slot) 103 (slot-value object 'hash-slots)))) 104 105(defmethod slot-makunbound-using-class 106 ((class hash-class) object (slot hash-effective-slot-definition)) 107 (remhash (slot-definition-name slot) 108 (slot-value object 'hash-slots))) 109