-
Notifications
You must be signed in to change notification settings - Fork 1
/
fake-slots.lisp
56 lines (50 loc) · 2.13 KB
/
fake-slots.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
;;;; fake-slots.lisp
(in-package #:zacl)
;;;
;;; "Fake" slots are simulating slot values and accessors with slot
;;; data stored outside the actual instance. It's for things like
;;; EXCL::STREAM-PROPERTY-LIST, where the property list of the stream
;;; is implemented as a slot in Allegro CL, but it's more convenient
;;; to store it outside the instance on non-Allegro CL.
;;;
;;; External slot data is stored in a weak hash table keyed on the
;;; instance.
;;;
(defvar *fake-slots-table*
(make-hash-table))
(defun ensure-fake-slot-table (slot-name class-name)
(let ((class-table (gethash class-name *fake-slots-table*)))
(unless class-table
(setf class-table
(setf (gethash class-name *fake-slots-table*)
(make-hash-table))))
(let ((slot-table (gethash slot-name class-table)))
(unless slot-table
(setf slot-table
(setf (gethash slot-name class-table)
(make-weak-hash-table))))
slot-table)))
(defun fake-slot-table (slot-name class-name)
(gethash slot-name (gethash class-name *fake-slots-table*)))
(defmacro def-fake-slot (slot-name class-name
&key accessor (default-value nil default-value-p))
(unless accessor
(setf accessor slot-name))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(ensure-fake-slot-table ',slot-name ',class-name))
(defgeneric ,accessor (,class-name)
(:method ((object ,class-name))
(let ((table (fake-slot-table ',slot-name ',class-name)))
(multiple-value-bind (value foundp)
(gethash object table)
(cond (foundp value)
,@ (if default-value-p
`((t
(setf (gethash object table) ,default-value)))
`((t
(slot-unbound (class-of object) object ',slot-name)))))))))
(defgeneric (setf ,accessor) (,class-name new-value)
(:method (new-value (object ,class-name))
(let ((table (fake-slot-table ',slot-name ',class-name)))
(setf (gethash object table) new-value))))))