Commit | Line | Data |
---|---|---|
5ffa1c4c C |
1 | ;;; -*- Mode:Lisp; Package:SI; Lowercase:True; Base:8 -*- |
2 | ;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** | |
3 | (setq rcs-struct- | |
4 | "$Header: /usr/lib/lisp/RCS/struct.l,v 1.2 83/08/06 08:41:10 jkf Exp $") | |
5 | ||
6 | ;The master copy of this file is in MC:ALAN;NSTRUCT > | |
7 | ;The current Lisp machine copy is in AI:LISPM2;STRUCT > | |
8 | ;The current Multics copy is in >udd>Mathlab>Bawden>defstruct.lisp | |
9 | ||
10 | ;***** READ THIS PLEASE! ***** | |
11 | ;If you are thinking of munging anything in this file you might want | |
12 | ;to consider finding me (ALAN) and asking me to mung it for you. | |
13 | ;There is more than one copy of this file in the world (it runs in PDP10 | |
14 | ;and Multics MacLisp and on LispMachines) and whatever amazing | |
15 | ;features you are considering adding might be usefull to those people | |
16 | ;as well. If you still cannot contain yourself long enough to find | |
17 | ;me, AT LEAST send me a piece of mail describing what you did and why. | |
18 | ;Thanks for reading this flame. | |
19 | ; Alan Bawden (ALAN@MC) | |
20 | ||
21 | ;Things to fix: | |
22 | ||
23 | ;For LispMachine: | |
24 | ; :%P-LDB type (this is hard to do, punt for now.) | |
25 | ||
26 | ;For Multics: | |
27 | ; displacement is a problem (no displace) | |
28 | ; nth, nthcdr don't exist there | |
29 | ; ldb, dpb don't exist, so byte fields don't work without Mathlab macros | |
30 | ; callable accessors don't work | |
31 | ; dpb is needed at the user's compile time if he is using byte fields. | |
32 | ||
33 | #+Franz (environment-maclisp) | |
34 | ||
35 | (eval-when (compile) | |
36 | (cond ((status feature ITS) | |
37 | (load '|alan;lspenv init|)) | |
38 | ((status feature Multics) | |
39 | (load '|>udd>Mathlab>Bawden>lspenv.lisp|)))) | |
40 | ||
41 | #+PDP10 | |
42 | (cond ((status nofeature noldmsg) | |
43 | (terpri msgfiles) | |
44 | (princ '#.(and (status feature PDP10) | |
45 | (maknam (nconc (exploden ";Loading DEFSTRUCT ") | |
46 | (exploden (caddr (truename infile)))))) | |
47 | msgfiles))) | |
48 | ||
49 | #+Multics | |
50 | (declare (genprefix defstruct-internal-) | |
51 | (macros t)) | |
52 | ||
53 | #+Franz | |
54 | (declare (macros t)) | |
55 | ||
56 | #M | |
57 | (eval-when (eval compile) | |
58 | (setsyntax #/: (ascii #\space) nil)) | |
59 | ||
60 | ;; #+Franz | |
61 | ;; (eval-when (eval compile) | |
62 | ;; (setsyntax #/: 'vseparator)) ; make :'s go away | |
63 | ||
64 | (eval-when (eval) | |
65 | ;;So we may run the thing interpreted we need the simple | |
66 | ;;defstruct that lives here: | |
67 | (cond ((status feature ITS) | |
68 | (load '|alan;struct initial|)) | |
69 | ((status feature Multics) | |
70 | (load '|>udd>Mathlab>Bawden>initial_defstruct|)) | |
71 | ((status feature Franz) | |
72 | (load 'structini.l)))) | |
73 | ||
74 | (eval-when (compile) | |
75 | ;;To compile the thing this probably is an old fasl: (!) | |
76 | (cond ((status feature ITS) | |
77 | (load '|alan;struct boot|)) | |
78 | ((status feature Multics) | |
79 | (load '|>udd>Mathlab>Bawden>boot_defstruct|)) | |
80 | ((status feature Franz) ; This is only needed for bootstrapping | |
81 | (cond ((and (null (getd 'defstruct)) | |
82 | (not (probef | |
83 | (concat lisp-library-directory "//struct.o")))) | |
84 | (load 'structini)))) | |
85 | )) | |
86 | ||
87 | #+Multics | |
88 | (defun nth (n l) | |
89 | (do ((n n (1- n)) | |
90 | (l l (cdr l))) | |
91 | ((zerop n) (car l)))) | |
92 | ||
93 | #+Multics | |
94 | (defun nthcdr (n l) | |
95 | (do ((n n (1- n)) | |
96 | (l l (cdr l))) | |
97 | ((zerop n) l))) | |
98 | ||
99 | #+(or Franz Multics) | |
100 | (defun displace (x y) | |
101 | (cond ((atom y) | |
102 | (rplaca x 'progn) | |
103 | (rplacd x (list y))) | |
104 | (t | |
105 | (rplaca x (car y)) | |
106 | (rplacd x (cdr y)))) | |
107 | x) | |
108 | ||
109 | ;;; You might think you could use progn for this, but you can't! | |
110 | (defun defstruct-dont-displace (x y) | |
111 | x ;ignored | |
112 | y) | |
113 | \f | |
114 | ;;; Eval this before attempting incremental compilation | |
115 | (eval-when (eval compile) | |
116 | ||
117 | #+PDP10 | |
118 | (defmacro append-symbols args | |
119 | (do ((l (reverse args) (cdr l)) | |
120 | (x) | |
121 | (a nil (if (or (atom x) | |
122 | (not (eq (car x) 'quote))) | |
123 | (if (null a) | |
124 | `(exploden ,x) | |
125 | `(nconc (exploden ,x) ,a)) | |
126 | (let ((l (exploden (cadr x)))) | |
127 | (cond ((null a) `',l) | |
128 | ((= 1 (length l)) `(cons ,(car l) ,a)) | |
129 | (t `(append ',l ,a))))))) | |
130 | ||
131 | ((null l) `(implode ,a)) | |
132 | (setq x (car l)))) | |
133 | ||
134 | #+Multics | |
135 | (defmacro append-symbols args | |
136 | `(make_atom (catenate . ,args))) | |
137 | ||
138 | #+LispM | |
139 | (defmacro append-symbols args | |
140 | `(intern (string-append . ,args))) | |
141 | ||
142 | #+Franz | |
143 | (defmacro append-symbols (&rest args) | |
144 | `(concat . ,args)) | |
145 | ||
146 | (defmacro defstruct-putprop (sym val ind) | |
147 | `(push `(defprop ,,sym ,,val ,,ind) returns)) | |
148 | ||
149 | (defmacro defstruct-put-macro (sym fcn) | |
150 | #M `(defstruct-putprop ,sym ,fcn 'macro) | |
151 | #+lispm | |
152 | (setq fcn (if (and (not (atom fcn)) | |
153 | (eq (car fcn) 'quote)) | |
154 | `'(macro . ,(cadr fcn)) | |
155 | `(cons 'macro ,fcn))) | |
156 | #+Franz | |
157 | (setq fcn (if (and (not (atom fcn)) | |
158 | (eq (car fcn) 'quote)) | |
159 | `'(macro (macroarg) (,(cadr fcn) macroarg)) | |
160 | `(cons 'macro ,fcn))) ;; probably incorrect | |
161 | ||
162 | #Q `(push `(fdefine ',,sym ',,fcn t) returns) | |
163 | #+Franz `(push `(def ,,sym ,,fcn) returns) | |
164 | ) | |
165 | ||
166 | (defmacro make-empty () `'%%defstruct-empty%%) | |
167 | ||
168 | (defmacro emptyp (x) `(eq ,x '%%defstruct-empty%%)) | |
169 | \f | |
170 | ;;;Here we must deal with the fact that error reporting works | |
171 | ;;;differently everywhere! | |
172 | ||
173 | #+(or Franz PDP10) | |
174 | ;;;first arg is ALWAYS a symbol or a quoted symbol: | |
175 | (defmacro defstruct-error (message &rest args) | |
176 | (let* ((chars (nconc (exploden (if (atom message) | |
177 | message | |
178 | (cadr message))) | |
179 | '(#/.))) ;"Bad frob" => "Bad frob." | |
180 | (new-message | |
181 | (maknam (if (null args) | |
182 | chars | |
183 | (let ((c (car chars))) ;"Bad frob." => "-- bad frob." | |
184 | (or (< c #/A) | |
185 | (> c #/Z) | |
186 | (rplaca chars (+ c #o40))) | |
187 | (append '(#/- #/- #\space) chars)))))) | |
188 | `(error ',new-message | |
189 | ,@(cond ((null args) `()) | |
190 | ((null (cdr args)) `(,(car args))) | |
191 | (t `((list ,@args))))))) | |
192 | ||
193 | #+Multics | |
194 | ;;;first arg is ALWAYS a string: | |
195 | (defmacro defstruct-error (message &rest args) | |
196 | `(error ,(catenate "defstruct: " | |
197 | message | |
198 | (if (null args) | |
199 | "." | |
200 | ": ")) | |
201 | ,@(cond ((null args) `()) | |
202 | ((null (cdr args)) `(,(car args))) | |
203 | (t `((list ,@args)))))) | |
204 | ||
205 | #+LispM | |
206 | ;;;first arg is ALWAYS a string: | |
207 | (defmacro defstruct-error (message &rest args) | |
208 | `(ferror nil | |
209 | ,(string-append message | |
210 | (if (null args) | |
211 | "." | |
212 | ":~@{ ~S~}")) | |
213 | ,@args)) | |
214 | ||
215 | );End of eval-when (eval compile) | |
216 | \f | |
217 | ;;;If you mung the the ordering af any of the slots in this structure, | |
218 | ;;;be sure to change the version slot and the definition of the function | |
219 | ;;;get-defstruct-description. Munging the defstruct-slot-description | |
220 | ;;;structure should also cause you to change the version "number" in this manner. | |
221 | (defstruct (defstruct-description | |
222 | (:type :list) | |
223 | (:default-pointer description) | |
224 | (:conc-name defstruct-description-) | |
225 | (:alterant nil)) | |
226 | (version 'one) | |
227 | type | |
228 | (displace 'defstruct-dont-displace) | |
229 | slot-alist | |
230 | named-p | |
231 | constructors | |
232 | (default-pointer nil) | |
233 | (but-first nil) | |
234 | size | |
235 | (property-alist nil) | |
236 | ;;end of "expand-time" slots | |
237 | name | |
238 | include | |
239 | (initial-offset 0) | |
240 | (eval-when '(eval compile load)) | |
241 | alterant | |
242 | (conc-name nil) | |
243 | (callable-accessors #M nil #Q t) | |
244 | (size-macro nil) | |
245 | (size-symbol nil) | |
246 | ) | |
247 | ||
248 | (defun get-defstruct-description (name) | |
249 | (let ((description (get name 'defstruct-description))) | |
250 | (cond ((null description) | |
251 | (defstruct-error | |
252 | "A structure with this name has not been defined" name)) | |
253 | ((not (eq (defstruct-description-version) 'one)) | |
254 | (defstruct-error "The description of this structure is out of date, | |
255 | it should be recompiled using the current version of defstruct" | |
256 | name)) | |
257 | (t description)))) | |
258 | ||
259 | ;;;See note above defstruct-description structure before munging this one. | |
260 | (defstruct (defstruct-slot-description | |
261 | (:type :list) | |
262 | (:default-pointer slot-description) | |
263 | (:conc-name defstruct-slot-description-) | |
264 | (:alterant nil)) | |
265 | number | |
266 | (ppss nil) | |
267 | init-code | |
268 | (type 'notype) | |
269 | (property-alist nil) | |
270 | ref-macro-name | |
271 | ) | |
272 | ||
273 | ;;;Perhaps this structure wants a version slot too? | |
274 | (defstruct (defstruct-type-description | |
275 | (:type :list) | |
276 | (:default-pointer type-description) | |
277 | (:conc-name defstruct-type-description-) | |
278 | (:alterant nil)) | |
279 | ref-expander | |
280 | ref-no-args | |
281 | cons-expander | |
282 | cons-flavor | |
283 | (cons-keywords nil) | |
284 | (named-type nil) | |
285 | (overhead 0) | |
286 | (defstruct-expander nil) | |
287 | ) | |
288 | \f | |
289 | ;; (DEFSTRUCT (<name> . <options>) . <slots>) or (DEFSTRUCT <name> . <slots>) | |
290 | ;; | |
291 | ;; <options> is of the form (<option> <option> (<option> <val>) ...) | |
292 | ;; | |
293 | ;; <slots> is of the form (<slot> (<slot> <initial-value>) ...) | |
294 | ;; | |
295 | ;; Options: | |
296 | ;; :TYPE defaults to HUNK | |
297 | ;; :CONSTRUCTOR defaults to "MAKE-<name>" | |
298 | ;; :DEFAULT-POINTER defaults to empty (if no <val> given defaults to "<name>") | |
299 | ;; :CONC-NAME defaults to empty (if no <val> given defaults to "<name>-") | |
300 | ;; :SIZE-SYMBOL defaults to empty (if no <val> given defaults to "<name>-SIZE") | |
301 | ;; :SIZE-MACRO defaults to empty (if no <val> given defaults to "<name>-SIZE") | |
302 | ;; :ALTERANT defaults to "ALTER-<name>" | |
303 | ;; :BUT-FIRST must have a <val> given | |
304 | ;; :INCLUDE must have a <val> given | |
305 | ;; :PROPERTY (:property foo bar) gives the structure a foo property of bar. | |
306 | ;; :INITIAL-OFFSET can cause defstruct to skip over that many slots. | |
307 | ;; :NAMED takes no value. Tries to make the structure a named type. | |
308 | ;; :CALLABLE-ACCESSORS defaults to T on the LispMachine, NIL elsewhere. | |
309 | ;; <type> any type name can be used without a <val> instead of saying (TYPE <type>) | |
310 | ;; <other> any symbol with a non-nil :defstruct-option property. You say | |
311 | ;; (<other> <val>) and the effect is that of (:property <other> <val>) | |
312 | ;; | |
313 | ;; Properties used: | |
314 | ;; DEFSTRUCT-TYPE-DESCRIPTION each type has one, it is a type-description. | |
315 | ;; DEFSTRUCT-NAME each constructor, alterant and size macro has one, it is a name. | |
316 | ;; DEFSTRUCT-DESCRIPTION each name has one, it is a description (see below). | |
317 | ;; DEFSTRUCT-SLOT each accesor has one, it is of the form: (<name> . <slot>) | |
318 | ;; :DEFSTRUCT-OPTION if a symbol FOO has this property then it can be used as an | |
319 | ;; option giving the structure a FOO property of the value (which must be given). | |
320 | \f | |
321 | (defmacro defstruct (options &body items) | |
322 | (let* ((description (defstruct-parse-options options)) | |
323 | (type-description (get (defstruct-description-type) | |
324 | 'defstruct-type-description)) | |
325 | (name (defstruct-description-name)) | |
326 | (new-slots (defstruct-parse-items items description)) | |
327 | (returns nil)) | |
328 | (push `',name returns) | |
329 | (or (null (defstruct-type-description-defstruct-expander)) | |
330 | (setq returns (append (funcall (defstruct-type-description-defstruct-expander) | |
331 | description) | |
332 | returns))) | |
333 | #Q (push `(record-source-file-name ',name) returns) | |
334 | (defstruct-putprop name description 'defstruct-description) | |
335 | (let ((alterant (defstruct-description-alterant)) | |
336 | (size-macro (defstruct-description-size-macro)) | |
337 | (size-symbol (defstruct-description-size-symbol))) | |
338 | (cond (alterant | |
339 | (defstruct-put-macro alterant 'defstruct-expand-alter-macro) | |
340 | (defstruct-putprop alterant name 'defstruct-name))) | |
341 | (cond (size-macro | |
342 | (defstruct-put-macro size-macro 'defstruct-expand-size-macro) | |
343 | (defstruct-putprop size-macro name 'defstruct-name))) | |
344 | (cond (size-symbol | |
345 | (push `(#M defvar #Q defconst #F setq ,size-symbol | |
346 | ,(+ (defstruct-description-size) | |
347 | (defstruct-type-description-overhead))) | |
348 | returns)))) | |
349 | (do cs (defstruct-description-constructors) (cdr cs) (null cs) | |
350 | (defstruct-put-macro (caar cs) 'defstruct-expand-cons-macro) | |
351 | (defstruct-putprop (caar cs) name 'defstruct-name)) | |
352 | `(eval-when ,(defstruct-description-eval-when) | |
353 | ,.(defstruct-define-ref-macros new-slots description) | |
354 | . ,returns))) | |
355 | \f | |
356 | (defun defstruct-parse-options (options) | |
357 | (let ((name (if (atom options) options (car options))) | |
358 | (type nil) | |
359 | (constructors (make-empty)) | |
360 | (alterant (make-empty)) | |
361 | (included nil) | |
362 | (named-p nil) | |
363 | (description (make-defstruct-description))) | |
364 | (setf (defstruct-description-name) name) | |
365 | (do ((op) (val) (vals) | |
366 | (options (if (atom options) nil (cdr options)) | |
367 | (cdr options))) | |
368 | ((null options)) | |
369 | (if (atom (setq op (car options))) | |
370 | (setq vals nil) | |
371 | (setq op (prog1 (car op) (setq vals (cdr op))))) | |
372 | (setq val (if (null vals) (make-empty) (car vals))) | |
373 | #Q AGAIN | |
374 | (selectq op | |
375 | (:type | |
376 | (if (emptyp val) | |
377 | (defstruct-error | |
378 | "The type option to defstruct must have a value given" | |
379 | name)) | |
380 | (setq type val)) | |
381 | (:default-pointer | |
382 | (setf (defstruct-description-default-pointer) | |
383 | (if (emptyp val) name val))) | |
384 | (:but-first | |
385 | (if (emptyp val) | |
386 | (defstruct-error | |
387 | "The but-first option to defstruct must have a value given" | |
388 | name)) | |
389 | (setf (defstruct-description-but-first) val)) | |
390 | (:conc-name | |
391 | (setf (defstruct-description-conc-name) | |
392 | (if (emptyp val) | |
393 | (append-symbols name '-) | |
394 | val))) | |
395 | (:callable-accessors | |
396 | (setf (defstruct-description-callable-accessors) | |
397 | (if (emptyp val) t val))) | |
398 | (:displace | |
399 | (setf (defstruct-description-displace) | |
400 | (cond ((or (emptyp val) | |
401 | (eq val 't)) | |
402 | 'displace) | |
403 | ((null val) 'defstruct-dont-displace) | |
404 | (t val)))) | |
405 | (:constructor | |
406 | (cond ((null val) | |
407 | (setq constructors nil)) | |
408 | (t | |
409 | (and (emptyp val) | |
410 | (setq val (append-symbols 'make- name))) | |
411 | (setq val (cons val (cdr vals))) | |
412 | (if (emptyp constructors) | |
413 | (setq constructors (list val)) | |
414 | (push val constructors))))) | |
415 | (:alterant | |
416 | (setq alterant val)) | |
417 | (:size-macro | |
418 | (setf (defstruct-description-size-macro) | |
419 | (if (emptyp val) | |
420 | (append-symbols name '-size) | |
421 | val))) | |
422 | (:size-symbol | |
423 | (setf (defstruct-description-size-symbol) | |
424 | (if (emptyp val) | |
425 | (append-symbols name '-size) | |
426 | val))) | |
427 | (:include | |
428 | (and (emptyp val) | |
429 | (defstruct-error | |
430 | "The include option to defstruct requires a value" | |
431 | name)) | |
432 | (setq included val) | |
433 | (setf (defstruct-description-include) vals)) | |
434 | (:property | |
435 | (push (cons (car vals) (if (null (cdr vals)) t (cadr vals))) | |
436 | (defstruct-description-property-alist))) | |
437 | (:named | |
438 | (or (emptyp val) | |
439 | (defstruct-error | |
440 | "The named option to defstruct doesn't take a value" name)) | |
441 | (setq named-p t)) | |
442 | (:eval-when | |
443 | (and (emptyp val) | |
444 | (defstruct-error | |
445 | "The eval-when option to defstruct requires a value" | |
446 | name)) | |
447 | (setf (defstruct-description-eval-when) val)) | |
448 | (:initial-offset | |
449 | (and (or (emptyp val) | |
450 | (not (fixp val))) | |
451 | (defstruct-error | |
452 | "The initial-offset option to defstruct requires a fixnum" | |
453 | name)) | |
454 | (setf (defstruct-description-initial-offset) val)) | |
455 | (otherwise | |
456 | (cond ((get op 'defstruct-type-description) | |
457 | (or (emptyp val) | |
458 | (defstruct-error | |
459 | "defstruct type used as an option with a value" | |
460 | op 'in name)) | |
461 | (setq type op)) | |
462 | ((get op ':defstruct-option) | |
463 | (push (cons op (if (emptyp val) t val)) | |
464 | (defstruct-description-property-alist))) | |
465 | (t | |
466 | #Q (multiple-value-bind (new foundp) | |
467 | (intern-soft op si:pkg-user-package) | |
468 | (or (not foundp) | |
469 | (eq op new) | |
470 | (progn (setq op new) (go AGAIN)))) | |
471 | (defstruct-error | |
472 | "defstruct doesn't understand this option" | |
473 | op 'in name)))))) | |
474 | (cond ((emptyp constructors) | |
475 | (setq constructors | |
476 | (list (cons (append-symbols 'make- name) | |
477 | nil))))) | |
478 | (setf (defstruct-description-constructors) constructors) | |
479 | (cond ((emptyp alterant) | |
480 | (setq alterant | |
481 | (append-symbols 'alter- name)))) | |
482 | (setf (defstruct-description-alterant) alterant) | |
483 | (cond ((not (null type)) | |
484 | (let ((type-description | |
485 | (or (get type 'defstruct-type-description) | |
486 | #Q (multiple-value-bind | |
487 | (new foundp) | |
488 | (intern-soft type si:pkg-user-package) | |
489 | (and foundp | |
490 | (not (eq type new)) | |
491 | (progn (setq type new) | |
492 | (get type 'defstruct-type-description)))) | |
493 | (defstruct-error | |
494 | "Unknown type in defstruct" | |
495 | type 'in name)))) | |
496 | (if named-p | |
497 | (setq type | |
498 | (or (defstruct-type-description-named-type) | |
499 | (defstruct-error | |
500 | "There is no way to make this defstruct type named" | |
501 | type 'in name))))))) | |
502 | (cond (included | |
503 | (let ((d (get-defstruct-description included))) | |
504 | (if (null type) | |
505 | (setq type (defstruct-description-type d)) | |
506 | (or (eq type (defstruct-description-type d)) | |
507 | (defstruct-error | |
508 | "defstruct types must agree for include option" | |
509 | included 'included-by name))) | |
510 | (and named-p | |
511 | (not (eq type (defstruct-type-description-named-type | |
512 | (or (get type 'defstruct-type-description) | |
513 | (defstruct-error | |
514 | "Unknown type in defstruct" | |
515 | type 'in name 'including included))))) | |
516 | (defstruct-error | |
517 | "Included defstruct's type isn't a named type" | |
518 | included 'included-by name)))) | |
519 | ((null type) | |
520 | (setq type | |
521 | (cond (named-p | |
522 | #+PDP10 ':named-hunk | |
523 | #+Franz ':named-vector | |
524 | #+Multics ':named-list | |
525 | #+LispM ':named-array) | |
526 | (t | |
527 | #+PDP10 ':hunk | |
528 | #+Franz ':named-vector | |
529 | #+Multics ':list | |
530 | #+LispM ':array))))) | |
531 | (let ((type-description (or (get type 'defstruct-type-description) | |
532 | (defstruct-error | |
533 | "Undefined defstruct type" | |
534 | type 'in name)))) | |
535 | (setf (defstruct-description-type) type) | |
536 | (setf (defstruct-description-named-p) | |
537 | (eq (defstruct-type-description-named-type) type))) | |
538 | description)) | |
539 | \f | |
540 | (defun defstruct-parse-items (items description) | |
541 | (let ((name (defstruct-description-name)) | |
542 | (offset (defstruct-description-initial-offset)) | |
543 | (include (defstruct-description-include)) | |
544 | (o-slot-alist nil) | |
545 | (conc-name (defstruct-description-conc-name))) | |
546 | (or (null include) | |
547 | (let ((d (get (car include) 'defstruct-description))) | |
548 | (setq offset (+ offset (defstruct-description-size d))) | |
549 | (setq o-slot-alist | |
550 | (subst nil nil (defstruct-description-slot-alist d))) | |
551 | (do ((l (cdr include) (cdr l)) | |
552 | (it) (val)) | |
553 | ((null l)) | |
554 | (cond ((atom (setq it (car l))) | |
555 | (setq val (make-empty))) | |
556 | (t | |
557 | (setq val (cadr it)) | |
558 | (setq it (car it)))) | |
559 | (let ((slot-description (cdr (assq it o-slot-alist)))) | |
560 | (and (null slot-description) | |
561 | (defstruct-error | |
562 | "Unknown slot in included defstruct" | |
563 | it 'in include 'included-by name)) | |
564 | (setf (defstruct-slot-description-init-code) val))))) | |
565 | (do ((i offset (1+ i)) | |
566 | (l items (cdr l)) | |
567 | (slot-alist nil) | |
568 | #+PDP10 (chars (exploden conc-name))) | |
569 | ((null l) | |
570 | (setq slot-alist (nreverse slot-alist)) | |
571 | (setf (defstruct-description-size) i) | |
572 | (setf (defstruct-description-slot-alist) | |
573 | (nconc o-slot-alist slot-alist)) | |
574 | slot-alist) | |
575 | (cond ((atom (car l)) | |
576 | (push (defstruct-parse-one-field | |
577 | (car l) i nil nil conc-name #+PDP10 chars) | |
578 | slot-alist)) | |
579 | ((atom (caar l)) | |
580 | (push (defstruct-parse-one-field | |
581 | (caar l) i nil (cdar l) conc-name #+PDP10 chars) | |
582 | slot-alist)) | |
583 | (t | |
584 | (do ll (car l) (cdr ll) (null ll) | |
585 | (push (defstruct-parse-one-field | |
586 | (caar ll) i (cadar ll) | |
587 | (cddar ll) conc-name #+PDP10 chars) | |
588 | slot-alist))))))) | |
589 | ||
590 | (defun defstruct-parse-one-field (it number ppss rest conc-name #+PDP10 chars) | |
591 | (let ((mname (if conc-name #+PDP10 (implode (append chars (exploden it))) | |
592 | #+Multics (make_atom (catenate conc-name it)) | |
593 | #+Franz (concat conc-name it) | |
594 | #+LispM (intern (string-append conc-name it)) | |
595 | it))) | |
596 | (cons it (make-defstruct-slot-description | |
597 | number number | |
598 | ppss ppss | |
599 | init-code (if (null rest) (make-empty) (car rest)) | |
600 | ref-macro-name mname)))) | |
601 | \f | |
602 | (defun defstruct-define-ref-macros (new-slots description) | |
603 | (let ((name (defstruct-description-name)) | |
604 | (returns nil)) | |
605 | (if (not (defstruct-description-callable-accessors)) | |
606 | (do ((l new-slots (cdr l)) | |
607 | (mname)) | |
608 | ((null l)) | |
609 | (setq mname (defstruct-slot-description-ref-macro-name (cdar l))) | |
610 | (defstruct-put-macro mname 'defstruct-expand-ref-macro) | |
611 | (defstruct-putprop mname (cons name (caar l)) 'defstruct-slot)) | |
612 | (let ((type-description | |
613 | (get (defstruct-description-type) | |
614 | 'defstruct-type-description))) | |
615 | (let ((code (defstruct-type-description-ref-expander)) | |
616 | (n (defstruct-type-description-ref-no-args)) | |
617 | (but-first (defstruct-description-but-first)) | |
618 | (default-pointer (defstruct-description-default-pointer))) | |
619 | (do ((args nil (cons (gensym) args)) | |
620 | (i n (1- i))) | |
621 | ((< i 2) | |
622 | ;;Last arg (if it exists) is name of structure, | |
623 | ;; for documentation purposes. | |
624 | (and (= i 1) | |
625 | (setq args (cons name args))) | |
626 | (let ((body (cons (if but-first | |
627 | `(,but-first ,(car args)) | |
628 | (car args)) | |
629 | (cdr args)))) | |
630 | (and default-pointer | |
631 | (setq args `((,(car args) ,default-pointer) | |
632 | &optional . ,(cdr args)))) | |
633 | (setq args (reverse args)) | |
634 | (setq body (reverse body)) | |
635 | (do ((l new-slots (cdr l)) | |
636 | (mname)) | |
637 | ((null l)) | |
638 | (setq mname (defstruct-slot-description-ref-macro-name | |
639 | (cdar l))) | |
640 | #M ;;This must come BEFORE the defun. THINK! | |
641 | (defstruct-put-macro mname 'defstruct-expand-ref-macro) | |
642 | (let ((ref (lexpr-funcall | |
643 | code | |
644 | (defstruct-slot-description-number (cdar l)) | |
645 | description | |
646 | body)) | |
647 | (ppss (defstruct-slot-description-ppss (cdar l)))) | |
648 | (push `(#+(or Franz Maclisp) | |
649 | defun #Q defsubst ,mname ,args | |
650 | ,(if (null ppss) ref `(ldb ,ppss ,ref))) | |
651 | returns)) | |
652 | (defstruct-putprop mname | |
653 | (cons name (caar l)) | |
654 | 'defstruct-slot)))))))) | |
655 | returns)) | |
656 | \f | |
657 | (defun defstruct-expand-size-macro (x) | |
658 | (let ((description (get-defstruct-description (get (car x) 'defstruct-name)))) | |
659 | (let ((type-description (get (defstruct-description-type) | |
660 | 'defstruct-type-description))) | |
661 | (funcall (defstruct-description-displace) | |
662 | x | |
663 | (+ (defstruct-description-size) | |
664 | (defstruct-type-description-overhead)))))) | |
665 | ||
666 | (defun defstruct-expand-ref-macro (x) | |
667 | (let* ((pair (get (car x) 'defstruct-slot)) | |
668 | (description (get-defstruct-description (car pair))) | |
669 | (type-description | |
670 | (get (defstruct-description-type) 'defstruct-type-description)) | |
671 | (code (defstruct-type-description-ref-expander)) | |
672 | (n (defstruct-type-description-ref-no-args)) | |
673 | (args (reverse (cdr x))) | |
674 | (nargs (length args)) | |
675 | (default (defstruct-description-default-pointer)) | |
676 | (but-first (defstruct-description-but-first))) | |
677 | (cond ((= n nargs) | |
678 | (and but-first | |
679 | (rplaca args `(,but-first ,(car args))))) | |
680 | ((and (= n (1+ nargs)) default) | |
681 | (setq args (cons (if but-first | |
682 | `(,but-first ,default) | |
683 | default) | |
684 | args))) | |
685 | (t | |
686 | (defstruct-error | |
687 | "Wrong number of args to an accessor macro" x))) | |
688 | (let* ((slot-description | |
689 | (cdr (or (assq (cdr pair) | |
690 | (defstruct-description-slot-alist)) | |
691 | (defstruct-error | |
692 | "This slot no longer exists in this structure" | |
693 | (cdr pair) 'in (car pair))))) | |
694 | (ref (lexpr-funcall | |
695 | code | |
696 | (defstruct-slot-description-number) | |
697 | description | |
698 | (nreverse args))) | |
699 | (ppss (defstruct-slot-description-ppss))) | |
700 | (funcall (defstruct-description-displace) | |
701 | x | |
702 | (if (null ppss) | |
703 | ref | |
704 | `(ldb ,ppss ,ref)))))) | |
705 | \f | |
706 | (defun defstruct-parse-setq-style-slots (l slots others x) | |
707 | (do ((l l (cddr l)) | |
708 | (kludge (cons nil nil))) | |
709 | ((null l) kludge) | |
710 | (or (and (cdr l) | |
711 | (symbolp (car l))) | |
712 | (defstruct-error | |
713 | "Bad argument list to constructor or alterant macro" x)) | |
714 | (defstruct-make-init-dsc kludge (car l) (cadr l) slots others x))) | |
715 | ||
716 | (defun defstruct-make-init-dsc (kludge name code slots others x) | |
717 | (let ((p (assq name slots))) | |
718 | (if (null p) | |
719 | (if (memq name others) | |
720 | (push (cons name code) (cdr kludge)) | |
721 | (defstruct-error | |
722 | "Unknown slot to constructor or alterant macro" x)) | |
723 | (let* ((slot-description (cdr p)) | |
724 | (number (defstruct-slot-description-number)) | |
725 | (ppss (defstruct-slot-description-ppss)) | |
726 | (dsc (assoc number (car kludge)))) | |
727 | (cond ((null dsc) | |
728 | (setq dsc (list* number nil (make-empty) 0 0 nil)) | |
729 | (push dsc (car kludge)))) | |
730 | (cond ((null ppss) | |
731 | (setf (car (cddr dsc)) code) | |
732 | (setf (cadr dsc) t)) | |
733 | (t (cond #-Franz | |
734 | ((and (numberp ppss) (numberp code)) | |
735 | (setf (ldb ppss (cadr (cddr dsc))) -1) | |
736 | (setf (ldb ppss (caddr (cddr dsc))) code)) | |
737 | (t | |
738 | (push (cons ppss code) (cdddr (cddr dsc))))) | |
739 | (or (eq t (cadr dsc)) | |
740 | (push name (cadr dsc))))))))) | |
741 | ||
742 | (defun defstruct-code-from-dsc (dsc) | |
743 | (let ((code (car (cddr dsc))) | |
744 | (mask (cadr (cddr dsc))) | |
745 | (bits (caddr (cddr dsc)))) | |
746 | (if (emptyp code) | |
747 | (setq code bits) | |
748 | (or (zerop mask) | |
749 | (setq code (if (numberp code) | |
750 | (boole 7 bits (boole 2 mask code)) | |
751 | (if (zerop (logand mask | |
752 | (1+ (logior mask (1- mask))))) | |
753 | (let ((ss (haulong (boole 2 mask (1- mask))))) | |
754 | `(dpb ,(lsh bits (- ss)) | |
755 | ,(logior (lsh ss 6) | |
756 | (logand #o77 | |
757 | (- (haulong mask) ss))) | |
758 | ,code)) | |
759 | `(boole 7 ,bits (boole 2 ,mask ,code))))))) | |
760 | (do l (cdddr (cddr dsc)) (cdr l) (null l) | |
761 | (setq code `(dpb ,(cdar l) ,(caar l) ,code))) | |
762 | code)) | |
763 | \f | |
764 | (defun defstruct-expand-cons-macro (x) | |
765 | (let* ((description (get-defstruct-description (get (car x) 'defstruct-name))) | |
766 | (type-description (get (defstruct-description-type) | |
767 | 'defstruct-type-description)) | |
768 | (slot-alist (defstruct-description-slot-alist)) | |
769 | (cons-keywords (defstruct-type-description-cons-keywords)) | |
770 | inits kludge | |
771 | (constructor-description | |
772 | (cdr (or (assq (car x) (defstruct-description-constructors)) | |
773 | (defstruct-error | |
774 | "This constructor is no longer defined for this structure" | |
775 | (car x) 'in (defstruct-description-name))))) | |
776 | (aux nil) | |
777 | (aux-init nil)) | |
778 | (if (null constructor-description) | |
779 | (setq kludge (defstruct-parse-setq-style-slots (cdr x) | |
780 | slot-alist | |
781 | cons-keywords | |
782 | x)) | |
783 | (prog (args l) | |
784 | (setq kludge (cons nil nil)) | |
785 | (setq args (cdr x)) | |
786 | (setq l (car constructor-description)) | |
787 | R (cond ((null l) | |
788 | (if (null args) | |
789 | (return nil) | |
790 | (go barf-tma))) | |
791 | ((atom l) (go barf)) | |
792 | ((eq (car l) '&optional) (go O)) | |
793 | ((eq (car l) '&rest) (go S)) | |
794 | ((eq (car l) '&aux) (go A)) | |
795 | ((null args) (go barf-tfa))) | |
796 | (defstruct-make-init-dsc kludge | |
797 | (pop l) | |
798 | (pop args) | |
799 | slot-alist | |
800 | cons-keywords | |
801 | x) | |
802 | (go R) | |
803 | O (and (null args) (go OD)) | |
804 | (pop l) | |
805 | (cond ((null l) (go barf-tma)) | |
806 | ((atom l) (go barf)) | |
807 | ((eq (car l) '&optional) (go barf)) | |
808 | ((eq (car l) '&rest) (go S)) | |
809 | ((eq (car l) '&aux) (go barf-tma))) | |
810 | (defstruct-make-init-dsc kludge | |
811 | (if (atom (car l)) (car l) (caar l)) | |
812 | (pop args) | |
813 | slot-alist | |
814 | cons-keywords | |
815 | x) | |
816 | (go O) | |
817 | OD (pop l) | |
818 | (cond ((null l) (return nil)) | |
819 | ((atom l) (go barf)) | |
820 | ((eq (car l) '&optional) (go barf)) | |
821 | ((eq (car l) '&rest) (go S)) | |
822 | ((eq (car l) '&aux) (go A))) | |
823 | (or (atom (car l)) | |
824 | (defstruct-make-init-dsc kludge | |
825 | (caar l) | |
826 | (cadar l) | |
827 | slot-alist | |
828 | cons-keywords | |
829 | x)) | |
830 | (go OD) | |
831 | S (and (atom (cdr l)) (go barf)) | |
832 | (defstruct-make-init-dsc kludge | |
833 | (cadr l) | |
834 | `(list . ,args) | |
835 | slot-alist | |
836 | cons-keywords | |
837 | x) | |
838 | (setq l (cddr l)) | |
839 | (and (null l) (return nil)) | |
840 | (and (atom l) (go barf)) | |
841 | (or (eq (car l) '&aux) (go barf)) | |
842 | A (pop l) | |
843 | (cond ((null l) (return nil)) | |
844 | ((atom l) (go barf)) | |
845 | ((atom (car l)) | |
846 | (push (car l) aux) | |
847 | (push (make-empty) aux-init)) | |
848 | (t | |
849 | (push (caar l) aux) | |
850 | (push (cadar l) aux-init))) | |
851 | (go A) | |
852 | barf (defstruct-error | |
853 | "Bad format for defstruct constructor arglist" | |
854 | `(,(car x) . ,(car constructor-description))) | |
855 | barf-tfa (defstruct-error "Too few arguments to constructor macro" x) | |
856 | barf-tma (defstruct-error "Too many arguments to constructor macro" x))) | |
857 | (do l slot-alist (cdr l) (null l) | |
858 | (let* ((name (caar l)) | |
859 | (slot-description (cdar l)) | |
860 | (code (do ((aux aux (cdr aux)) | |
861 | (aux-init aux-init (cdr aux-init))) | |
862 | ((null aux) (defstruct-slot-description-init-code)) | |
863 | (and (eq name (car aux)) (return (car aux-init))))) | |
864 | (ppss (defstruct-slot-description-ppss))) | |
865 | (or (and (emptyp code) (null ppss)) | |
866 | (let* ((number (defstruct-slot-description-number)) | |
867 | (dsc (assoc number (car kludge)))) | |
868 | (cond ((null dsc) | |
869 | (setq dsc (list* number nil (make-empty) 0 0 nil)) | |
870 | (push dsc (car kludge)))) | |
871 | (cond ((emptyp code)) | |
872 | ((eq t (cadr dsc))) | |
873 | ((null ppss) | |
874 | (and (emptyp (car (cddr dsc))) | |
875 | (setf (car (cddr dsc)) code))) | |
876 | ((memq name (cadr dsc))) | |
877 | #-Franz | |
878 | ((and (numberp ppss) (numberp code)) | |
879 | (setf (ldb ppss (cadr (cddr dsc))) -1) | |
880 | (setf (ldb ppss (caddr (cddr dsc))) code)) | |
881 | (t | |
882 | (push (cons ppss code) (cdddr (cddr dsc))))))))) | |
883 | (selectq (defstruct-type-description-cons-flavor) | |
884 | (:list | |
885 | (do ((l nil (cons nil l)) | |
886 | (i (defstruct-description-size) (1- i))) | |
887 | ((= i 0) (setq inits l))) | |
888 | (do l (car kludge) (cdr l) (null l) | |
889 | (setf (nth (caar l) inits) | |
890 | (defstruct-code-from-dsc (car l))))) | |
891 | (:alist | |
892 | (setq inits (car kludge)) | |
893 | (do l inits (cdr l) (null l) | |
894 | (rplacd (car l) (defstruct-code-from-dsc (car l))))) | |
895 | (otherwise | |
896 | (defstruct-error | |
897 | "Unknown flavor to constructor macro expander" | |
898 | (defstruct-description-type)))) | |
899 | (funcall (defstruct-description-displace) | |
900 | x (funcall (defstruct-type-description-cons-expander) | |
901 | inits description (cdr kludge))))) | |
902 | \f | |
903 | (defun defstruct-expand-alter-macro (x) | |
904 | (let* ((description (get-defstruct-description (get (car x) 'defstruct-name))) | |
905 | (type-description (get (defstruct-description-type) | |
906 | 'defstruct-type-description)) | |
907 | (ref-code (defstruct-type-description-ref-expander))) | |
908 | (or (= 1 (defstruct-type-description-ref-no-args)) | |
909 | (defstruct-error | |
910 | "Alterant macros cannot handle this defstruct type" | |
911 | (defstruct-description-type))) | |
912 | (do ((l (car (defstruct-parse-setq-style-slots | |
913 | (cddr x) | |
914 | (defstruct-description-slot-alist) | |
915 | nil | |
916 | x)) | |
917 | (cdr l)) | |
918 | (but-first (defstruct-description-but-first)) | |
919 | (body nil) | |
920 | (var (gensym)) | |
921 | (vars nil) | |
922 | (vals nil)) | |
923 | ((null l) | |
924 | (funcall (defstruct-description-displace) | |
925 | x | |
926 | `((lambda (,var) | |
927 | . ,(if (null vars) | |
928 | body | |
929 | `(((lambda ,vars . ,body) . ,vals)))) | |
930 | ,(if but-first | |
931 | `(,but-first ,(cadr x)) | |
932 | (cadr x))))) | |
933 | (let ((ref (funcall ref-code (caar l) description var))) | |
934 | (and (emptyp (car (cddr (car l)))) | |
935 | (setf (car (cddr (car l))) ref)) | |
936 | (let ((code (defstruct-code-from-dsc (car l)))) | |
937 | (if (null (cdr l)) | |
938 | (push `(setf ,ref ,code) body) | |
939 | (let ((sym (gensym))) | |
940 | (push `(setf ,ref ,sym) body) | |
941 | (push sym vars) | |
942 | (push code vals)))))))) | |
943 | \f | |
944 | (defmacro defstruct-define-type (type . options) | |
945 | (do ((options options (cdr options)) | |
946 | (op) (args) | |
947 | (type-description (make-defstruct-type-description)) | |
948 | (cons-expander nil) | |
949 | (ref-expander nil) | |
950 | (defstruct-expander nil)) | |
951 | ((null options) | |
952 | (or cons-expander | |
953 | (defstruct-error "No cons option in defstruct-define-type" type)) | |
954 | (or ref-expander | |
955 | (defstruct-error "No ref option in defstruct-define-type" type)) | |
956 | `(progn 'compile | |
957 | ,cons-expander | |
958 | ,ref-expander | |
959 | ,@(and defstruct-expander (list defstruct-expander)) | |
960 | (defprop ,type ,type-description defstruct-type-description))) | |
961 | (cond ((atom (setq op (car options))) | |
962 | (setq args nil)) | |
963 | (t | |
964 | (setq args (cdr op)) | |
965 | (setq op (car op)))) | |
966 | #Q AGAIN | |
967 | (selectq op | |
968 | (:cons | |
969 | (or (> (length args) 2) | |
970 | (defstruct-error | |
971 | "Bad cons option in defstruct-define-type" | |
972 | (car options) 'in type)) | |
973 | (let ((n (length (car args))) | |
974 | (name (append-symbols type '-defstruct-cons))) | |
975 | (or (= n 3) | |
976 | (defstruct-error | |
977 | "Bad cons option in defstruct-define-type" | |
978 | (car options) 'in type)) | |
979 | (setf (defstruct-type-description-cons-flavor) | |
980 | #-LispM (cadr args) | |
981 | #+LispM (intern (string (cadr args)) si:pkg-user-package)) | |
982 | (setf (defstruct-type-description-cons-expander) name) | |
983 | (setq cons-expander `(defun ,name ,(car args) | |
984 | . ,(cddr args))))) | |
985 | (:ref | |
986 | (or (> (length args) 1) | |
987 | (defstruct-error | |
988 | "Bad ref option in defstruct-define-type" | |
989 | (car options) 'in type)) | |
990 | (let ((n (length (car args))) | |
991 | (name (append-symbols type '-defstruct-ref))) | |
992 | (or (> n 2) | |
993 | (defstruct-error | |
994 | "Bad ref option in defstruct-define-type" | |
995 | (car options) 'in type)) | |
996 | (setf (defstruct-type-description-ref-no-args) (- n 2)) | |
997 | (setf (defstruct-type-description-ref-expander) name) | |
998 | (setq ref-expander `(defun ,name ,(car args) | |
999 | . ,(cdr args))))) | |
1000 | (:overhead | |
1001 | (setf (defstruct-type-description-overhead) | |
1002 | (if (null args) | |
1003 | (defstruct-error | |
1004 | "Bad option to defstruct-define-type" | |
1005 | (car options) 'in type) | |
1006 | (car args)))) | |
1007 | (:named | |
1008 | (setf (defstruct-type-description-named-type) | |
1009 | (if (null args) | |
1010 | type | |
1011 | (car args)))) | |
1012 | (:keywords | |
1013 | (setf (defstruct-type-description-cons-keywords) args)) | |
1014 | (:defstruct | |
1015 | (or (> (length args) 1) | |
1016 | (defstruct-error | |
1017 | "Bad defstruct option in defstruct-define-type" | |
1018 | (car options) 'in type)) | |
1019 | (let ((name (append-symbols type '-defstruct-expand))) | |
1020 | (setf (defstruct-type-description-defstruct-expander) name) | |
1021 | (setq defstruct-expander `(defun ,name . ,args)))) | |
1022 | (otherwise | |
1023 | #Q (multiple-value-bind (new foundp) | |
1024 | (intern-soft op si:pkg-user-package) | |
1025 | (or (not foundp) | |
1026 | (eq op new) | |
1027 | (progn (setq op new) (go AGAIN)))) | |
1028 | (defstruct-error | |
1029 | "Unknown option to defstruct-define-type" | |
1030 | (car options) 'in type))))) | |
1031 | \f | |
1032 | #Q | |
1033 | (defprop :make-array t :defstruct-option) | |
1034 | ||
1035 | (defstruct-define-type :array | |
1036 | #Q (:named :named-array) | |
1037 | #Q (:keywords :make-array) | |
1038 | (:cons | |
1039 | (arg description etc) :alist | |
1040 | #M etc ;ignored in MacLisp | |
1041 | #F etc ;ignored in MacLisp | |
1042 | #Q (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i)) | |
1043 | description etc nil nil nil 1) | |
1044 | #M (maclisp-array-for-defstruct arg description 't) | |
1045 | #F (maclisp-array-for-defstruct arg description 't)) | |
1046 | (:ref | |
1047 | (n description arg) | |
1048 | description ;ignored | |
1049 | #M `(arraycall t ,arg ,n) | |
1050 | #F `(arraycall t ,arg ,n) | |
1051 | #Q `(aref ,arg ,n))) | |
1052 | ||
1053 | #Q | |
1054 | (defstruct-define-type :named-array | |
1055 | (:keywords :make-array) | |
1056 | :named (:overhead 1) | |
1057 | (:cons | |
1058 | (arg description etc) :alist | |
1059 | (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,(1+ i))) | |
1060 | description etc nil t nil 1)) | |
1061 | (:ref (n description arg) | |
1062 | description ;ignored | |
1063 | `(aref ,arg ,(1+ n)))) | |
1064 | ||
1065 | (defstruct-define-type :fixnum-array | |
1066 | #Q (:keywords :make-array) | |
1067 | (:cons | |
1068 | (arg description etc) :alist | |
1069 | #M etc ;ignored in MacLisp | |
1070 | #F etc ;ignored in MacLisp | |
1071 | #Q (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i)) | |
1072 | description etc 'art-32b nil nil 1) | |
1073 | #M (maclisp-array-for-defstruct arg description 'fixnum) | |
1074 | #F (maclisp-array-for-defstruct arg description 'fixnum)) | |
1075 | (:ref | |
1076 | (n description arg) | |
1077 | description ;ignored | |
1078 | #M `(arraycall fixnum ,arg ,n) | |
1079 | #F `(arraycall fixnum ,arg ,n) | |
1080 | #Q `(aref ,arg ,n))) | |
1081 | ||
1082 | (defstruct-define-type :flonum-array | |
1083 | #Q (:keywords :make-array) | |
1084 | (:cons | |
1085 | (arg description etc) :alist | |
1086 | #M etc ;ignored in MacLisp | |
1087 | #F etc ;ignored in MacLisp | |
1088 | #Q (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i)) | |
1089 | description etc 'art-float nil nil 1) | |
1090 | #M (maclisp-array-for-defstruct arg description 'flonum) | |
1091 | #F (maclisp-array-for-defstruct arg description 'flonum)) | |
1092 | (:ref | |
1093 | (n description arg) | |
1094 | description ;ignored | |
1095 | #M `(arraycall flonum ,arg ,n) | |
1096 | #F `(arraycall flonum ,arg ,n) | |
1097 | #Q `(aref ,arg ,n))) | |
1098 | ||
1099 | #M | |
1100 | (defstruct-define-type :un-gc-array | |
1101 | (:cons | |
1102 | (arg description etc) :alist | |
1103 | etc ;ignored | |
1104 | (maclisp-array-for-defstruct arg description 'nil)) | |
1105 | (:ref | |
1106 | (n description arg) | |
1107 | description ;ignored | |
1108 | `(arraycall nil ,arg ,n))) | |
1109 | ||
1110 | #Q | |
1111 | (defstruct-define-type :array-leader | |
1112 | (:named :named-array-leader) | |
1113 | (:keywords :make-array) | |
1114 | (:cons | |
1115 | (arg description etc) :alist | |
1116 | (lispm-array-for-defstruct arg #'(lambda (v a i) | |
1117 | `(store-array-leader ,v ,a ,i)) | |
1118 | description etc nil nil t 1)) | |
1119 | (:ref | |
1120 | (n description arg) | |
1121 | description ;ignored | |
1122 | `(array-leader ,arg ,n))) | |
1123 | ||
1124 | #Q | |
1125 | (defstruct-define-type :named-array-leader | |
1126 | (:keywords :make-array) | |
1127 | :named (:overhead 1) | |
1128 | (:cons | |
1129 | (arg description etc) :alist | |
1130 | (lispm-array-for-defstruct | |
1131 | arg | |
1132 | #'(lambda (v a i) | |
1133 | `(store-array-leader ,v ,a ,(if (zerop i) | |
1134 | 0 | |
1135 | (1+ i)))) | |
1136 | description etc nil t t 1)) | |
1137 | (:ref | |
1138 | (n description arg) | |
1139 | description ;ignored | |
1140 | (if (zerop n) | |
1141 | `(array-leader ,arg 0) | |
1142 | `(array-leader ,arg ,(1+ n))))) | |
1143 | ||
1144 | #Q | |
1145 | (defprop :times t :defstruct-option) | |
1146 | ||
1147 | #Q | |
1148 | (defstruct-define-type :grouped-array | |
1149 | (:keywords :make-array :times) | |
1150 | (:cons | |
1151 | (arg description etc) :alist | |
1152 | (lispm-array-for-defstruct | |
1153 | arg | |
1154 | #'(lambda (v a i) `(aset ,v ,a ,i)) | |
1155 | description etc nil nil nil | |
1156 | (or (cdr (or (assq ':times etc) | |
1157 | (assq ':times (defstruct-description-property-alist)))) | |
1158 | 1))) | |
1159 | (:ref | |
1160 | (n description index arg) | |
1161 | description ;ignored | |
1162 | (cond ((numberp index) | |
1163 | `(aref ,arg ,(+ n index))) | |
1164 | ((zerop n) | |
1165 | `(aref ,arg ,index)) | |
1166 | (t `(aref ,arg (+ ,n ,index)))))) | |
1167 | \f | |
1168 | #Q | |
1169 | (defun lispm-array-for-defstruct (arg cons-init description etc type named-p leader-p times) | |
1170 | (let ((p (cons nil nil)) | |
1171 | (no-op 'nil)) | |
1172 | (defstruct-grok-make-array-args | |
1173 | (cdr (assq ':make-array (defstruct-description-property-alist))) | |
1174 | p) | |
1175 | (defstruct-grok-make-array-args | |
1176 | (cdr (assq ':make-array etc)) | |
1177 | p) | |
1178 | (and type (putprop p type ':type)) | |
1179 | (and named-p (putprop p `',(defstruct-description-name) ':named-structure-symbol)) | |
1180 | (putprop p | |
1181 | (let ((size (if named-p | |
1182 | (1+ (defstruct-description-size)) | |
1183 | (defstruct-description-size)))) | |
1184 | (if (numberp times) | |
1185 | (* size times) | |
1186 | `(* ,size ,times))) | |
1187 | (if leader-p ':leader-length ':dimensions)) | |
1188 | (or leader-p | |
1189 | (let ((type (get p ':type))) | |
1190 | (or (atom type) | |
1191 | (not (eq (car type) 'quote)) | |
1192 | (setq type (cadr type))) | |
1193 | (caseq type | |
1194 | ((nil art-q art-q-list)) | |
1195 | ((art-32b art-16b art-8b art-4b art-2b art-1b art-string) (setq no-op '0)) | |
1196 | ((art-float) (setq no-op '0.0)) | |
1197 | (t (setq no-op (make-empty)))))) | |
1198 | (do ((creator | |
1199 | (let ((dims (remprop p ':dimensions))) | |
1200 | (do l (cdr p) (cddr l) (null l) | |
1201 | (rplaca l `',(car l))) | |
1202 | `(make-array ,(if (null dims) 0 (car dims)) ,@(cdr p)))) | |
1203 | (var (gensym)) | |
1204 | (set-ups nil (if (equal (cdar l) no-op) | |
1205 | set-ups | |
1206 | (cons (funcall cons-init (cdar l) var (caar l)) | |
1207 | set-ups))) | |
1208 | (l arg (cdr l))) | |
1209 | ((null l) | |
1210 | (if set-ups | |
1211 | `((lambda (,var) | |
1212 | ,@(nreverse set-ups) | |
1213 | ,var) | |
1214 | ,creator) | |
1215 | creator))))) | |
1216 | ||
1217 | #Q | |
1218 | (defun defstruct-grok-make-array-args (args p) | |
1219 | (let ((nargs (length args))) | |
1220 | (if (and (not (> nargs 7)) | |
1221 | (or (oddp nargs) | |
1222 | (do ((l args (cddr l))) | |
1223 | ((null l) nil) | |
1224 | (or (memq (car l) '(:area :type :displaced-to :leader-list | |
1225 | :leader-length :displaced-index-offset | |
1226 | :named-structure-symbol :dimensions | |
1227 | :length)) | |
1228 | (return t))))) | |
1229 | (do ((l args (cdr l)) | |
1230 | (keylist '(:area :type :dimensions :displaced-to :old-leader-length-or-list | |
1231 | :displaced-index-offset :named-structure-symbol) | |
1232 | (cdr keylist))) | |
1233 | ((null l) | |
1234 | (and (boundp 'compiler:compiler-warnings-context) | |
1235 | (boundp 'compiler:last-error-function) | |
1236 | (not (null compiler:compiler-warnings-context)) | |
1237 | (compiler:barf args '|-- old style :MAKE-ARRAY constructor keyword argument| | |
1238 | 'compiler:warn)) | |
1239 | p) | |
1240 | (putprop p (car l) (car keylist))) | |
1241 | (do ((l args (cddr l))) | |
1242 | ((null l) p) | |
1243 | (if (or (null (cdr l)) | |
1244 | (not (memq (car l) '(:area :type :displaced-to :leader-list | |
1245 | :leader-length :displaced-index-offset | |
1246 | :named-structure-symbol :dimensions | |
1247 | :length)))) | |
1248 | (defstruct-error | |
1249 | "defstruct can't grok these make-array arguments" | |
1250 | args)) | |
1251 | (putprop p | |
1252 | (cadr l) | |
1253 | (if (eq (car l) ':length) | |
1254 | ':dimensions | |
1255 | (car l))))))) | |
1256 | ||
1257 | #+(or Franz Maclisp) | |
1258 | (defun maclisp-array-for-defstruct (arg description type) | |
1259 | (do ((creator `(array nil ,type ,(defstruct-description-size))) | |
1260 | (var (gensym)) | |
1261 | (no-op (caseq type | |
1262 | (fixnum 0) | |
1263 | (flonum 0.0) | |
1264 | ((t nil) nil))) | |
1265 | (set-ups nil (if (equal (cdar l) no-op) | |
1266 | set-ups | |
1267 | (cons `(store (arraycall ,type ,var ,(caar l)) | |
1268 | ,(cdar l)) | |
1269 | set-ups))) | |
1270 | (l arg (cdr l))) | |
1271 | ((null l) | |
1272 | (if set-ups | |
1273 | `((lambda (,var) | |
1274 | ,@(nreverse set-ups) | |
1275 | ,var) | |
1276 | ,creator) | |
1277 | creator)))) | |
1278 | \f | |
1279 | #+PDP10 | |
1280 | (defprop :sfa-function t :defstruct-option) | |
1281 | ||
1282 | #+PDP10 | |
1283 | (defprop :sfa-name t :defstruct-option) | |
1284 | ||
1285 | #+PDP10 | |
1286 | (defstruct-define-type :sfa | |
1287 | (:keywords :sfa-function :sfa-name) | |
1288 | (:cons | |
1289 | (arg description etc) :alist | |
1290 | (do ((creator `(sfa-create ,(or (cdr (or (assq ':sfa-function etc) | |
1291 | (assq ':sfa-function (defstruct-description-property-alist)))) | |
1292 | `',(defstruct-description-name)) | |
1293 | ,(defstruct-description-size) | |
1294 | ,(or (cdr (or (assq ':sfa-name etc) | |
1295 | (assq ':sfa-name (defstruct-description-property-alist)))) | |
1296 | `',(defstruct-description-name)))) | |
1297 | (l arg (cdr l)) | |
1298 | (var (gensym)) | |
1299 | (set-ups nil (if (null (cdar l)) | |
1300 | set-ups | |
1301 | (cons `(sfa-store ,var ,(caar l) | |
1302 | ,(cdar l)) | |
1303 | set-ups)))) | |
1304 | ((null l) | |
1305 | (if set-ups | |
1306 | `((lambda (,var) | |
1307 | ,@(nreverse set-ups) | |
1308 | ,var) | |
1309 | ,creator) | |
1310 | creator)))) | |
1311 | (:ref | |
1312 | (n description arg) | |
1313 | description ;ignored | |
1314 | `(sfa-get ,arg ,n))) | |
1315 | \f | |
1316 | #+(or Franz PDP10) | |
1317 | (defstruct-define-type :hunk | |
1318 | (:named :named-hunk) | |
1319 | (:cons | |
1320 | (arg description etc) :list | |
1321 | description ;ignored | |
1322 | etc ;ignored | |
1323 | (if arg | |
1324 | #+PDP-10 `(hunk . ,(nconc (cdr arg) (ncons (car arg)))) | |
1325 | #+Franz `(hunk . ,arg) | |
1326 | (defstruct-error "No slots in hunk type defstruct"))) | |
1327 | (:ref | |
1328 | (n description arg) | |
1329 | description ;ignored | |
1330 | `(cxr ,n ,arg))) | |
1331 | ||
1332 | #+(or Franz PDP10) | |
1333 | (defstruct-define-type :named-hunk | |
1334 | :named (:overhead 1) | |
1335 | (:cons | |
1336 | (arg description etc) :list | |
1337 | etc ;ignored | |
1338 | (if arg | |
1339 | #+PDP-10 `(hunk ',(defstruct-description-name) | |
1340 | . ,(nconc (cdr arg) (ncons (car arg)))) | |
1341 | #+Franz `(hunk ',(defstruct-description-name) | |
1342 | . ,arg) | |
1343 | `(hunk ',(defstruct-description-name) nil))) | |
1344 | (:ref | |
1345 | (n description arg) | |
1346 | description ;ignored | |
1347 | (cond #+PDP-10 ((= n 0) `(cxr 0 ,arg)) | |
1348 | (t `(cxr ,(1+ n) ,arg))))) | |
1349 | ||
1350 | #+(or Franz PDP10 NIL ) | |
1351 | (defstruct-define-type :vector | |
1352 | #+Franz | |
1353 | (:named :named-vector) | |
1354 | (:cons | |
1355 | (arg description etc) :list | |
1356 | description ;ignored | |
1357 | etc ;ignored | |
1358 | `(vector ,@arg)) | |
1359 | (:ref | |
1360 | (n description arg) | |
1361 | description ;ignored | |
1362 | `(vref ,arg ,n))) | |
1363 | ||
1364 | #+Franz | |
1365 | (defstruct-define-type :named-vector | |
1366 | :named | |
1367 | (:cons | |
1368 | (arg description etc) :list | |
1369 | description ;ignored | |
1370 | etc ;ignored | |
1371 | `(let ((nv (vector ,@arg))) | |
1372 | (vsetprop nv ',(defstruct-description-name)) | |
1373 | nv)) | |
1374 | (:ref | |
1375 | (n description arg) | |
1376 | description ;ignored | |
1377 | `(vref ,arg ,n))) | |
1378 | \f | |
1379 | (defstruct-define-type :list | |
1380 | (:named :named-list) | |
1381 | (:cons | |
1382 | (arg description etc) :list | |
1383 | description ;ignored | |
1384 | etc ;ignored | |
1385 | `(list . ,arg)) | |
1386 | (:ref | |
1387 | (n description arg) | |
1388 | description ;ignored | |
1389 | #+Multics `(,(let ((i (\ n 4))) | |
1390 | (cond ((= i 0) 'car) | |
1391 | ((= i 1) 'cadr) | |
1392 | ((= i 2) 'caddr) | |
1393 | (t 'cadddr))) | |
1394 | ,(do ((a arg `(cddddr ,a)) | |
1395 | (i (// n 4) (1- i))) | |
1396 | ((= i 0) a))) | |
1397 | #-Multics `(nth ,n ,arg))) | |
1398 | ||
1399 | (defstruct-define-type :named-list | |
1400 | :named (:overhead 1) | |
1401 | (:cons | |
1402 | (arg description etc) :list | |
1403 | etc ;ignored | |
1404 | `(list ',(defstruct-description-name) . ,arg)) | |
1405 | (:ref | |
1406 | (n description arg) | |
1407 | description ;ignored | |
1408 | #+Multics `(,(let ((i (\ (1+ n) 4))) | |
1409 | (cond ((= i 0) 'car) | |
1410 | ((= i 1) 'cadr) | |
1411 | ((= i 2) 'caddr) | |
1412 | (t 'cadddr))) | |
1413 | ,(do ((a arg `(cddddr ,a)) | |
1414 | (i (// (1+ n) 4) (1- i))) | |
1415 | ((= i 0) a))) | |
1416 | #-Multics `(nth ,(1+ n) ,arg))) | |
1417 | \f | |
1418 | (defstruct-define-type :list* | |
1419 | (:cons | |
1420 | (arg description etc) :list | |
1421 | description ;ignored | |
1422 | etc ;ignored | |
1423 | `(list* . ,arg)) | |
1424 | (:ref | |
1425 | (n description arg) | |
1426 | (let ((size (1- (defstruct-description-size)))) | |
1427 | #+Multics (do ((a arg `(cddddr ,a)) | |
1428 | (i (// n 4) (1- i))) | |
1429 | ((= i 0) | |
1430 | (let* ((i (\ n 4)) | |
1431 | (a (cond ((= i 0) a) | |
1432 | ((= i 1) `(cdr ,a)) | |
1433 | ((= i 2) `(cddr ,a)) | |
1434 | (t `(cdddr ,a))))) | |
1435 | (if (< n size) `(car ,a) a)))) | |
1436 | #-Multics (if (< n size) | |
1437 | `(nth ,n ,arg) | |
1438 | `(nthcdr ,n ,arg)))) | |
1439 | (:defstruct (description) | |
1440 | (and (defstruct-description-include) | |
1441 | (defstruct-error | |
1442 | "Structure of type list* cannot include another" | |
1443 | (defstruct-description-name))) | |
1444 | nil)) | |
1445 | ||
1446 | (defstruct-define-type :tree | |
1447 | (:cons | |
1448 | (arg description etc) :list | |
1449 | etc ;ignored | |
1450 | (if (null arg) (defstruct-error | |
1451 | "defstruct cannot make an empty tree" | |
1452 | (defstruct-description-name))) | |
1453 | (make-tree-for-defstruct arg (defstruct-description-size))) | |
1454 | (:ref | |
1455 | (n description arg) | |
1456 | (do ((size (defstruct-description-size)) | |
1457 | (a arg) | |
1458 | (tem)) | |
1459 | (()) | |
1460 | (cond ((= size 1) (return a)) | |
1461 | ((< n (setq tem (// size 2))) | |
1462 | (setq a `(car ,a)) | |
1463 | (setq size tem)) | |
1464 | (t (setq a `(cdr ,a)) | |
1465 | (setq size (- size tem)) | |
1466 | (setq n (- n tem)))))) | |
1467 | (:defstruct (description) | |
1468 | (and (defstruct-description-include) | |
1469 | (defstruct-error | |
1470 | "Structure of type tree cannot include another" | |
1471 | (defstruct-description-name))) | |
1472 | nil)) | |
1473 | ||
1474 | (defun make-tree-for-defstruct (arg size) | |
1475 | (cond ((= size 1) (car arg)) | |
1476 | ((= size 2) `(cons ,(car arg) ,(cadr arg))) | |
1477 | (t (do ((a (cdr arg) (cdr a)) | |
1478 | (m (// size 2)) | |
1479 | (n (1- (// size 2)) (1- n))) | |
1480 | ((zerop n) | |
1481 | `(cons ,(make-tree-for-defstruct arg m) | |
1482 | ,(make-tree-for-defstruct a (- size m)))))))) | |
1483 | ||
1484 | (defstruct-define-type :fixnum | |
1485 | (:cons | |
1486 | (arg description etc) :list | |
1487 | etc ;ignored | |
1488 | (and (or (null arg) | |
1489 | (not (null (cdr arg)))) | |
1490 | (defstruct-error | |
1491 | "Structure of type fixnum must have exactly 1 slot to be constructable" | |
1492 | (defstruct-description-name))) | |
1493 | (car arg)) | |
1494 | (:ref | |
1495 | (n description arg) | |
1496 | n ;ignored | |
1497 | description ;ignored | |
1498 | arg)) | |
1499 | \f | |
1500 | #+Multics | |
1501 | (defprop :external-ptr t :defstruct-option) | |
1502 | ||
1503 | #+Multics | |
1504 | (defstruct-define-type :external | |
1505 | (:keywords :external-ptr) | |
1506 | (:cons (arg description etc) :alist | |
1507 | (let ((ptr (cdr (or (assq ':external-ptr etc) | |
1508 | (assq ':external-ptr | |
1509 | (defstruct-description-property-alist)) | |
1510 | (defstruct-error | |
1511 | "No pointer given for external array" | |
1512 | (defstruct-description-name)))))) | |
1513 | (do ((creator `(array nil external ,ptr ,(defstruct-description-size))) | |
1514 | (var (gensym)) | |
1515 | (alist arg (cdr alist)) | |
1516 | (inits nil (cons `(store (arraycall fixnum ,var ,(caar alist)) | |
1517 | ,(cdar alist)) | |
1518 | inits))) | |
1519 | ((null alist) | |
1520 | (if (null inits) | |
1521 | creator | |
1522 | `((lambda (,var) ,.inits ,var) | |
1523 | ,creator)))))) | |
1524 | (:ref (n description arg) | |
1525 | description ;ignored | |
1526 | `(arraycall fixnum ,arg ,n))) | |
1527 | \f | |
1528 | (defvar *defstruct-examine&deposit-arg*) | |
1529 | ||
1530 | (defun defstruct-examine (*defstruct-examine&deposit-arg* | |
1531 | name slot-name) | |
1532 | (eval (list (defstruct-slot-description-ref-macro-name | |
1533 | (defstruct-examine&deposit-find-slot-description | |
1534 | name slot-name)) | |
1535 | '*defstruct-examine&deposit-arg*))) | |
1536 | ||
1537 | (defvar *defstruct-examine&deposit-val*) | |
1538 | ||
1539 | (defun defstruct-deposit (*defstruct-examine&deposit-val* | |
1540 | *defstruct-examine&deposit-arg* | |
1541 | name slot-name) | |
1542 | (eval (list 'setf | |
1543 | (list (defstruct-slot-description-ref-macro-name | |
1544 | (defstruct-examine&deposit-find-slot-description | |
1545 | name slot-name)) | |
1546 | '*defstruct-examine&deposit-arg*) | |
1547 | '*defstruct-examine&deposit-val*))) | |
1548 | ||
1549 | #Q | |
1550 | (defun defstruct-get-locative (*defstruct-examine&deposit-arg* | |
1551 | name slot-name) | |
1552 | (let ((slot-description (defstruct-examine&deposit-find-slot-description | |
1553 | name slot-name))) | |
1554 | (or (null (defstruct-slot-description-ppss)) | |
1555 | (defstruct-error | |
1556 | "You cannot get a locative to a byte field" | |
1557 | slot-name 'in name)) | |
1558 | (eval (list 'locf | |
1559 | (list (defstruct-slot-description-ref-macro-name) | |
1560 | '*defstruct-examine&deposit-arg*))))) | |
1561 | ||
1562 | (defun defstruct-examine&deposit-find-slot-description (name slot-name) | |
1563 | (let ((description (get-defstruct-description name))) | |
1564 | (let ((slot-description | |
1565 | (cdr (or (assq slot-name (defstruct-description-slot-alist)) | |
1566 | (defstruct-error | |
1567 | "No such slot in this structure" | |
1568 | slot-name 'in name)))) | |
1569 | (type-description | |
1570 | (or (get (defstruct-description-type) 'defstruct-type-description) | |
1571 | (defstruct-error | |
1572 | "Undefined defstruct type" | |
1573 | (defstruct-description-type))))) | |
1574 | (or (= (defstruct-type-description-ref-no-args) 1) | |
1575 | (defstruct-error | |
1576 | "defstruct-examine and defstruct-deposit cannot handle structures of this type" | |
1577 | (defstruct-description-type))) | |
1578 | slot-description))) | |
1579 | \f | |
1580 | #+PDP10 | |
1581 | (defprop defstruct | |
1582 | #.(and (status feature PDP10) | |
1583 | (caddr (truename infile))) | |
1584 | version) | |
1585 | ||
1586 | (sstatus feature defstruct) |