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