Return to struct.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib

Annotation of 42BSD/ucb/lisp/lisplib/struct.l, revision 1.1

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.