/
defclass-support.lisp
282 lines (254 loc) · 11.5 KB
/
defclass-support.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
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
(cl:in-package #:sicl-clos)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Functions to canonicalize certain parts of the defclass macro
;;; The DEFCLASS macro. The AMOP is inconsistent with respect to the
;;; CLHS. For instance, it requires the arguments to ENSURE-CLASS to
;;; appear in the same order as they appear in the DEFCLASS form, but
;;; that should not matter since they are not evaluated. The CLHS
;;; explicitly allows for DEFCLASS to support additional class
;;; options.
;;; The AMOP says that the NAME argument to DEFCLASS becomes the first
;;; argument to ENSURE-CLASS. Nothing particular here.
;;;
;;; The AMOP says that the SUPERCLASS-NAMES argument to DEFCLASS
;;; becomes the value of the :DIRECT-SUPERCLASSES argument to
;;; ENSURE-CLASS. The CLHS requires that the DIRECT-SUPERCLASSES
;;; argument to DEFCLASS be a proper list of non-NIL symbols.
(defun canonicalize-direct-superclass-name (class-name)
(unless (and (symbolp class-name)
(not (null class-name)))
(error 'class-name-must-be-non-nil-symbol
:name class-name))
class-name)
(defun canonicalize-direct-superclass-names (direct-superclass-names)
(unless (cleavir-code-utilities:proper-list-p direct-superclass-names)
(error 'superclass-list-must-be-proper-list
:datum direct-superclass-names))
(loop for name in direct-superclass-names
collect (canonicalize-direct-superclass-name name)))
(declaim (notinline make-initfunction))
(defun make-initfunction (form)
`(lambda () ,form))
(defun check-slot-spec-non-empty-proper-list (direct-slot-spec)
(unless (and (cleavir-code-utilities:proper-list-p direct-slot-spec)
(consp direct-slot-spec))
(error 'malformed-slot-spec
:slot-spec direct-slot-spec)))
(defun check-slot-spec-name-is-symbol (direct-slot-spec)
(unless (symbolp (car direct-slot-spec))
(error 'illegal-slot-name
:slot-name (car direct-slot-spec))))
(defun check-slot-options-even-length (direct-slot-spec)
(unless (evenp (length (cdr direct-slot-spec)))
(error 'slot-options-must-be-even
:options direct-slot-spec)))
(defun populate-table-with-slot-options (table slot-options)
(loop for (name value) on slot-options by #'cddr
do (unless (symbolp name)
(error 'slot-option-name-must-be-symbol
:option-name name))
(push value (gethash name table '()))))
(defun process-initform-option (table direct-slot-spec)
(multiple-value-bind (value flag) (gethash :initform table)
(if flag
(progn (unless (= (length value) 1)
(error 'multiple-initform-options-not-permitted
:datum direct-slot-spec))
(remhash :initform table)
`(:initform ',(car value)
:initfunction ,(make-initfunction (car value))))
'())))
(defun process-initarg-options (table)
(multiple-value-bind (value flag)
(gethash :initarg table)
(if flag
(progn (remhash :initarg table)
`(:initargs ',(reverse value)))
'())))
(defun split-accessors (table)
(multiple-value-bind (value flag) (gethash :accessor table)
(when flag
(loop for accessor in value
do (push accessor (gethash :reader table '()))
(push `(setf ,accessor) (gethash :writer table '())))
(remhash :accessor table))))
(defun process-readers (table)
(multiple-value-bind (value flag)
(gethash :reader table)
(if flag
(progn (remhash :reader table)
`(:readers ',(reverse value)))
'())))
(defun process-writers (table)
(multiple-value-bind (value flag)
(gethash :writer table)
(if flag
(progn (remhash :writer table)
`(:writers ',(reverse value)))
'())))
(defun process-documentation (table direct-slot-spec)
(multiple-value-bind (value flag) (gethash :documentation table)
(if flag
(progn (unless (= (length value) 1)
(error 'multiple-documentation-options-not-permitted
:datum direct-slot-spec))
(unless (stringp (car value))
(error 'slot-documentation-option-must-be-string
:datum (car value)))
(remhash :documentation table)
`(:documentation ,(car value)))
'())))
(defun process-allocation (table direct-slot-spec)
(multiple-value-bind (value flag) (gethash :allocation table)
(if flag
(progn (unless (= (length value) 1)
(error 'multiple-allocation-options-not-permitted
:slot-specifier direct-slot-spec))
(remhash :allocation table)
`(:allocation ,(car value)))
'())))
(defun process-type (table direct-slot-spec)
(multiple-value-bind (value flag)
(gethash :type table)
(if flag
(progn (unless (= (length value) 1)
(error 'multiple-type-options-not-permitted
:datum direct-slot-spec))
(remhash :type table)
`(:type ',(car value))))))
(defun canonicalize-direct-slot-spec (direct-slot-spec)
;; A direct-slot-spec can be a symbol which is then the
;; name of the slot.
(if (symbolp direct-slot-spec)
`(:name ',direct-slot-spec)
(progn
;; If the direct-slot-spec is not a symbol, it must
;; be a non-empty proper list.
(check-slot-spec-non-empty-proper-list direct-slot-spec)
;; In that case, the first element must be the name
;; of the slot, which must be a symbol.
(check-slot-spec-name-is-symbol direct-slot-spec)
;; The slot options must be a list of even length
;; where every other element is the name of a slot
;; option and every other element is the value of
;; the slot option.
(check-slot-options-even-length direct-slot-spec)
(let ((ht (make-hash-table :test #'eq)))
(populate-table-with-slot-options ht (cdr direct-slot-spec))
(let ((result `(:name ',(car direct-slot-spec))))
(flet ((add (option)
(setf result (append result option))))
(add (process-initform-option ht direct-slot-spec))
(add (process-initarg-options ht))
(split-accessors ht)
(add (process-readers ht))
(add (process-writers ht))
(add (process-documentation ht direct-slot-spec))
(add (process-allocation ht direct-slot-spec))
(add (process-type ht direct-slot-spec))
;; Add remaining options without checking.
(maphash (lambda (name value)
(add (list name (reverse value))))
ht))
`(list ,@result))))))
(defun canonicalize-direct-slot-specs (direct-slot-specs)
(when (not (cleavir-code-utilities:proper-list-p direct-slot-specs))
(error 'malformed-slot-list
:slot-list direct-slot-specs))
`(list ,@(loop for spec in direct-slot-specs
collect (canonicalize-direct-slot-spec spec))))
;;; Canonicalize a single default initarg. Recall that a
;;; canonicalized default initarg is a list of three elements: The
;;; symbol naming the initarg, the form to be used for to compute the
;;; initial value, and a lambda expression representing the thunk
;;; that, when called, returns the value of the form.
(defun canonicalize-default-initarg (name form)
(unless (symbolp name)
(error 'default-initarg-name-must-be-symbol
:datum name))
`(list ,name ',form (lambda () ,form)))
;;; Canonicalize the :DEFAULT-INITARGS class option.
(defun canonicalize-default-initargs (initargs)
(unless (cleavir-code-utilities:proper-list-p initargs)
(error 'malformed-default-initargs-option
:option `(:default-initargs ,@initargs)))
(unless (evenp (length initargs))
(error 'malformed-default-initargs-option
:option `(:default-initargs ,@initargs)))
`(list ,@(loop for (name value) on initargs by #'cddr
collect (canonicalize-default-initarg name value))))
(defun check-options-non-empty (options)
;; Check that each option is a non-empty list
(let ((potential-malformed-option (member-if-not #'consp options)))
(unless (null potential-malformed-option)
(error 'class-option-must-be-non-empty-list
:option (car potential-malformed-option)))))
(defun check-option-names (options)
;; Check that the name of each option is a symbol
(let ((potential-malformed-option (member-if-not #'symbolp options :key #'car)))
(unless (null potential-malformed-option)
(error 'class-option-name-must-be-symbol
:option-name (car potential-malformed-option)))))
(defun check-no-duplicate-option-names (options)
;; Check that there are no duplicate option names
(let ((reduced-options (remove-duplicates options :key #'car :test #'eq)))
(when (< (length reduced-options) (length options))
(loop for option in reduced-options
do (when (> (count (car option) options
:key #'car :test #'eq) 1)
(error 'duplicate-class-option-not-allowed
:option (car option)))))))
;;; Make sure each class options is well formed, and check that a
;;; class option appears at most once. Return a list of class
;;; options, including the corresponding keyword argument, to be
;;; spliced into the call to ENSURE-CLASS.
(defun canonicalize-defclass-options (options)
(check-options-non-empty options)
(check-option-names options)
(check-no-duplicate-option-names options)
(let ((result '()))
(loop for option in options
do (case (car option)
(:default-initargs
(setf result
(append result
`(:direct-default-initargs
,(canonicalize-default-initargs (cdr option))))))
(:documentation
(unless (null (cddr option))
(error 'malformed-documentation-option
:documentation-option option))
(setf result
(append result `(:documentation ,(cadr option)))))
(:metaclass
(unless (null (cddr option))
(error 'malformed-metaclass-option
:option option))
(setf result
(append result `(:metaclass ',(cadr option)))))
(t
(setf result
(append result `(,(car option) ,(cdr option)))))))
result))
(defun defclass-expander
(name superclass-names slot-specifiers options environment)
(let* ((canonicalized-superclass-names
(canonicalize-direct-superclass-names superclass-names))
(options (canonicalize-defclass-options options))
(metaclass-name (getf options :metaclass 'standard-class))
(env-var (gensym)))
`(progn
(eval-when (:compile-toplevel)
(let* ((,env-var (env:global-environment ,environment)))
(setf (env:class-description ,env-var ',name)
(env:make-class-description
',name ',canonicalized-superclass-names ',metaclass-name))))
(eval-when (:load-toplevel :execute)
(ensure-class ',name
:name ',name
:direct-superclasses
',canonicalized-superclass-names
:direct-slots
,(canonicalize-direct-slot-specs slot-specifiers)
,@options)))))