![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to struct.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / lisplib|
Return to struct.l CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / lisplib |
1.1 root 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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
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:
1580: #+PDP10
1581: (defprop defstruct
1582: #.(and (status feature PDP10)
1583: (caddr (truename infile)))
1584: version)
1585:
1586: (sstatus feature defstruct)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.