projects / unix-history / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
BSD 4_3_Net_2 release
[unix-history] / usr / src / usr.bin / lisp / lisplib / struct.l
CommitLineData
c3a1cbcf
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,
255it 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)
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.