1 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
2 |
|
|
3 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
4 |
|
;; |
5 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
6 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
7 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
8 |
|
;; any later version. |
9 |
|
;; |
10 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
11 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
12 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
13 |
|
;; License for more details. |
14 |
|
;; |
15 |
|
;; You should have received a copy of the GNU Library General Public License |
16 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
17 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
18 |
|
|
19 |
|
|
20 |
|
;;;; DEFSTRUCT.LSP |
21 |
|
;;;; |
22 |
|
;;;; The structure routines. |
23 |
|
|
24 |
|
|
25 |
|
(in-package 'lisp) |
26 |
|
(export 'defstruct) |
27 |
|
|
28 |
|
|
29 |
|
(in-package 'system) |
30 |
|
|
31 |
|
|
32 |
|
(proclaim '(optimize (safety 2) (space 3))) |
33 |
|
|
34 |
|
|
35 |
|
|
36 |
|
;(in-package 'system) |
37 |
|
|
38 |
|
|
39 |
|
|
40 |
|
(defvar *accessors* (make-array 10 :adjustable t)) |
41 |
|
(defvar *list-accessors* (make-array 2 :adjustable t)) |
42 |
|
(defvar *vector-accessors* (make-array 2 :adjustable t)) |
43 |
|
|
44 |
|
(or (fboundp 'record-fn) (setf (symbol-function 'record-fn) |
45 |
|
#'(lambda (&rest l) l nil))) |
46 |
|
|
47 |
|
(defun make-access-function (name conc-name no-conc type named include no-fun |
48 |
|
;; from apply |
49 |
|
slot-name default-init slot-type read-only |
50 |
|
offset &optional predicate ) |
51 |
|
(declare (ignore named default-init predicate )) |
52 |
|
|
53 |
|
(let ((access-function |
54 |
|
(if no-conc |
55 |
|
slot-name |
56 |
|
(intern (si:string-concatenate (string conc-name) |
57 |
|
(string slot-name))))) |
58 |
|
accsrs dont-overwrite) |
59 |
|
(ecase type |
60 |
|
((nil) |
61 |
|
(setf accsrs *accessors*)) |
62 |
|
(list |
63 |
|
(setf accsrs *list-accessors*)) |
64 |
|
(vector |
65 |
|
(setf accsrs *vector-accessors*))) |
66 |
|
(or (> (length accsrs) offset) |
67 |
|
(adjust-array accsrs (+ offset 10))) |
68 |
|
(unless |
69 |
|
dont-overwrite |
70 |
|
(record-fn access-function 'defun '(t) slot-type) |
71 |
|
(or no-fun |
72 |
|
(and (fboundp access-function) |
73 |
|
(eq (aref accsrs offset) (symbol-function access-function))) |
74 |
|
(setf (symbol-function access-function) |
75 |
|
(or (aref accsrs offset) |
76 |
|
(setf (aref accsrs offset) |
77 |
|
(cond ((eq accsrs *accessors*) |
78 |
|
#'(lambda (x) |
79 |
|
(or (structurep x) |
80 |
|
(error "~a is not a structure" x)) |
81 |
|
(structure-ref1 x offset))) |
82 |
|
((eq accsrs *list-accessors*) |
83 |
|
#'(lambda(x) |
84 |
|
(si:list-nth offset x))) |
85 |
|
((eq accsrs *vector-accessors*) |
86 |
|
#'(lambda(x) |
87 |
|
(aref x offset))))))))) |
88 |
|
(cond (read-only |
89 |
|
(remprop access-function 'structure-access) |
90 |
|
(setf (get access-function 'struct-read-only) t)) |
91 |
|
(t (remprop access-function 'setf-update-fn) |
92 |
|
(remprop access-function 'setf-lambda) |
93 |
|
(remprop access-function 'setf-documentation) |
94 |
|
(let ((tem (get access-function 'structure-access))) |
95 |
|
(cond ((and (consp tem) include |
96 |
|
(subtypep include (car tem)) |
97 |
|
(eql (cdr tem) offset)) |
98 |
|
;; don't change overwrite accessor of subtype. |
99 |
|
(setq dont-overwrite t) |
100 |
|
) |
101 |
|
(t (setf (get access-function 'structure-access) |
102 |
|
(cons (if type type name) offset))))))) |
103 |
|
nil)) |
104 |
|
|
105 |
|
|
106 |
|
(defun make-constructor (name constructor type named |
107 |
|
slot-descriptions) |
108 |
|
(declare (ignore named)) |
109 |
|
(let ((slot-names |
110 |
|
;; Collect the slot-names. |
111 |
|
(mapcar #'(lambda (x) |
112 |
|
(cond ((null x) |
113 |
|
;; If the slot-description is NIL, |
114 |
|
;; it is in the padding of initial-offset. |
115 |
|
nil) |
116 |
|
((null (car x)) |
117 |
|
;; If the slot name is NIL, |
118 |
|
;; it is the structure name. |
119 |
|
;; This is for typed structures with names. |
120 |
|
(list 'quote (cadr x))) |
121 |
|
(t (car x)))) |
122 |
|
slot-descriptions)) |
123 |
|
(keys |
124 |
|
;; Make the keyword parameters. |
125 |
|
(mapcan #'(lambda (x) |
126 |
|
(cond ((null x) nil) |
127 |
|
((null (car x)) nil) |
128 |
|
((null (cadr x)) (list (car x))) |
129 |
|
(t (list (list (car x) (cadr x)))))) |
130 |
|
slot-descriptions))) |
131 |
|
(cond ((consp constructor) |
132 |
|
;; The case for a BOA constructor. |
133 |
|
;; Dirty code!! |
134 |
|
;; We must add an initial value for an optional parameter, |
135 |
|
;; if the default value is not specified |
136 |
|
;; in the given parameter list and yet the initial value |
137 |
|
;; is supplied in the slot description. |
138 |
|
(do ((a (cadr constructor) (cdr a)) (l nil) (vs nil)) |
139 |
|
((endp a) |
140 |
|
;; Add those options that do not appear in the parameter list |
141 |
|
;; as auxiliary paramters. |
142 |
|
;; The parameters are accumulated in the variable VS. |
143 |
|
(setq keys |
144 |
|
(nreconc (cons '&aux l) |
145 |
|
(mapcan #'(lambda (k) |
146 |
|
(if (member (if (atom k) k (car k)) |
147 |
|
vs) |
148 |
|
nil |
149 |
|
(list k))) |
150 |
|
keys)))) |
151 |
|
;; Skip until &OPTIONAL appears. |
152 |
|
(when (member (car a) lambda-list-keywords) |
153 |
|
(or (eq (car a) '&optional) (push '&optional a))) |
154 |
|
(cond ((eq (car a) '&optional) |
155 |
|
(setq l (cons '&optional l)) |
156 |
|
(do ((aa (cdr a) (cdr aa)) (ov) (y)) |
157 |
|
((endp aa) |
158 |
|
;; Add those options that do not appear in the |
159 |
|
;; parameter list. |
160 |
|
(setq keys |
161 |
|
(nreconc (cons '&aux l) |
162 |
|
(mapcan #'(lambda (k) |
163 |
|
(if (member (if (atom k) |
164 |
|
k |
165 |
|
(car k)) |
166 |
|
vs) |
167 |
|
nil |
168 |
|
(list k))) |
169 |
|
keys))) |
170 |
|
(return nil)) |
171 |
|
(when (member (car aa) lambda-list-keywords) |
172 |
|
(when (eq (car aa) '&rest) |
173 |
|
;; &REST is found. |
174 |
|
(setq l (cons '&rest l)) |
175 |
|
(setq aa (cdr aa)) |
176 |
|
(unless (and (not (endp aa)) |
177 |
|
(symbolp (car aa))) |
178 |
|
(illegal-boa)) |
179 |
|
(setq vs (cons (car aa) vs)) |
180 |
|
(setq l (cons (car aa) l)) |
181 |
|
(setq aa (cdr aa)) |
182 |
|
(when (endp aa) |
183 |
|
(setq keys |
184 |
|
(nreconc |
185 |
|
(cons '&aux l) |
186 |
|
(mapcan |
187 |
|
#'(lambda (k) |
188 |
|
(if (member (if (atom k) |
189 |
|
k |
190 |
|
(car k)) |
191 |
|
vs) |
192 |
|
nil |
193 |
|
(list k))) |
194 |
|
keys))) |
195 |
|
(return nil))) |
196 |
|
;; &AUX should follow. |
197 |
|
(unless (eq (car aa) '&aux) |
198 |
|
(illegal-boa)) |
199 |
|
(setq l (cons '&aux l)) |
200 |
|
(do ((aaa (cdr aa) (cdr aaa))) |
201 |
|
((endp aaa)) |
202 |
|
(setq l (cons (car aaa) l)) |
203 |
|
(cond ((and (atom (car aaa)) |
204 |
|
(symbolp (car aaa))) |
205 |
|
(setq vs (cons (car aaa) vs))) |
206 |
|
((and (symbolp (caar aaa)) |
207 |
|
(or (endp (cdar aaa)) |
208 |
|
(endp (cddar aaa)))) |
209 |
|
(setq vs (cons (caar aaa) vs))) |
210 |
|
(t (illegal-boa)))) |
211 |
|
;; End of the parameter list. |
212 |
|
(setq keys |
213 |
|
(nreconc l |
214 |
|
(mapcan |
215 |
|
#'(lambda (k) |
216 |
|
(if (member (if (atom k) |
217 |
|
k |
218 |
|
(car k)) |
219 |
|
vs) |
220 |
|
nil |
221 |
|
(list k))) |
222 |
|
keys))) |
223 |
|
(return nil)) |
224 |
|
;; Checks if the optional paramter without a default |
225 |
|
;; value has a default value in the slot-description. |
226 |
|
(if (and (cond ((atom (car aa)) (setq ov (car aa)) t) |
227 |
|
((endp (cdar aa)) (setq ov (caar aa)) t) |
228 |
|
(t nil)) |
229 |
|
(setq y (member ov |
230 |
|
keys |
231 |
|
:key |
232 |
|
#'(lambda (x) |
233 |
|
(if (consp x) |
234 |
|
;; With default value. |
235 |
|
(car x)))))) |
236 |
|
;; If no default value is supplied for |
237 |
|
;; the optional parameter and yet appears |
238 |
|
;; in KEYS with a default value, |
239 |
|
;; then cons the pair to L, |
240 |
|
(setq l (cons (car y) l)) |
241 |
|
;; otherwise cons just the parameter to L. |
242 |
|
(setq l (cons (car aa) l))) |
243 |
|
;; Checks the form of the optional parameter. |
244 |
|
(cond ((atom (car aa)) |
245 |
|
(unless (symbolp (car aa)) |
246 |
|
(illegal-boa)) |
247 |
|
(setq vs (cons (car aa) vs))) |
248 |
|
((not (symbolp (caar aa))) |
249 |
|
(illegal-boa)) |
250 |
|
((or (endp (cdar aa)) (endp (cddar aa))) |
251 |
|
(setq vs (cons (caar aa) vs))) |
252 |
|
((not (symbolp (caddar aa))) |
253 |
|
(illegal-boa)) |
254 |
|
((not (endp (cdddar aa))) |
255 |
|
(illegal-boa)) |
256 |
|
(t |
257 |
|
(setq vs (cons (caar aa) vs)) |
258 |
|
(setq vs (cons (caddar aa) vs))))) |
259 |
|
;; RETURN from the outside DO. |
260 |
|
(return nil)) |
261 |
|
(t |
262 |
|
(unless (symbolp (car a)) |
263 |
|
(illegal-boa)) |
264 |
|
(setq l (cons (car a) l)) |
265 |
|
(setq vs (cons (car a) vs))))) |
266 |
|
(setq constructor (car constructor))) |
267 |
|
(t |
268 |
|
;; If not a BOA constructor, just cons &KEY. |
269 |
|
(setq keys (cons '&key keys)))) |
270 |
|
(cond ((null type) |
271 |
|
`(defun ,constructor ,keys |
272 |
|
(si:make-structure ',name ,@slot-names))) |
273 |
|
((or (eq type 'vector) |
274 |
|
(and (consp type) (eq (car type) 'vector))) |
275 |
|
`(defun ,constructor ,keys |
276 |
|
(vector ,@slot-names))) |
277 |
|
((eq type 'list) |
278 |
|
`(defun ,constructor ,keys |
279 |
|
(list ,@slot-names))) |
280 |
|
((error "~S is an illegal structure type" type))))) |
281 |
|
|
282 |
|
(defun illegal-boa () |
283 |
|
(error "An illegal BOA constructor.")) |
284 |
|
|
285 |
|
(defun make-predicate (name predicate type named name-offset) |
286 |
|
(cond ((null type)) |
287 |
|
; done in define-structure |
288 |
|
((or (eq type 'vector) |
289 |
|
(and (consp type) (eq (car type) 'vector))) |
290 |
|
;; The name is at the NAME-OFFSET in the vector. |
291 |
|
(unless named (error "The structure should be named.")) |
292 |
|
`(defun ,predicate (x) |
293 |
|
(and (vectorp x) |
294 |
|
(> (the fixnum (length x)) ,name-offset) |
295 |
|
(eq (aref (the (vector t) x) ,name-offset) ',name)))) |
296 |
|
((eq type 'list) |
297 |
|
;; The name is at the NAME-OFFSET in the list. |
298 |
|
(unless named (error "The structure should be named.")) |
299 |
|
(if (= name-offset 0) |
300 |
|
`(defun ,predicate (x) |
301 |
|
(and (consp x) |
302 |
|
(eq (car x) ',name))) |
303 |
|
`(defun ,predicate (x) |
304 |
|
(do ((i ,name-offset (1- i)) |
305 |
|
(z x (cdr z))) |
306 |
|
((= i 0) (and (consp z) (eq (car z) ',name))) |
307 |
|
(declare (fixnum i)) |
308 |
|
(unless (consp z) (return nil)))))) |
309 |
|
((error "~S is an illegal structure type.")))) |
310 |
|
|
311 |
|
|
312 |
|
;;; PARSE-SLOT-DESCRIPTION parses the given slot-description |
313 |
|
;;; and returns a list of the form: |
314 |
|
;;; (slot-name default-init slot-type read-only offset) |
315 |
|
|
316 |
|
(defun parse-slot-description (slot-description offset) |
317 |
|
(let (slot-name default-init slot-type read-only) |
318 |
|
(cond ((atom slot-description) |
319 |
|
(setq slot-name slot-description)) |
320 |
|
((endp (cdr slot-description)) |
321 |
|
(setq slot-name (car slot-description))) |
322 |
|
(t |
323 |
|
(setq slot-name (car slot-description)) |
324 |
|
(setq default-init (cadr slot-description)) |
325 |
|
(do ((os (cddr slot-description) (cddr os)) (o) (v)) |
326 |
|
((endp os)) |
327 |
|
(setq o (car os)) |
328 |
|
(when (endp (cdr os)) |
329 |
|
(error "~S is an illegal structure slot option." |
330 |
|
os)) |
331 |
|
(setq v (cadr os)) |
332 |
|
(case o |
333 |
|
(:type (setq slot-type v)) |
334 |
|
(:read-only (setq read-only v)) |
335 |
|
(t |
336 |
|
(error "~S is an illegal structure slot option." |
337 |
|
os)))))) |
338 |
|
(list slot-name default-init slot-type read-only offset))) |
339 |
|
|
340 |
|
|
341 |
|
;;; OVERWRITE-SLOT-DESCRIPTIONS overwrites the old slot-descriptions |
342 |
|
;;; with the new descriptions which are specified in the |
343 |
|
;;; :include defstruct option. |
344 |
|
|
345 |
|
(defun overwrite-slot-descriptions (news olds) |
346 |
|
(if (null olds) |
347 |
|
nil |
348 |
|
(let ((sds (member (caar olds) news :key #'car))) |
349 |
|
(cond (sds |
350 |
|
(when (and (null (cadddr (car sds))) |
351 |
|
(cadddr (car olds))) |
352 |
|
;; If read-only is true in the old |
353 |
|
;; and false in the new, signal an error. |
354 |
|
(error "~S is an illegal include slot-description." |
355 |
|
sds)) |
356 |
|
;; If |
357 |
|
(setf (caddr (car sds)) |
358 |
|
(best-array-element-type (caddr (car sds)))) |
359 |
|
(when (not (equal (normalize-type (or (caddr (car sds)) t)) |
360 |
|
(normalize-type (or (caddr (car olds)) t)))) |
361 |
|
(error "Type mismmatch for included slot ~a" (car sds))) |
362 |
|
(cons (list (caar sds) |
363 |
|
(cadar sds) |
364 |
|
(caddar sds) |
365 |
|
(cadddr (car sds)) |
366 |
|
;; The offset if from the old. |
367 |
|
(car (cddddr (car olds)))) |
368 |
|
(overwrite-slot-descriptions news (cdr olds)))) |
369 |
|
(t |
370 |
|
(cons (car olds) |
371 |
|
(overwrite-slot-descriptions news (cdr olds)))))))) |
372 |
|
|
373 |
|
(defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t)) |
374 |
|
(defvar *alignment-t* (alignment t)) |
375 |
|
|
376 |
|
(defun make-t-type (n include slot-descriptions &aux i) |
377 |
|
(let ((res (make-array n :element-type 'unsigned-char :static t))) |
378 |
|
(when include |
379 |
|
(let ((tem (get include 's-data))raw) |
380 |
|
(or tem (error "Included structure undefined ~a" include)) |
381 |
|
(setq raw (s-data-raw tem)) |
382 |
|
(dotimes (i (min n (length raw))) |
383 |
|
(setf (aref res i) (aref raw i))))) |
384 |
|
(dolist (v slot-descriptions) |
385 |
|
(setq i (nth 4 v)) |
386 |
|
(let ((type (third v))) |
387 |
|
(cond ((<= (the fixnum (alignment type)) *alignment-t*) |
388 |
|
(setf (aref res i) (aet-type type)))))) |
389 |
|
(cond ((< n (length *all-t-s-type*)) |
390 |
|
(dotimes (i n) |
391 |
|
(cond ((not (eql (the fixnum (aref res i)) 0)) |
392 |
|
(return-from make-t-type res)))) |
393 |
|
*all-t-s-type*) |
394 |
|
(t res)))) |
395 |
|
|
396 |
|
(defvar *standard-slot-positions* |
397 |
|
(let ((ar (make-array 50 :element-type 'unsigned-short |
398 |
|
:static t))) |
399 |
|
(dotimes (i 50) |
400 |
|
(declare (fixnum i)) |
401 |
|
(setf (aref ar i)(* (size-of t) i))) |
402 |
|
ar)) |
403 |
|
|
404 |
|
(eval-when (compile ) |
405 |
|
(proclaim '(function round-up (fixnum fixnum ) fixnum)) |
406 |
|
) |
407 |
|
|
408 |
|
(defun round-up (a b) |
409 |
|
(declare (fixnum a b)) |
410 |
|
(setq a (ceiling a b)) |
411 |
|
(the fixnum (* a b))) |
412 |
|
|
413 |
|
|
414 |
|
(defun get-slot-pos (leng include slot-descriptions &aux type small-types |
415 |
|
has-holes) |
416 |
|
(declare (special *standard-slot-positions*)) include |
417 |
|
(dolist (v slot-descriptions) |
418 |
|
(when (and v (car v)) |
419 |
|
(setf type |
420 |
|
(best-array-element-type (caddr v)) |
421 |
|
(caddr v) type) |
422 |
|
(let ((val (second v))) |
423 |
|
(unless (typep val type) |
424 |
|
(if (and (symbolp val) |
425 |
|
(constantp val)) |
426 |
|
(setf val (symbol-value val))) |
427 |
|
(and (constantp val) |
428 |
|
(setf (cadr v) (coerce val type))))) |
429 |
|
(cond ((memq type '(signed-char unsigned-char |
430 |
|
short unsigned-short |
431 |
|
long-float |
432 |
|
bit)) |
433 |
|
(setq small-types t))))) |
434 |
|
(cond ((and (null small-types) |
435 |
|
(< leng (length *standard-slot-positions*)) |
436 |
|
(list *standard-slot-positions* (* leng (size-of t)) nil))) |
437 |
|
(t (let ((ar (make-array leng :element-type 'unsigned-short |
438 |
|
:static t)) |
439 |
|
(pos 0)(i 0)(align 0)type (next-pos 0)) |
440 |
|
(declare (fixnum pos i align next-pos)) |
441 |
|
;; A default array. |
442 |
|
|
443 |
|
(dolist |
444 |
|
(v slot-descriptions) |
445 |
|
(setq type (caddr v)) |
446 |
|
(setq align (alignment type)) |
447 |
|
(unless (<= align *alignment-t*) |
448 |
|
(setq type t) |
449 |
|
(setf (caddr v) t) |
450 |
|
(setq align *alignment-t*) |
451 |
|
(setq v (nconc v '(t)))) |
452 |
|
(setq next-pos (round-up pos align)) |
453 |
|
(or (eql pos next-pos) (setq has-holes t)) |
454 |
|
(setq pos next-pos) |
455 |
|
(setf (aref ar i) pos) |
456 |
|
(incf pos (size-of type)) |
457 |
|
(incf i)) |
458 |
|
(list ar (round-up pos (size-of t)) has-holes) |
459 |
|
)))) |
460 |
|
|
461 |
|
|
462 |
|
|
463 |
|
|
464 |
|
|
465 |
|
|
466 |
|
|
467 |
|
|
468 |
|
|
469 |
|
|
470 |
|
|
471 |
|
|
472 |
|
|
473 |
|
|
474 |
|
|
475 |
|
|
476 |
|
|
477 |
|
|
478 |
|
|
479 |
|
|
480 |
|
|
481 |
|
|
482 |
|
|
483 |
|
(defun define-structure (name conc-name no-conc type named slot-descriptions copier |
484 |
|
static include print-function constructors |
485 |
|
offset predicate &optional documentation no-funs |
486 |
|
&aux def leng) |
487 |
|
(and (consp type) (eq (car type) 'vector)(setq type 'vector)) |
488 |
|
(setq leng(length slot-descriptions)) |
489 |
|
(dolist (x slot-descriptions) |
490 |
|
(and x (car x) |
491 |
|
(apply #'make-access-function |
492 |
|
name conc-name no-conc type named include no-funs |
493 |
|
x ))) |
494 |
|
(when (and copier (not no-funs)) |
495 |
|
(setf (symbol-function copier) |
496 |
|
(ecase type |
497 |
|
((nil) #'si::copy-structure) |
498 |
|
(list #'copy-list) |
499 |
|
(vector #'copy-seq)))) |
500 |
|
|
501 |
|
|
502 |
|
(cond ((and (null type) |
503 |
|
(eq name 's-data)) |
504 |
|
;bootstrapping code! |
505 |
|
(setq def (make-s-data-structure |
506 |
|
(make-array (* leng (size-of t)) |
507 |
|
:element-type 'string-char :static t) |
508 |
|
(make-t-type leng nil slot-descriptions) |
509 |
|
*standard-slot-positions* |
510 |
|
slot-descriptions |
511 |
|
t |
512 |
|
)) |
513 |
|
) |
514 |
|
(t |
515 |
|
(let (slot-position |
516 |
|
(size 0) has-holes |
517 |
|
(include-str (and include |
518 |
|
(get include 's-data)))) |
519 |
|
(when include-str |
520 |
|
(cond ((and (s-data-frozen include-str) |
521 |
|
(or (not (s-data-included include-str)) |
522 |
|
(not (let ((te (get name 's-data))) |
523 |
|
(and te |
524 |
|
(eq (s-data-includes |
525 |
|
te) |
526 |
|
include-str)))))) |
527 |
|
(warn " ~a was frozen but now included" |
528 |
|
include))) |
529 |
|
(pushnew name (s-data-included include-str))) |
530 |
|
(when (null type) |
531 |
|
(setf slot-position |
532 |
|
(get-slot-pos leng include slot-descriptions)) |
533 |
|
(setf size (cadr slot-position) |
534 |
|
has-holes (caddr slot-position) |
535 |
|
slot-position (car slot-position) |
536 |
|
)) |
537 |
|
(setf def (make-s-data |
538 |
|
:name name |
539 |
|
:length leng |
540 |
|
:raw |
541 |
|
(and (null type) |
542 |
|
(make-t-type leng include slot-descriptions)) |
543 |
|
:slot-position slot-position |
544 |
|
:size size |
545 |
|
:has-holes has-holes |
546 |
|
:staticp static |
547 |
|
:includes include-str |
548 |
|
:print-function print-function |
549 |
|
:slot-descriptions slot-descriptions |
550 |
|
:constructors constructors |
551 |
|
:offset offset |
552 |
|
:type type |
553 |
|
:named named |
554 |
|
:documentation documentation |
555 |
|
:conc-name conc-name))))) |
556 |
|
(let ((tem (get name 's-data))) |
557 |
|
(cond ((eq name 's-data) |
558 |
|
(if tem (warn "not replacing s-data property")) |
559 |
|
(or tem (setf (get name 's-data) def))) |
560 |
|
(tem |
561 |
|
(check-s-data tem def name)) |
562 |
|
(t (setf (get name 's-data) def))) |
563 |
|
(when documentation |
564 |
|
(setf (get name 'structure-documentation) |
565 |
|
documentation)) |
566 |
|
(when (and (null type) predicate) |
567 |
|
(record-fn predicate 'defun '(t) t) |
568 |
|
(or no-funs |
569 |
|
(setf (symbol-function predicate) |
570 |
|
#'(lambda (x) |
571 |
|
(si::structure-subtype-p x name)))) |
572 |
|
(setf (get predicate 'compiler::co1) |
573 |
|
'compiler::co1structure-predicate) |
574 |
|
(setf (get predicate 'struct-predicate) name) |
575 |
|
) |
576 |
|
) nil) |
577 |
|
|
578 |
|
|
579 |
|
(defmacro defstruct (name &rest slots) |
580 |
|
(let ((slot-descriptions slots) |
581 |
|
options |
582 |
|
conc-name |
583 |
|
constructors default-constructor no-constructor |
584 |
|
copier |
585 |
|
predicate predicate-specified |
586 |
|
include |
587 |
|
print-function type named initial-offset |
588 |
|
offset name-offset |
589 |
|
documentation |
590 |
|
static |
591 |
|
(no-conc nil)) |
592 |
|
|
593 |
|
(when (consp name) |
594 |
|
;; The defstruct options are supplied. |
595 |
|
(setq options (cdr name)) |
596 |
|
(setq name (car name))) |
597 |
|
|
598 |
|
;; The default conc-name. |
599 |
|
(setq conc-name (si:string-concatenate (string name) "-")) |
600 |
|
|
601 |
|
;; The default constructor. |
602 |
|
(setq default-constructor |
603 |
|
(intern (si:string-concatenate "MAKE-" (string name)))) |
604 |
|
|
605 |
|
;; The default copier and predicate. |
606 |
|
(setq copier |
607 |
|
(intern (si:string-concatenate "COPY-" (string name))) |
608 |
|
predicate |
609 |
|
(intern (si:string-concatenate (string name) "-P"))) |
610 |
|
|
611 |
|
;; Parse the defstruct options. |
612 |
|
(do ((os options (cdr os)) (o) (v)) |
613 |
|
((endp os)) |
614 |
|
(cond ((and (consp (car os)) (not (endp (cdar os)))) |
615 |
|
(setq o (caar os) v (cadar os)) |
616 |
|
(case o |
617 |
|
(:conc-name |
618 |
|
(if (null v) |
619 |
|
(progn |
620 |
|
(setq conc-name "") |
621 |
|
(setq no-conc t)) |
622 |
|
(setq conc-name v))) |
623 |
|
(:constructor |
624 |
|
(if (null v) |
625 |
|
(setq no-constructor t) |
626 |
|
(if (endp (cddar os)) |
627 |
|
(setq constructors (cons v constructors)) |
628 |
|
(setq constructors (cons (cdar os) constructors))))) |
629 |
|
(:copier (setq copier v)) |
630 |
|
(:static (setq static v)) |
631 |
|
(:predicate |
632 |
|
(setq predicate v) |
633 |
|
(setq predicate-specified t)) |
634 |
|
(:include |
635 |
|
(setq include (cdar os)) |
636 |
|
(unless (get v 's-data) |
637 |
|
(error "~S is an illegal included structure." v))) |
638 |
|
(:print-function |
639 |
|
(and (consp v) (eq (car v) 'function) |
640 |
|
(setq v (second v))) |
641 |
|
(setq print-function v)) |
642 |
|
(:type (setq type v)) |
643 |
|
(:initial-offset (setq initial-offset v)) |
644 |
|
(t (error "~S is an illegal defstruct option." o)))) |
645 |
|
(t |
646 |
|
(if (consp (car os)) |
647 |
|
(setq o (caar os)) |
648 |
|
(setq o (car os))) |
649 |
|
(case o |
650 |
|
(:constructor |
651 |
|
(setq constructors |
652 |
|
(cons default-constructor constructors))) |
653 |
|
((:copier :predicate :print-function)) |
654 |
|
(:conc-name |
655 |
|
(progn |
656 |
|
(setq conc-name "") |
657 |
|
(setq no-conc t))) |
658 |
|
(:named (setq named t)) |
659 |
|
(t (error "~S is an illegal defstruct option." o)))))) |
660 |
|
|
661 |
|
(setq conc-name (intern (string conc-name))) |
662 |
|
|
663 |
|
(and include (not print-function) |
664 |
|
(setq print-function (s-data-print-function (get (car include) 's-data)))) |
665 |
|
|
666 |
|
;; Skip the documentation string. |
667 |
|
(when (and (not (endp slot-descriptions)) |
668 |
|
(stringp (car slot-descriptions))) |
669 |
|
(setq documentation (car slot-descriptions)) |
670 |
|
(setq slot-descriptions (cdr slot-descriptions))) |
671 |
|
|
672 |
|
;; Check the include option. |
673 |
|
(when include |
674 |
|
(unless (equal type |
675 |
|
(s-data-type (get (car include) 's-data))) |
676 |
|
(error "~S is an illegal structure include." |
677 |
|
(car include)))) |
678 |
|
|
679 |
|
;; Set OFFSET. |
680 |
|
(cond ((null include) |
681 |
|
(setq offset 0)) |
682 |
|
(t |
683 |
|
(setq offset (s-data-offset (get (car include) 's-data))))) |
684 |
|
|
685 |
|
;; Increment OFFSET. |
686 |
|
(when (and type initial-offset) |
687 |
|
(setq offset (+ offset initial-offset))) |
688 |
|
(when (and type named) |
689 |
|
(setq name-offset offset) |
690 |
|
(setq offset (1+ offset))) |
691 |
|
|
692 |
|
;; Parse slot-descriptions, incrementing OFFSET for each one. |
693 |
|
(do ((ds slot-descriptions (cdr ds)) |
694 |
|
(sds nil)) |
695 |
|
((endp ds) |
696 |
|
(setq slot-descriptions (nreverse sds))) |
697 |
|
(setq sds (cons (parse-slot-description (car ds) offset) sds)) |
698 |
|
(setq offset (1+ offset))) |
699 |
|
|
700 |
|
;; If TYPE is non-NIL and structure is named, |
701 |
|
;; add the slot for the structure-name to the slot-descriptions. |
702 |
|
(when (and type named) |
703 |
|
(setq slot-descriptions |
704 |
|
(cons (list nil name) slot-descriptions))) |
705 |
|
|
706 |
|
;; Pad the slot-descriptions with the initial-offset number of NILs. |
707 |
|
(when (and type initial-offset) |
708 |
|
(setq slot-descriptions |
709 |
|
(append (make-list initial-offset) slot-descriptions))) |
710 |
|
|
711 |
|
;; Append the slot-descriptions of the included structure. |
712 |
|
;; The slot-descriptions in the include option are also counted. |
713 |
|
(cond ((null include)) |
714 |
|
((endp (cdr include)) |
715 |
|
(setq slot-descriptions |
716 |
|
(append (s-data-slot-descriptions |
717 |
|
(get (car include) 's-data)) |
718 |
|
slot-descriptions))) |
719 |
|
(t |
720 |
|
(setq slot-descriptions |
721 |
|
(append (overwrite-slot-descriptions |
722 |
|
(mapcar #'(lambda (sd) |
723 |
|
(parse-slot-description sd 0)) |
724 |
|
(cdr include)) |
725 |
|
(s-data-slot-descriptions |
726 |
|
(get (car include) 's-data) |
727 |
|
)) |
728 |
|
slot-descriptions)))) |
729 |
|
|
730 |
|
(cond (no-constructor |
731 |
|
;; If a constructor option is NIL, |
732 |
|
;; no constructor should have been specified. |
733 |
|
(when constructors |
734 |
|
(error "Contradictory constructor options."))) |
735 |
|
((null constructors) |
736 |
|
;; If no constructor is specified, |
737 |
|
;; the default-constructor is made. |
738 |
|
(setq constructors (list default-constructor)))) |
739 |
|
|
740 |
|
;; We need a default constructor for the sharp-s-reader |
741 |
|
(or (member t (mapcar 'symbolp constructors)) |
742 |
|
(push (intern (string-concatenate "__si::" default-constructor)) |
743 |
|
constructors)) |
744 |
|
|
745 |
|
;; Check the named option and set the predicate. |
746 |
|
(when (and type (not named)) |
747 |
|
(when predicate-specified |
748 |
|
(error "~S is an illegal structure predicate." |
749 |
|
predicate)) |
750 |
|
(setq predicate nil)) |
751 |
|
|
752 |
|
(when include (setq include (car include))) |
753 |
|
|
754 |
|
;; Check the print-function. |
755 |
|
(when (and print-function type) |
756 |
|
(error "A print function is supplied to a typed structure.")) |
757 |
|
|
758 |
|
`(progn |
759 |
|
(define-structure ',name ',conc-name ',no-conc ',type |
760 |
|
',named ',slot-descriptions ',copier ',static ',include ',print-function ',constructors |
761 |
|
',offset ',predicate ',documentation |
762 |
|
) |
763 |
|
|
764 |
|
,@(mapcar #'(lambda (constructor) |
765 |
|
(make-constructor name constructor type named |
766 |
|
slot-descriptions)) |
767 |
|
constructors) |
768 |
|
,@(if (and type predicate) |
769 |
|
(list (make-predicate name predicate type named |
770 |
|
name-offset))) |
771 |
|
',name |
772 |
|
))) |
773 |
|
|
774 |
|
;; First several fields of this must coincide with the C structure |
775 |
|
;; s_data (see object.h). |
776 |
|
|
777 |
|
|
778 |
|
(defstruct s-data name |
779 |
|
(length 0 :type fixnum) |
780 |
|
raw |
781 |
|
included |
782 |
|
includes |
783 |
|
staticp |
784 |
|
print-function |
785 |
|
slot-descriptions |
786 |
|
slot-position |
787 |
|
(size 0 :type fixnum) |
788 |
|
has-holes |
789 |
|
frozen |
790 |
|
documentation |
791 |
|
constructors |
792 |
|
offset |
793 |
|
named |
794 |
|
type |
795 |
|
conc-name |
796 |
|
) |
797 |
|
|
798 |
|
|
799 |
|
(defun check-s-data (tem def name) |
800 |
|
(cond ((s-data-included tem) |
801 |
|
(setf (s-data-included def)(s-data-included tem)))) |
802 |
|
(cond ((s-data-frozen tem) |
803 |
|
(setf (s-data-frozen def) t))) |
804 |
|
(unless (equalp def tem) |
805 |
|
(warn "structure ~a is changing" name) |
806 |
|
(setf (get name 's-data) def))) |
807 |
|
(defun freeze-defstruct (name) |
808 |
|
(let ((tem (and (symbolp name) (get name 's-data)))) |
809 |
|
(if tem (setf (s-data-frozen tem) t)))) |
810 |
|
|
811 |
|
|
812 |
|
;;; The #S reader. |
813 |
|
|
814 |
|
(defun sharp-s-reader (stream subchar arg) |
815 |
|
(declare (ignore subchar)) |
816 |
|
(when (and arg (null *read-suppress*)) |
817 |
|
(error "An extra argument was supplied for the #S readmacro.")) |
818 |
|
(let* ((l (prog1 (read stream t nil t) |
819 |
|
(if *read-suppress* |
820 |
|
(return-from sharp-s-reader nil)))) |
821 |
|
(sd |
822 |
|
(or (get (car l) 's-data) |
823 |
|
|
824 |
|
(error "~S is not a structure." (car l))))) |
825 |
|
|
826 |
|
;; Intern keywords in the keyword package. |
827 |
|
(do ((ll (cdr l) (cddr ll))) |
828 |
|
((endp ll) |
829 |
|
;; Find an appropriate construtor. |
830 |
|
(do ((cs (s-data-constructors sd) (cdr cs))) |
831 |
|
((endp cs) |
832 |
|
(error "The structure ~S has no structure constructor." |
833 |
|
(car l))) |
834 |
|
(when (symbolp (car cs)) |
835 |
|
(return (apply (car cs) (cdr l)))))) |
836 |
|
(rplaca ll (intern (string (car ll)) 'keyword))))) |
837 |
|
|
838 |
|
|
839 |
|
;; Set the dispatch macro. |
840 |
|
(set-dispatch-macro-character #\# #\s 'sharp-s-reader) |
841 |
|
(set-dispatch-macro-character #\# #\S 'sharp-s-reader) |
842 |
|
|
843 |
|
;; Examples from Common Lisp Reference Manual. |
844 |
|
|
845 |
|
#| |
846 |
|
(defstruct ship |
847 |
|
x-position |
848 |
|
y-position |
849 |
|
x-velocity |
850 |
|
y-velocity |
851 |
|
mass) |
852 |
|
|
853 |
|
(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char) |
854 |
|
sex) |
855 |
|
(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char) |
856 |
|
sex) |
857 |
|
(defstruct person1 name (age 20 :type fixnum) |
858 |
|
sex) |
859 |
|
|
860 |
|
(defstruct joe a (a1 0 :type (mod 30)) (a2 0 :type (mod 30)) |
861 |
|
(a3 0 :type (mod 30)) (a4 0 :type (mod 30)) ) |
862 |
|
|
863 |
|
;(defstruct person name age sex) |
864 |
|
|
865 |
|
(defstruct (astronaut (:include person (age 45 :type fixnum)) |
866 |
|
(:conc-name astro-)) |
867 |
|
helmet-size |
868 |
|
(favorite-beverage 'tang)) |
869 |
|
|
870 |
|
(defstruct (foo (:constructor create-foo (a |
871 |
|
&optional b (c 'sea) |
872 |
|
&rest d |
873 |
|
&aux e (f 'eff)))) |
874 |
|
a (b 'bee) c d e f) |
875 |
|
|
876 |
|
(defstruct (binop (:type list) :named (:initial-offset 2)) |
877 |
|
(operator '?) |
878 |
|
operand-1 |
879 |
|
operand-2) |
880 |
|
|
881 |
|
(defstruct (annotated-binop (:type list) |
882 |
|
(:initial-offset 3) |
883 |
|
(:include binop)) |
884 |
|
commutative |
885 |
|
associative |
886 |
|
identity) |
887 |
|
|
888 |
|
|# |