1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2009 Clozure Associates |
---|
4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
5 | ;;; This file is part of Clozure CL. |
---|
6 | ;;; |
---|
7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
11 | ;;; conflict, the preamble takes precedence. |
---|
12 | ;;; |
---|
13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
14 | ;;; |
---|
15 | ;;; The LLGPL is also available online at |
---|
16 | ;;; http://opensource.franz.com/preamble.html |
---|
17 | |
---|
18 | ; defstruct-lds.lisp |
---|
19 | |
---|
20 | (in-package "CCL") |
---|
21 | |
---|
22 | (eval-when (eval compile) |
---|
23 | (require 'defstruct-macros) |
---|
24 | ) |
---|
25 | |
---|
26 | |
---|
27 | |
---|
28 | |
---|
29 | (defun uvector-subtype-p (thing subtype-number) |
---|
30 | (= (the fixnum (typecode thing)) subtype-number)) |
---|
31 | |
---|
32 | (defun uvector (subtype &rest p) |
---|
33 | (declare (dynamic-extent p)) |
---|
34 | (let ((n (length p)) (uv)) |
---|
35 | (setq uv (%alloc-misc n subtype)) |
---|
36 | (dotimes (i (the fixnum n)) (declare (fixnum i)) (uvset uv i (pop p))) |
---|
37 | uv)) |
---|
38 | |
---|
39 | ;(defmacro test (&rest args) `(macroexpand-1 (defstruct ,@args))) |
---|
40 | |
---|
41 | ;--> To do: compiler transform for copier, possibly constructor. |
---|
42 | (defmacro defstruct (options &rest slots &environment env) |
---|
43 | "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)} |
---|
44 | Define the structure type Name. Instances are created by MAKE-<name>, |
---|
45 | which takes &KEY arguments allowing initial slot values to the specified. |
---|
46 | A SETF'able function <name>-<slot> is defined for each slot to read and |
---|
47 | write slot values. <name>-p is a type predicate. |
---|
48 | |
---|
49 | Popular DEFSTRUCT options (see manual for others): |
---|
50 | |
---|
51 | (:CONSTRUCTOR Name) |
---|
52 | (:PREDICATE Name) |
---|
53 | Specify the name for the constructor or predicate. |
---|
54 | |
---|
55 | (:CONSTRUCTOR Name Lambda-List) |
---|
56 | Specify the name and arguments for a BOA constructor |
---|
57 | (which is more efficient when keyword syntax isn't necessary.) |
---|
58 | |
---|
59 | (:INCLUDE Supertype Slot-Spec*) |
---|
60 | Make this type a subtype of the structure type Supertype. The optional |
---|
61 | Slot-Specs override inherited slot options. |
---|
62 | |
---|
63 | Slot options: |
---|
64 | |
---|
65 | :TYPE Type-Spec |
---|
66 | Asserts that the value of this slot is always of the specified type. |
---|
67 | |
---|
68 | :READ-ONLY {T | NIL} |
---|
69 | If true, no setter function is defined for this slot." |
---|
70 | ;There's too much state to keep around here to break it up into little |
---|
71 | ;functions, so what the hell, let's do it all inline... |
---|
72 | (prog (struct-name type conc-name constructor copier predicate include |
---|
73 | print-function print-object named initial-offset boa-constructors print-p |
---|
74 | documentation (slot-list ()) (offset 0) superclasses sd |
---|
75 | refnames) |
---|
76 | ;Parse options |
---|
77 | (if (atom options) |
---|
78 | (setq struct-name options options ()) |
---|
79 | (setq struct-name (pop options))) |
---|
80 | (unless (symbolp struct-name) (signal-program-error $XNotSym struct-name)) |
---|
81 | (let (name args constructor-p predicate-p) |
---|
82 | (while options |
---|
83 | (if (atom (car options)) |
---|
84 | (setq name (%car options) args ()) |
---|
85 | (setq name (%caar options) args (%cdar options))) |
---|
86 | (case name |
---|
87 | (:conc-name |
---|
88 | (when conc-name (go dup-options)) |
---|
89 | (when (cdr args) (go bad-options)) |
---|
90 | (setq conc-name (or args (list nil)))) |
---|
91 | (:constructor |
---|
92 | (when (cddr args) (go bad-options)) |
---|
93 | (cond ((cdr args) (push args boa-constructors)) |
---|
94 | (t (when constructor (go dup-options)) |
---|
95 | (unless (symbolp (%car args)) (go bad-options)) |
---|
96 | (setq constructor-p t constructor args)))) |
---|
97 | (:copier |
---|
98 | (when copier (go dup-options)) |
---|
99 | (when (or (cdr args) (not (symbolp (%car args)))) (go bad-options)) |
---|
100 | (setq copier args)) |
---|
101 | (:predicate |
---|
102 | (when predicate (go dup-options)) |
---|
103 | (when (or (cdr args) (not (symbolp (%car args)))) (go bad-options)) |
---|
104 | (setq predicate-p t predicate args)) |
---|
105 | (:include |
---|
106 | (when include (go dup-options)) |
---|
107 | (when (or (null args) (not (symbolp (car args)))) (go bad-options)) |
---|
108 | (setq include args)) |
---|
109 | ((:print-function :print-object) |
---|
110 | (when print-function (go dup-options)) |
---|
111 | (when (or (cdr args) |
---|
112 | (not (or (symbolp (%car args)) |
---|
113 | (and (consp (%car args)) (eq (%caar args) 'lambda))))) |
---|
114 | (go bad-options)) |
---|
115 | (setq print-p t |
---|
116 | print-function (%car args) |
---|
117 | print-object (eq name :print-object))) |
---|
118 | (:type |
---|
119 | (when type (go dup-options)) |
---|
120 | (when (cdr args) (go bad-options)) |
---|
121 | (unless (eq (setq type (%car args)) 'list) |
---|
122 | (when (eq type 'vector) (setq type '(vector t))) |
---|
123 | (when (or (atom type) (neq (%car type) 'vector) (cdr (%cdr type))) |
---|
124 | (go bad-options)))) |
---|
125 | (:named |
---|
126 | (when args (go bad-options)) |
---|
127 | (setq named t)) |
---|
128 | (:initial-offset |
---|
129 | (when initial-offset (go dup-options)) |
---|
130 | (when (or (cdr args) (not (fixnump (%car args))) (%i< (%car args) 0)) |
---|
131 | (go bad-options)) |
---|
132 | (setq initial-offset (%car args))) |
---|
133 | (t (go bad-options))) |
---|
134 | (setq options (%cdr options))) |
---|
135 | ;Options parsed! Do defaulting and some consistency checking. |
---|
136 | (cond (type |
---|
137 | (when (null (defstruct-reftype type)) ;e.g. (vector NIL) |
---|
138 | (bad-named-arg :type type)) |
---|
139 | (when print-p |
---|
140 | (error "Cannot specify ~S with ~S" :print-function :type)) |
---|
141 | (if (and named (consp type) (eq (car type) 'vector) |
---|
142 | (cadr type) (not (subtypep 'symbol (cadr type)))) |
---|
143 | (error "Cannot specify ~S with type: ~S" :named type)) |
---|
144 | ) |
---|
145 | ((built-in-type-p struct-name) |
---|
146 | (error "Cannot redefine built-in type ~S" struct-name)) |
---|
147 | (initial-offset |
---|
148 | (error "Cannot use ~S without ~S" :initial-offset :type)) |
---|
149 | (t (setq named t))) |
---|
150 | (if (not named) |
---|
151 | (when predicate-p |
---|
152 | (unless (null (setq predicate (%car predicate))) |
---|
153 | (error "Cannot specify :PREDICATE for an unnamed structure"))) |
---|
154 | (setq predicate (if (null predicate) |
---|
155 | (concat-pnames struct-name "-P") |
---|
156 | (%car predicate)))) |
---|
157 | (setq conc-name |
---|
158 | (if (null conc-name) (%str-cat (symbol-name struct-name) "-") |
---|
159 | (if (%car conc-name) (string (%car conc-name))))) |
---|
160 | (unless (and boa-constructors (not constructor-p)) |
---|
161 | (setq constructor |
---|
162 | (if (null constructor) |
---|
163 | (concat-pnames "MAKE-" struct-name) (%car constructor)))) |
---|
164 | (setq copier |
---|
165 | (if (null copier) (concat-pnames "COPY-" struct-name) (%car copier)))) |
---|
166 | ;Process included slots |
---|
167 | (when include |
---|
168 | (let* ((included-name (%car include)) |
---|
169 | (sub-sd (or (let* ((defenv (definition-environment env))) |
---|
170 | (when defenv (%cdr (assq included-name (defenv.structures defenv))))) |
---|
171 | (gethash included-name %defstructs%))) |
---|
172 | (slots (%cdr include)) |
---|
173 | name args ssd) |
---|
174 | (unless sub-sd (error "No such structure: ~S" (cons :include include))) |
---|
175 | (unless (eq (defstruct-reftype type) |
---|
176 | (defstruct-reftype (sd-type sub-sd))) |
---|
177 | (error "Incompatible structure type ~S for ~S" |
---|
178 | (sd-type sub-sd) (cons :include include))) |
---|
179 | (dolist (ssd (sd-slots sub-sd)) (push |
---|
180 | (let* ((new-ssd (copy-ssd ssd))) |
---|
181 | (ssd-set-inherited new-ssd) |
---|
182 | new-ssd) |
---|
183 | slot-list)) |
---|
184 | (while slots |
---|
185 | (if (atom (car slots)) |
---|
186 | (setq name (%car slots) args ()) |
---|
187 | (setq name (%caar slots) args (%cdar slots))) |
---|
188 | (unless (symbolp name) (signal-program-error $XNotSym name)) |
---|
189 | (unless (setq ssd (named-ssd name slot-list)) |
---|
190 | (error "~S has no ~S slot, in ~S" |
---|
191 | (sd-name sub-sd) name (cons :include include))) |
---|
192 | (ssd-set-initform ssd (pop args)) |
---|
193 | (while args |
---|
194 | (when (atom (cdr args)) (signal-program-error "~S is not a proper list" (cdr args))) |
---|
195 | (cond ((eq (%car args) :type) ) |
---|
196 | ((eq (%car args) :read-only) |
---|
197 | (when (and (not (%cadr args)) (ssd-r/o ssd)) |
---|
198 | (signal-program-error "Slot ~S in ~S must be read-only" name (sd-name sub-sd))) |
---|
199 | (when (%cadr args) (ssd-set-r/o ssd))) |
---|
200 | (t (signal-program-error "~S must be (member :type :read-only)." (%car args)))) |
---|
201 | (setq args (%cddr args))) |
---|
202 | (setq slots (%cdr slots))) |
---|
203 | (setq offset (sd-size sub-sd)) |
---|
204 | (setq superclasses (sd-superclasses sub-sd)))) |
---|
205 | (push struct-name superclasses) |
---|
206 | ;Now add own slots |
---|
207 | (setq offset (%i+ offset (or initial-offset 0))) |
---|
208 | (when (and named (or type (not include))) |
---|
209 | (push (make-ssd 0 (if type `',struct-name `',superclasses) offset t) slot-list) |
---|
210 | (setq named offset offset (%i+ offset 1))) |
---|
211 | (when (stringp (%car slots)) |
---|
212 | (setq documentation (%car slots) slots (%cdr slots))) |
---|
213 | (let (name args read-only initform slot-type) |
---|
214 | (while slots |
---|
215 | (if (atom (%car slots)) |
---|
216 | (setq name (%car slots) args ()) |
---|
217 | (setq name (%caar slots) args (%cdar slots))) |
---|
218 | (unless (symbolp name) (go bad-slot)) |
---|
219 | (setq read-only nil initform (pop args) slot-type t) |
---|
220 | (while args |
---|
221 | (when (atom (cdr args)) (go bad-slot)) |
---|
222 | ;; To do: check for multiple/incompatible options. |
---|
223 | (cond ((eq (%car args) :type) |
---|
224 | (setq slot-type (%cadr args))) |
---|
225 | ((eq (%car args) :read-only) |
---|
226 | (setq read-only (%cadr args))) |
---|
227 | (t (go bad-slot))) |
---|
228 | (setq args (%cddr args))) |
---|
229 | (specifier-type slot-type env) ;; Check for validity (signals program error) |
---|
230 | (push (make-ssd name initform offset read-only slot-type) slot-list) |
---|
231 | (setq slots (%cdr slots) offset (%i+ offset 1)))) |
---|
232 | (setq slot-list (nreverse slot-list)) |
---|
233 | (when (and (null type) include) |
---|
234 | (ssd-set-initform (car slot-list) `',superclasses)) |
---|
235 | (progn ;when conc-name |
---|
236 | (dolist (slot slot-list) |
---|
237 | (unless (fixnump (ssd-name slot)) |
---|
238 | (push (if conc-name |
---|
239 | (concat-pnames conc-name (ssd-name slot)) |
---|
240 | (ssd-name slot)) |
---|
241 | refnames))) |
---|
242 | (setq refnames (nreverse refnames))) |
---|
243 | (setq sd (vector type slot-list superclasses offset constructor () refnames)) |
---|
244 | (return |
---|
245 | `(progn |
---|
246 | ,@(when (null (sd-type sd)) |
---|
247 | `((when (memq ',struct-name *nx-known-declarations*) |
---|
248 | (check-declaration-redefinition ',struct-name 'defstruct)))) |
---|
249 | (remove-structure-defs ',struct-name) ; lose any previous defs |
---|
250 | ,.(defstruct-slot-defs sd refnames env) |
---|
251 | ,.(if copier (defstruct-copier sd copier env)) |
---|
252 | ,.(if predicate (defstruct-predicate sd named predicate env)) |
---|
253 | (eval-when (:compile-toplevel) |
---|
254 | (define-compile-time-structure |
---|
255 | ',sd |
---|
256 | ',refnames |
---|
257 | ,(if (and predicate (null (sd-type sd))) `',predicate) |
---|
258 | ,env)) |
---|
259 | (%defstruct-do-load-time |
---|
260 | ',sd |
---|
261 | ,(if (and predicate (null (sd-type sd))) `',predicate) |
---|
262 | ,.(if documentation (list documentation))) |
---|
263 | ,.(%defstruct-compile sd refnames env) |
---|
264 | ,.(defstruct-boa-constructors sd boa-constructors) |
---|
265 | ,.(if constructor (list (defstruct-constructor sd constructor))) |
---|
266 | ;; Wait until slot accessors are defined, to avoid |
---|
267 | ;; undefined function warnings in the print function/method. |
---|
268 | (%defstruct-set-print-function |
---|
269 | ',sd |
---|
270 | ,(if print-function |
---|
271 | (if (symbolp print-function) |
---|
272 | `',print-function |
---|
273 | `#',print-function) |
---|
274 | (unless print-p (if include 0))) |
---|
275 | ,print-object) |
---|
276 | ',struct-name)) |
---|
277 | |
---|
278 | dup-options |
---|
279 | (error "Duplicate ~S options not allowed" (%car options)) |
---|
280 | bad-options |
---|
281 | (signal-program-error "Bad defstruct option ~S." (%car options)) |
---|
282 | bad-slot |
---|
283 | (signal-program-error "Bad defstruct slot spec ~S." (%car slots)))) |
---|
284 | |
---|
285 | (defun concat-pnames (name1 name2) |
---|
286 | (intern (%str-cat (string name1) (string name2)))) |
---|
287 | |
---|
288 | (defun wrap-with-type-declaration (value slot &aux (slot-type (ssd-type slot))) |
---|
289 | (if (eq t slot-type) |
---|
290 | value |
---|
291 | `(the ,slot-type ,value))) |
---|
292 | |
---|
293 | (defun make-class-cells-list (class-names) |
---|
294 | (if (and (consp class-names) |
---|
295 | (eq (car class-names) 'quote) |
---|
296 | (consp (cdr class-names)) |
---|
297 | (null (cddr class-names)) |
---|
298 | (listp (cadr class-names)) |
---|
299 | (every #'symbolp (cadr class-names))) |
---|
300 | `',(mapcar (lambda (name) (find-class-cell name t)) (cadr class-names)) |
---|
301 | class-names)) |
---|
302 | |
---|
303 | (defun defstruct-constructor (sd constructor &aux (offset 0) |
---|
304 | (args ()) |
---|
305 | (values ()) |
---|
306 | slot-offset |
---|
307 | name) |
---|
308 | (dolist (slot (sd-slots sd)) |
---|
309 | (setq slot-offset (ssd-offset slot)) |
---|
310 | #-bccl (when (%i< slot-offset offset) |
---|
311 | (error "slots out of order! ~S" (sd-slots sd))) |
---|
312 | (while (%i< offset slot-offset) |
---|
313 | (push nil values) |
---|
314 | (setq offset (%i+ offset 1))) |
---|
315 | (if (fixnump (setq name (ssd-name slot))) |
---|
316 | (if (eql 0 name) |
---|
317 | (push (make-class-cells-list (ssd-initform slot)) values) |
---|
318 | (push (wrap-with-type-declaration (ssd-initform slot) slot) values)) |
---|
319 | (let* ((temp (make-symbol (symbol-name name)))) |
---|
320 | (push (list (list (make-keyword name) temp) (ssd-initform slot)) args) |
---|
321 | (push (wrap-with-type-declaration temp slot) values))) |
---|
322 | (setq offset (%i+ offset 1))) |
---|
323 | (setq values (nreverse values)) |
---|
324 | `(defun ,constructor (&key ,@(nreverse args)) |
---|
325 | ,(case (setq name (defstruct-reftype (sd-type sd))) |
---|
326 | (#.$defstruct-nth `(list ,@values)) |
---|
327 | (#.target::subtag-simple-vector `(vector ,@values)) |
---|
328 | ((#.target::subtag-struct #.$defstruct-struct) |
---|
329 | `(gvector :struct ,@values)) |
---|
330 | (t `(uvector ,name ,@values))))) |
---|
331 | |
---|
332 | (defun defstruct-boa-constructors (sd boas &aux (list ())) |
---|
333 | (dolist (boa boas list) |
---|
334 | (push (defstruct-boa-constructor sd boa) list))) |
---|
335 | |
---|
336 | (defun defstruct-boa-constructor (sd boa &aux (args ()) |
---|
337 | (used-slots ()) |
---|
338 | (values ()) |
---|
339 | (offset 0) |
---|
340 | arg-kind slot slot-offset) |
---|
341 | (unless (verify-lambda-list (cadr boa)) |
---|
342 | (error "Invalid lambda-list in ~S ." (cons :constructor boa))) |
---|
343 | (dolist (arg (cadr boa)) |
---|
344 | (cond ((memq arg lambda-list-keywords) |
---|
345 | (setq arg-kind arg)) |
---|
346 | ((setq slot (named-ssd arg (sd-slots sd))) |
---|
347 | (when (or (eq arg-kind '&optional) (eq arg-kind '&key) |
---|
348 | ;; for &aux variables, init value is |
---|
349 | ;; implementation-defined, however it's not |
---|
350 | ;; supposed to signal a type error until slot is |
---|
351 | ;; assigned, so might as well just use the |
---|
352 | ;; initform. |
---|
353 | (eq arg-kind '&aux)) |
---|
354 | (setq arg (list arg (ssd-initform slot)))) |
---|
355 | (push slot used-slots)) |
---|
356 | ((and (consp arg) (setq slot (named-ssd (if (consp (%car arg)) (%cadar arg) (%car arg)) (sd-slots sd)))) |
---|
357 | (push slot used-slots)) |
---|
358 | (t nil)) |
---|
359 | (push arg args)) |
---|
360 | (dolist (slot (sd-slots sd)) |
---|
361 | (setq slot-offset (ssd-offset slot)) |
---|
362 | #-bccl (when (%i< slot-offset offset) (error "slots out of order! ~S" sd)) |
---|
363 | (while (%i< offset slot-offset) |
---|
364 | (push nil values) |
---|
365 | (setq offset (%i+ offset 1))) |
---|
366 | (push (if (memq slot used-slots) (ssd-name slot) |
---|
367 | (if (eql 0 (ssd-name slot)) |
---|
368 | (make-class-cells-list (ssd-initform slot)) |
---|
369 | (if (constantp (ssd-initform slot)) (ssd-initform slot) |
---|
370 | (progn |
---|
371 | (unless (eq arg-kind '&aux) |
---|
372 | (push (setq arg-kind '&aux) args)) |
---|
373 | (push (list (ssd-name slot) (ssd-initform slot)) args) |
---|
374 | (ssd-name slot))))) |
---|
375 | values) |
---|
376 | (setq offset (%i+ offset 1))) |
---|
377 | (setq values (mapcar #'wrap-with-type-declaration (nreverse values) (sd-slots sd))) |
---|
378 | `(defun ,(car boa) ,(nreverse args) |
---|
379 | ,(case (setq slot (defstruct-reftype (sd-type sd))) |
---|
380 | (#.$defstruct-nth `(list ,@values)) |
---|
381 | (#.target::subtag-simple-vector `(vector ,@values)) |
---|
382 | ((#.target::subtag-struct #.$defstruct-struct) |
---|
383 | `(gvector :struct ,@values)) |
---|
384 | (t `(uvector ,slot ,@values))))) |
---|
385 | |
---|
386 | (defun defstruct-copier (sd copier env) |
---|
387 | `((eval-when (:compile-toplevel) |
---|
388 | (record-function-info ',copier ',*one-arg-defun-def-info* ,env)) |
---|
389 | (fset ',copier |
---|
390 | ,(if (eq (sd-type sd) 'list) '#'copy-list '#'copy-uvector)) |
---|
391 | (record-source-file ',copier 'function))) |
---|
392 | |
---|
393 | (defun defstruct-predicate (sd named predicate env) |
---|
394 | (declare (ignore env)) |
---|
395 | (let* ((arg (gensym)) |
---|
396 | (sd-name (sd-name sd)) |
---|
397 | (body |
---|
398 | (case (sd-type sd) |
---|
399 | ((nil) `(structure-typep ,arg ',(find-class-cell sd-name t))) |
---|
400 | ((list) `(and (consp ,arg) (eq (nth ,named ,arg) ',sd-name))) |
---|
401 | (t `(and (uvector-subtype-p ,arg ,(defstruct-reftype (sd-type sd))) |
---|
402 | (< ,named (uvsize ,arg)) |
---|
403 | (eq (uvref ,arg ,named) ',sd-name)))))) |
---|
404 | `((defun ,predicate (,arg) ,body)))) |
---|
405 | |
---|
406 | ; End of defstruct-lds.lisp |
---|