(FILECREATED "25-Mar-86 12:11:18" {ERIS}<LISPCORE>CML>LAB>NEWDEFSTRUCT.;1
 33571  

      changes to:  (VARS NEWDEFSTRUCTCOMS)
                   (RECORDS DEFSTRUCT-SLOT-DESCRIPTION DEFSTRUCT-DESCRIPTION)
                   (PROPS (SYMBOL-FUNCTION SETFN)
                          (CDR SETFN)
                          (CAR SETFN))
                   (FNS SETF-CDR SETF-CAR DEFAULT-STRUCTURE-PRINT VECTOR-SUB-PREDICATE 
                        LIST-SUB-PREDICATE STRUCTURE-PREDICATE DEFINE-PREDICATE DEFINE-COPIER 
                        DEFINE-BOA-CONSTRUCTORS DEFINE-CONSTRUCTOR DEFINE-SETTERS DEFINE-ACCESSORS 
                        CONCAT-STUFF CONCAT-PNAMES* CONCAT-PNAMES PARSE-SLOT-DESCRIPTIONS 
                        PARSE-NAME-AND-OPTIONS PRINT-DEFSTRUCT-SLOT-DESCRIPTION DSD-NAME 
                        MAKE-DEFSTRUCT-SLOT-DESCRIPTION COPY-DEFSTRUCT-SLOT-DESCRIPTION 
                        DEFSTRUCT-SLOT-DESCRIPTION-P MAKE-DEFSTRUCT-DESCRIPTION 
                        COPY-DEFSTRUCT-DESCRIPTION DEFSTRUCT-DESCRIPTION-P))


(PRETTYCOMPRINT NEWDEFSTRUCTCOMS)

(RPAQQ NEWDEFSTRUCTCOMS
 
       ((RECORDS DEFSTRUCT-DESCRIPTION DEFSTRUCT-SLOT-DESCRIPTION)
        (PROP SETFN CAR CDR SYMBOL-FUNCTION)
        (FNS CONCAT-STUFF COPY-DEFSTRUCT-DESCRIPTION COPY-DEFSTRUCT-SLOT-DESCRIPTION 
             DEFAULT-STRUCTURE-PRINT DEFSTRUCT-DESCRIPTION-P DEFSTRUCT-SLOT-DESCRIPTION-P DSD-NAME 
             DEFINE-ACCESSORS CONCAT-PNAMES CONCAT-PNAMES* DEFINE-BOA-CONSTRUCTORS DEFINE-CONSTRUCTOR 
             DEFINE-COPIER DEFINE-PREDICATE DEFINE-SETTERS LIST-SUB-PREDICATE 
             MAKE-DEFSTRUCT-DESCRIPTION MAKE-DEFSTRUCT-SLOT-DESCRIPTION PARSE-NAME-AND-OPTIONS 
             PARSE-SLOT-DESCRIPTIONS PRINT-DEFSTRUCT-SLOT-DESCRIPTION SETF-CAR SETF-CDR 
             STRUCTURE-PREDICATE VECTOR-SUB-PREDICATE)))
[DECLARE: EVAL@COMPILE 

(DATATYPE DEFSTRUCT-DESCRIPTION
 ((LENGTH POINTER)
                                 (OFFSET POINTER)
                                 (NAMED POINTER)
                                 (LISP-TYPE POINTER)
                                 (TYPE POINTER)
                                 (PRINT-FUNCTION POINTER)
                                 (INCLUDES POINTER)
                                 (INCLUDE POINTER)
                                 (PREDICATE POINTER)
                                 (COPIER POINTER)
                                 (BOA-CONSTRUCTORS POINTER)
                                 (CONSTRUCTOR POINTER)
                                 (CONC-NAME POINTER)
                                 (SLOTS POINTER)
                                 (DOC POINTER)
                                 (NAME POINTER)
                                 (ORIGINAL-FORM POINTER))
                                INCLUDES _ NIL)

(DATATYPE DEFSTRUCT-SLOT-DESCRIPTION
 ((READ-ONLY POINTER)
                                      (TYPE POINTER)
                                      (DEFAULT POINTER)
                                      (ACCESSOR POINTER)
                                      (INDEX POINTER)
                                      (%%NAME POINTER)))
]
(/DECLAREDATATYPE (QUOTE DEFSTRUCT-DESCRIPTION)
       (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
                     POINTER POINTER POINTER POINTER POINTER POINTER POINTER))
       (QUOTE ((DEFSTRUCT-DESCRIPTION 0 POINTER)
               (DEFSTRUCT-DESCRIPTION 2 POINTER)
               (DEFSTRUCT-DESCRIPTION 4 POINTER)
               (DEFSTRUCT-DESCRIPTION 6 POINTER)
               (DEFSTRUCT-DESCRIPTION 8 POINTER)
               (DEFSTRUCT-DESCRIPTION 10 POINTER)
               (DEFSTRUCT-DESCRIPTION 12 POINTER)
               (DEFSTRUCT-DESCRIPTION 14 POINTER)
               (DEFSTRUCT-DESCRIPTION 16 POINTER)
               (DEFSTRUCT-DESCRIPTION 18 POINTER)
               (DEFSTRUCT-DESCRIPTION 20 POINTER)
               (DEFSTRUCT-DESCRIPTION 22 POINTER)
               (DEFSTRUCT-DESCRIPTION 24 POINTER)
               (DEFSTRUCT-DESCRIPTION 26 POINTER)
               (DEFSTRUCT-DESCRIPTION 28 POINTER)
               (DEFSTRUCT-DESCRIPTION 30 POINTER)
               (DEFSTRUCT-DESCRIPTION 32 POINTER)))
       (QUOTE 34))
(/DECLAREDATATYPE (QUOTE DEFSTRUCT-SLOT-DESCRIPTION)
       (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER))
       (QUOTE ((DEFSTRUCT-SLOT-DESCRIPTION 0 POINTER)
               (DEFSTRUCT-SLOT-DESCRIPTION 2 POINTER)
               (DEFSTRUCT-SLOT-DESCRIPTION 4 POINTER)
               (DEFSTRUCT-SLOT-DESCRIPTION 6 POINTER)
               (DEFSTRUCT-SLOT-DESCRIPTION 8 POINTER)
               (DEFSTRUCT-SLOT-DESCRIPTION 10 POINTER)))
       (QUOTE 12))

(PUTPROPS CAR SETFN
 SETF-CAR)

(PUTPROPS CDR SETFN
 SETF-CDR)

(PUTPROPS SYMBOL-FUNCTION SETFN
 PUTD)
(DEFINEQ

(CONCAT-STUFF

  [CL:LAMBDA (THING1 THING2)
    (LET ((*PRINT-CASE* :UPCASE))
         (INTERN (CONCATENATE (QUOTE SIMPLE-STRING)
                        (PRINC-TO-STRING THING1)
                        (PRINC-TO-STRING THING2])

(COPY-DEFSTRUCT-DESCRIPTION

  (CL:LAMBDA (obj)
    (create
 DEFSTRUCT-DESCRIPTION using
 obj)))

(COPY-DEFSTRUCT-SLOT-DESCRIPTION

  (CL:LAMBDA (obj)
    (create
 DEFSTRUCT-SLOT-DESCRIPTION using
 obj)))

(DEFAULT-STRUCTURE-PRINT

  (CL:LAMBDA (STRUCTURE STREAM DEPTH)
    (CL:DECLARE (IGNORE DEPTH))
    (WRITE-STRING "#S(" STREAM)
    (PRIN1 (SVREF STRUCTURE 0)
           STREAM)
    (CL:DO ((INDEX 1 (1+ INDEX))
            (CL:LENGTH (CL:LENGTH STRUCTURE))
            (SLOTS (DD-SLOTS (GET (SVREF STRUCTURE 0)
                                  (QUOTE %%STRUCTURE-DEFINITION)))
                   (CDR SLOTS)))
           ((OR (= INDEX CL:LENGTH)
                (AND *PRINT-LENGTH* (= INDEX *PRINT-LENGTH*)))
            (CL:IF (= INDEX CL:LENGTH)
                   (WRITE-STRING ")" STREAM)
                   (WRITE-STRING "...)" STREAM)))
           (WRITE-CHAR |\SPACE STREAM)
           (PRIN1 (DSD-NAME
 (CAR SLOTS))
                  STREAM)
           (WRITE-CHAR |\SPACE STREAM)
           (PRIN1 (SVREF STRUCTURE INDEX)
                  STREAM))))

(DEFSTRUCT-DESCRIPTION-P

  (CL:LAMBDA (obj)
    (type?
 DEFSTRUCT-DESCRIPTION obj)))

(DEFSTRUCT-SLOT-DESCRIPTION-P

  (CL:LAMBDA (obj)
    (type?
 DEFSTRUCT-SLOT-DESCRIPTION obj)))

(DSD-NAME

  [CL:LAMBDA (DSD)
    (INTERN (STRING (DSD-%%NAME DSD))
           (SYMBOL-PACKAGE (DSD-ACCESSOR DSD])

(DEFINE-ACCESSORS

  [CL:LAMBDA (DEFSTRUCT)
    (CL:DO
     ((SLOTS (DD-SLOTS DEFSTRUCT)
             (CDR SLOTS))
      (STUFF (QUOTE NIL))
      (TYPE (DD-LISP-TYPE DEFSTRUCT)))
     ((NULL SLOTS)
      STUFF)
     (LET* ((SLOT (CAR SLOTS))
            (NAME (DSD-ACCESSOR SLOT))
            (INDEX (DSD-INDEX SLOT)))
           (CL:PUSH
            [CL:IF (AND (EQ TYPE (QUOTE SIMPLE-VECTOR))
                        (< INDEX NUMBER-OF-BUILT-IN-SLOT-FROBBERS))
                   [BQUOTE (PROGN [SETF (SYMBOL-FUNCTION (QUOTE (\, NAME)))
                                        (SYMBOL-FUNCTION (QUOTE (\, (SVREF BUILT-IN-ACCESSORS INDEX]
                                  (EVAL-WHEN (CL:COMPILE LOAD EVAL)
                                         (SETF (GET (QUOTE (\, NAME))
                                                    (QUOTE COMPILER::CLC-TRANSFORMS))
                                               (QUOTE ((\, (SVREF BUILT-IN-X-ACCESSORS INDEX]
                   (BQUOTE (PROGN (DEFUN (\, NAME)
                                         (STRUCTURE)
                                         (CL:ELT (THE (\, TYPE)
                                                      STRUCTURE)
                                                (\, INDEX)))
                                  (EVAL-WHEN (CL:COMPILE LOAD EVAL)
                                         (COMPILER::DEFTRANSFORM
                                          (\, NAME)
                                          (\, (CONCAT-PNAMES*
 (QUOTE X-)
                                                     NAME))
                                          (STRUCTURE)
                                          (BQUOTE (CL:ELT (THE (\, (QUOTE (\, TYPE)))
                                                               (\, STRUCTURE))
                                                         (\, (QUOTE (\, INDEX]
            STUFF])

(CONCAT-PNAMES

  (CL:LAMBDA (NAME1 NAME2)
    (CL:IF NAME1 (INTERN (CONCATENATE (QUOTE SIMPLE-STRING)
                                (SYMBOL-NAME NAME1)
                                (SYMBOL-NAME NAME2)))
           NAME2)))

(CONCAT-PNAMES*

  (CL:LAMBDA (NAME1 NAME2)
    (CL:IF NAME1 (MAKE-SYMBOL (CONCATENATE (QUOTE SIMPLE-STRING)
                                     (SYMBOL-NAME NAME1)
                                     (SYMBOL-NAME NAME2)))
           NAME2)))

(DEFINE-BOA-CONSTRUCTORS

  [CL:LAMBDA (DEFSTRUCT)
    (CL:DO*
     ((BOAS (DD-BOA-CONSTRUCTORS DEFSTRUCT)
            (CDR BOAS))
      (NAME (CAR (CAR BOAS))
            (CAR (CAR BOAS)))
      [ARGS (COPY-LIST (CADR (CAR BOAS)))
            (COPY-LIST (CADR (CAR BOAS]
      (SLOTS (DD-SLOTS DEFSTRUCT)
             (DD-SLOTS DEFSTRUCT))
      (SLOTS-IN-ARGLIST (QUOTE NIL)
             (QUOTE NIL))
      (DEFUNS (QUOTE NIL)))
     ((NULL BOAS)
      DEFUNS)
     [CL:DO ((ARGS ARGS (CDR ARGS))
             (ARG-KIND (QUOTE REQUIRED)))
            ((NULL ARGS))
            (LET ((ARG (CAR ARGS)))
                 (CL:IF (CL:ATOM ARG)
                        [CL:IF (MEMQ ARG (QUOTE (&OPTIONAL &REST &AUX)))
                               (CL:SETQ ARG-KIND ARG)
                               (CASE ARG-KIND ((REQUIRED &REST &AUX)
                                               (CL:PUSH ARG SLOTS-IN-ARGLIST))
                                     (&OPTIONAL (CL:PUSH ARG SLOTS-IN-ARGLIST)
                                            (RPLACA ARGS (LIST ARG
                                                               (DSD-DEFAULT
                                                                (CL:FIND ARG SLOTS :KEY
                                                                       (FUNCTION DSD-NAME]
                        (CL:PUSH (CAR ARG)
                               SLOTS-IN-ARGLIST]
     (LET ((INITIAL-CRUFT (MAKE-LIST (DD-OFFSET DEFSTRUCT)))
           (THING (CL:MAPCAR [FUNCTION (CL:LAMBDA (SLOT)
                                         (CL:IF (MEMQ (DSD-NAME
 SLOT)
                                                      SLOTS-IN-ARGLIST)
                                                (DSD-NAME
 SLOT)
                                                (DSD-DEFAULT SLOT]
                         SLOTS)))
          (CL:PUSH
           [BQUOTE
            (DEFUN
             (\, NAME)
             (\, ARGS)
             (\,
              (CL:IF
               (EQ (DD-TYPE DEFSTRUCT)
                   (QUOTE LIST))
               (BQUOTE (LIST [\,@(CL:IF (DD-NAMED DEFSTRUCT)
                                        (BQUOTE ((QUOTE (\, (DD-NAME DEFSTRUCT]
                             (\,@ INITIAL-CRUFT)
                             (\,@ THING)))
               (CL:IF (DD-NAMED DEFSTRUCT)
                      [BQUOTE (STRUCTURIFY (VECTOR (QUOTE (\, (DD-NAME DEFSTRUCT)))
                                                  (\,@ INITIAL-CRUFT)
                                                  (\,@ THING]
                      (CL:IF (EQ (DD-TYPE DEFSTRUCT)
                                 (QUOTE VECTOR))
                             (BQUOTE (VECTOR (\,@ INITIAL-CRUFT)
                                            (\,@ THING)))
                             (CL:DO ((THINGS THING (CDR THINGS))
                                     (INDEX 0 (1+ INDEX))
                                     (SETS (QUOTE NIL))
                                     (TEMP (GENSYM)))
                                    [(NULL THINGS)
                                     (BQUOTE (LET [((\, TEMP)
                                                    (MAKE-ARRAY (\, (DD-LENGTH DEFSTRUCT))
                                                           :ELEMENT-TYPE
                                                           (QUOTE (\, (CADR (DD-LISP-TYPE DEFSTRUCT]
                                                  (\,@ SETS)
                                                  (\, TEMP]
                                    (CL:PUSH [BQUOTE (SETF (AREF (\, TEMP)
                                                                 INDEX)
                                                           (\, (CAR THINGS]
                                           SETS]
           DEFUNS])

(DEFINE-CONSTRUCTOR

  [CL:LAMBDA (DEFSTRUCT)
    (LET ((NAME (DD-CONSTRUCTOR DEFSTRUCT)))
         (CL:WHEN
          NAME
          (LET* ((INITIAL-CRUFT (MAKE-LIST (DD-OFFSET DEFSTRUCT)))
                 (SLOTS (DD-SLOTS DEFSTRUCT))
                 (ARG-NAMES (CL:MAPCAR (FUNCTION DSD-NAME)
                                   SLOTS))
                 (ARGS (CL:MAPCAR [FUNCTION (CL:LAMBDA (SLOT)
                                              (BQUOTE ((\, (DSD-NAME
 SLOT))
                                                       (\, (DSD-DEFAULT SLOT]
                              SLOTS)))
                (BQUOTE
                 ((DEFUN
                   (\, NAME)
                   (&KEY (\,@ ARGS))
                   (\,
                    (CL:IF
                     (EQ (DD-TYPE DEFSTRUCT)
                         (QUOTE LIST))
                     (BQUOTE (LIST [\,@(CL:IF (DD-NAMED DEFSTRUCT)
                                              (BQUOTE ((QUOTE (\, (DD-NAME DEFSTRUCT]
                                   (\,@ INITIAL-CRUFT)
                                   (\,@ ARG-NAMES)))
                     (CL:IF
                      (DD-NAMED DEFSTRUCT)
                      [BQUOTE (STRUCTURIFY (VECTOR (QUOTE (\, (DD-NAME DEFSTRUCT)))
                                                  (\,@ INITIAL-CRUFT)
                                                  (\,@ ARG-NAMES]
                      (CL:IF (EQ (DD-TYPE DEFSTRUCT)
                                 (QUOTE VECTOR))
                             (BQUOTE (VECTOR (\,@ INITIAL-CRUFT)
                                            (\,@ ARG-NAMES)))
                             (CL:DO ((SLUTS SLOTS (CDR SLUTS))
                                     (SETS (QUOTE NIL))
                                     (TEMP (GENSYM)))
                                    [(NULL SLUTS)
                                     (BQUOTE (LET [((\, TEMP)
                                                    (MAKE-ARRAY (\, (DD-LENGTH DEFSTRUCT))
                                                           :ELEMENT-TYPE
                                                           (QUOTE (\, (CADR (DD-LISP-TYPE DEFSTRUCT]
                                                  (\,@ SETS)
                                                  (\, TEMP]
                                    (LET ((SLOT (CAR SLUTS)))
                                         (CL:PUSH [BQUOTE (SETF (AREF (\, TEMP)
                                                                      (\, (DSD-INDEX SLOT)))
                                                                (\, (DSD-NAME
 SLOT]
                                                SETS])

(DEFINE-COPIER

  [CL:LAMBDA (DEFSTRUCT)
    (CL:IF (DD-COPIER DEFSTRUCT)
           (COND
              [(AND (EQ (DD-LISP-TYPE DEFSTRUCT)
                        (QUOTE SIMPLE-VECTOR))
                    (DD-NAMED DEFSTRUCT))
               (BQUOTE ((SETF [SYMBOL-FUNCTION (QUOTE (\, (DD-COPIER DEFSTRUCT]
                              (SYMBOL-FUNCTION (QUOTE BUILT-IN-COPIER]
              [(EQ (DD-LISP-TYPE DEFSTRUCT)
                   (QUOTE LIST))
               (BQUOTE ((SETF [SYMBOL-FUNCTION (QUOTE (\, (DD-COPIER DEFSTRUCT]
                              (SYMBOL-FUNCTION (QUOTE COPY-LIST]
              (T (BQUOTE ((DEFUN (\, (DD-COPIER DEFSTRUCT))
                                 (STRUCTURE)
                                 (COPY-SEQ (THE (\, (DD-LISP-TYPE DEFSTRUCT))
                                                STRUCTURE])

(DEFINE-PREDICATE

  [CL:LAMBDA (DEFSTRUCT)
    (LET ((NAME (DD-NAME DEFSTRUCT))
          (PRED (DD-PREDICATE DEFSTRUCT)))
         (CL:WHEN (AND PRED (DD-NAMED DEFSTRUCT))
                (BQUOTE ([PROCLAIM (QUOTE (INLINE (\, PRED]
                         (DEFUN (\, PRED)
                                (OBJECT)
                                (TYPEP OBJECT (QUOTE (\, NAME])

(DEFINE-SETTERS

  [CL:LAMBDA (DEFSTRUCT)
    (CL:DO
     ((SLOTS (DD-SLOTS DEFSTRUCT)
             (CDR SLOTS))
      (STUFF (QUOTE NIL))
      (TYPE (DD-LISP-TYPE DEFSTRUCT)))
     ((NULL SLOTS)
      STUFF)
     (LET* ((SLOT (CAR SLOTS))
            (NAME (CONCAT-PNAMES*
 (QUOTE SET-)
                         (DSD-ACCESSOR SLOT)))
            (INDEX (DSD-INDEX SLOT)))
           (CL:UNLESS
            (DSD-READ-ONLY SLOT)
            (CL:PUSH
             [CL:IF
              (AND (EQ TYPE (QUOTE SIMPLE-VECTOR))
                   (< INDEX NUMBER-OF-BUILT-IN-SLOT-FROBBERS))
              [BQUOTE (DEFSETF (\, (DSD-ACCESSOR SLOT))
                             (\, (SVREF BUILT-IN-SETTERS INDEX]
              (BQUOTE (PROGN (DEFUN (\, NAME)
                                    (STRUCTURE NEW-VALUE)
                                    (SETF (CL:ELT (THE (\, TYPE)
                                                       STRUCTURE)
                                                 (\, INDEX))
                                          NEW-VALUE))
                             [EVAL-WHEN (CL:COMPILE LOAD EVAL)
                                    (COMPILER::DEFTRANSFORM
                                     (\, NAME)
                                     (\, (CONCAT-PNAMES*
 (QUOTE X-)
                                                NAME))
                                     (STRUCTURE NEW-VALUE)
                                     (BQUOTE (SETF [CL:ELT (THE (\, (QUOTE (\, TYPE)))
                                                                (\, STRUCTURE))
                                                          (\, (QUOTE (\, INDEX]
                                                   (\, NEW-VALUE]
                             (DEFSETF (\, (DSD-ACCESSOR SLOT))
                                    (\, NAME]
             STUFF])

(LIST-SUB-PREDICATE

  [CL:LAMBDA (OBJECT TYPE)
    (LET ((OBJ-NAME (CAR OBJECT)))
         (AND (SYMBOLP OBJ-NAME)
              (LET [(DD (GET OBJ-NAME (QUOTE %%STRUCTURE-DEFINITION]
                   (AND DD (NOT (NULL (MEMQ TYPE (DD-INCLUDES DD])

(MAKE-DEFSTRUCT-DESCRIPTION

  (CL:LAMBDA (&KEY NAME DOC SLOTS CONC-NAME CONSTRUCTOR BOA-CONSTRUCTORS COPIER PREDICATE INCLUDE
                   (INCLUDES NIL)
                   PRINT-FUNCTION TYPE LISP-TYPE NAMED OFFSET LENGTH ORIGINAL-FORM)

                                                                           (* gbn 
                                                                           "13-Mar-86 16:16")

    (create
 DEFSTRUCT-DESCRIPTION
           LENGTH _ LENGTH
           OFFSET _ OFFSET
           NAMED _ NAMED
           LISP-TYPE _ LISP-TYPE
           TYPE _ TYPE
           PRINT-FUNCTION _ PRINT-FUNCTION
           INCLUDES _ INCLUDES
           INCLUDE _ INCLUDE
           PREDICATE _ PREDICATE
           COPIER _ COPIER
           BOA-CONSTRUCTORS _ BOA-CONSTRUCTORS
           CONSTRUCTOR _ CONSTRUCTOR
           CONC-NAME _ CONC-NAME
           SLOTS _ SLOTS
           DOC _ DOC
           NAME _ NAME
           ORIGINAL-FORM _ ORIGINAL-FORM)))

(MAKE-DEFSTRUCT-SLOT-DESCRIPTION

  (CL:LAMBDA (&KEY %%NAME INDEX ACCESSOR DEFAULT TYPE READ-ONLY)
    (create
 DEFSTRUCT-SLOT-DESCRIPTION
           READ-ONLY _ READ-ONLY
           TYPE _ TYPE
           DEFAULT _ DEFAULT
           ACCESSOR _ ACCESSOR
           INDEX _ INDEX
           %%NAME _ %%NAME)))

(PARSE-NAME-AND-OPTIONS

  [CL:LAMBDA (NAME-AND-OPTIONS ORIGINAL-FORM)
                              (* gbn 
                                                                           "13-Mar-86 16:13")

    (CL:IF (CL:ATOM NAME-AND-OPTIONS)
           (CL:SETQ NAME-AND-OPTIONS (LIST NAME-AND-OPTIONS)))
    (CL:DO* ((OPTIONS (CDR NAME-AND-OPTIONS)
                    (CDR OPTIONS))
             (NAME (CAR NAME-AND-OPTIONS))
             (PRINT-FUNCTION (QUOTE DEFAULT-STRUCTURE-PRINT))
             (CONC-NAME (CONCAT-PNAMES
 NAME (QUOTE -
)))
             (CONSTRUCTOR (CONCAT-PNAMES
 (QUOTE MAKE-)
                                 NAME))
             (SAW-CONSTRUCTOR)
             (BOA-CONSTRUCTORS (QUOTE NIL))
             (COPIER (CONCAT-PNAMES
 (QUOTE COPY-)
                            NAME))
             (PREDICATE (CONCAT-PNAMES
 NAME (QUOTE -P)))
             (INCLUDE)
             (SAW-TYPE)
             (TYPE (QUOTE VECTOR))
             (SAW-NAMED)
             (OFFSET 0))
           ((NULL OPTIONS)
            (MAKE-DEFSTRUCT-DESCRIPTION
 :NAME NAME :ORIGINAL-FORM ORIGINAL-FORM :CONC-NAME CONC-NAME 
                   :CONSTRUCTOR CONSTRUCTOR :BOA-CONSTRUCTORS BOA-CONSTRUCTORS :COPIER COPIER 
                   :PREDICATE PREDICATE :INCLUDE INCLUDE :PRINT-FUNCTION PRINT-FUNCTION :TYPE TYPE 
                   :LISP-TYPE (COND
                                 ((EQ TYPE (QUOTE VECTOR))
                                  (QUOTE SIMPLE-VECTOR))
                                 ((EQ TYPE (QUOTE LIST))
                                  (QUOTE LIST))
                                 ((AND (CL:LISTP TYPE)
                                       (EQ (CAR TYPE)
                                           (QUOTE VECTOR)))
                                  (CONS (QUOTE SIMPLE-ARRAY)
                                        (CDR TYPE)))
                                 (T (CL:ERROR "~S is a bad :TYPE for Defstruct." TYPE)))
                   :NAMED
                   (CL:IF SAW-TYPE SAW-NAMED T)
                   :OFFSET OFFSET))
           (CL:IF (CL:ATOM (CAR OPTIONS))
                  [CASE (CAR OPTIONS)
                        (:CONSTRUCTOR (CL:SETQ SAW-CONSTRUCTOR T CONSTRUCTOR (CONCAT-PNAMES

                                                                              (QUOTE MAKE-)
                                                                              NAME)))
                        (:COPIER)
                        (:PREDICATE)
                        (:NAMED (CL:SETQ SAW-NAMED T))
                        (T (CL:ERROR "The Defstruct option ~S cannot be used with 0 arguments."
                                  (CAR OPTIONS]
                  (LET ((OPTION (CAAR OPTIONS))
                        (ARGS (CDAR OPTIONS)))
                       (CASE OPTION (:CONC-NAME (CL:SETQ CONC-NAME (CAR ARGS)))
                             [:CONSTRUCTOR (COND
                                              ((CDR ARGS)
                                               (CL:UNLESS SAW-CONSTRUCTOR (CL:SETQ CONSTRUCTOR NIL))
                                               (CL:PUSH ARGS BOA-CONSTRUCTORS))
                                              (T (CL:SETQ CONSTRUCTOR (CAR ARGS]
                             (:COPIER (CL:SETQ COPIER (CAR ARGS)))
                             (:PREDICATE (CL:SETQ PREDICATE (CAR ARGS)))
                             (:INCLUDE (CL:SETQ INCLUDE ARGS))
                             (:PRINT-FUNCTION (CL:SETQ PRINT-FUNCTION (CAR ARGS)))
                             (:TYPE (CL:SETQ SAW-TYPE T TYPE (CAR ARGS)))
                             (:NAMED (CL:ERROR "The Defstruct option :NAMED takes no arguments."))
                             (:INITIAL-OFFSET (CL:SETQ OFFSET (CAR ARGS)))
                             (T (CL:ERROR "~S is an unknown Defstruct option." OPTION])

(PARSE-SLOT-DESCRIPTIONS

  [CL:LAMBDA (DEFSTRUCT SLOTS)
    (CL:WHEN (STRINGP (CAR SLOTS))
           (SETF (DD-DOC DEFSTRUCT)
                 (CAR SLOTS))
           (CL:SETQ SLOTS (CDR SLOTS)))
    [CL:WHEN (DD-INCLUDE DEFSTRUCT)
           (LET* [(INCLUDED-NAME (CAR (DD-INCLUDE DEFSTRUCT)))
                  [INCLUDED-THING (OR (GET INCLUDED-NAME (QUOTE %%STRUCTURE-DEFINITION-IN-COMPILER))
                                      (GET INCLUDED-NAME (QUOTE %%STRUCTURE-DEFINITION]
                  (MODIFIED-SLOTS (CDR (DD-INCLUDE DEFSTRUCT]
                 (CL:UNLESS INCLUDED-THING (CL:ERROR 
                                      "Cannot find description of structure ~S to use for inclusion." 
                                                  INCLUDED-NAME))
                 (SETF (DD-INCLUDES DEFSTRUCT)
                       (CONS (DD-NAME INCLUDED-THING)
                             (DD-INCLUDES INCLUDED-THING)))
                 (SETF (DD-OFFSET DEFSTRUCT)
                       (DD-OFFSET INCLUDED-THING))
                 (CL:DO* ((ISLOTS (CL:MAPCAR [FUNCTION (CL:LAMBDA (SLOT)
                                                         (BQUOTE ((\, (DSD-NAME
 SLOT))
                                                                  (\, (DSD-DEFAULT SLOT))
                                                                  :TYPE
                                                                  (\, (DSD-TYPE SLOT))
                                                                  :READ-ONLY
                                                                  (\, (DSD-READ-ONLY SLOT]
                                         (DD-SLOTS INCLUDED-THING)))
                          (ISLOTS* ISLOTS (CDR ISLOTS*)))
                        ((NULL ISLOTS*)
                         (CL:SETQ SLOTS (NCONC ISLOTS SLOTS)))
                        (LET* [(ISLOT (CAR ISLOTS*))
                               (MODIFIEE (CL:FIND (CAR ISLOT)
                                                MODIFIED-SLOTS :KEY [FUNCTION (CL:LAMBDA (X)
                                                                                (CL:IF (CL:ATOM
                                                                                        X)
                                                                                       X
                                                                                       (CAR X]
                                                :TEST
                                                (FUNCTION STRING=]
                              (CL:WHEN MODIFIEE
                                     (COND
                                        ((SYMBOLP MODIFIEE)
                                         (SETF (CADR ISLOT)
                                               NIL))
                                        ((CL:LISTP MODIFIEE)
                                         (SETF (CADR ISLOT)
                                               (CADR MODIFIEE))
                                         (CL:WHEN (CDDR MODIFIEE)
                                                (CL:DO ((OPTIONS (CDDR MODIFIEE)
                                                               (CDDR OPTIONS)))
                                                       ((NULL OPTIONS))
                                                       (CASE (CAR OPTIONS)
                                                             (:TYPE (SETF (CADDDR ISLOT)
                                                                          (CADR OPTIONS)))
                                                             (:READ-ONLY (SETF (CADR (CDDDDR ISLOT))
                                                                               (CADR OPTIONS)))
                                                             (T (CL:ERROR 
                                                              "Bad option in included slot spec: ~S."
                                                                       (CAR OPTIONS]
    (CL:DO ((SLOTS SLOTS (CDR SLOTS))
            (INDEX (+ (DD-OFFSET DEFSTRUCT)
                      (CL:IF (DD-NAMED DEFSTRUCT)
                             1 0))
                   (1+ INDEX))
            (DESCRIPTIONS (QUOTE NIL)))
           ((NULL SLOTS)
            (SETF (DD-LENGTH DEFSTRUCT)
                  INDEX)
            (SETF (DD-SLOTS DEFSTRUCT)
                  (CL:NREVERSE DESCRIPTIONS)))
           (LET ((SLOT (CAR SLOTS)))
                (CL:PUSH [CL:IF (CL:ATOM SLOT)
                                (LET ((NAME SLOT))
                                     (MAKE-DEFSTRUCT-SLOT-DESCRIPTION
 :%%NAME (STRING NAME)
                                            :INDEX INDEX :ACCESSOR (CONCAT-PNAMES
 (DD-CONC-NAME
                                                                                   DEFSTRUCT)
                                                                          NAME)
                                            :TYPE T))
                                (CL:DO ((OPTIONS (CDDR SLOT)
                                               (CDDR OPTIONS))
                                        (NAME (CAR SLOT))
                                        (DEFAULT (CADR SLOT))
                                        (TYPE T)
                                        (READ-ONLY NIL))
                                       ((NULL OPTIONS)
                                        (MAKE-DEFSTRUCT-SLOT-DESCRIPTION
 :%%NAME (STRING NAME)
                                               :INDEX INDEX :ACCESSOR (CONCAT-PNAMES
 (DD-CONC-NAME
                                                                                      DEFSTRUCT)
                                                                             NAME)
                                               :DEFAULT DEFAULT :TYPE TYPE :READ-ONLY READ-ONLY))
                                       (CASE (CAR OPTIONS)
                                             (:TYPE (CL:SETQ TYPE (CADR OPTIONS)))
                                             (:READ-ONLY (CL:SETQ READ-ONLY (CADR OPTIONS]
                       DESCRIPTIONS])

(PRINT-DEFSTRUCT-SLOT-DESCRIPTION

  (CL:LAMBDA (STRUCTURE STREAM DEPTH)
    (CL:DECLARE (IGNORE DEPTH))
    (FORMAT STREAM "#<Defstruct-Slot-Description for ~S>" (DSD-NAME
 STRUCTURE))))

(SETF-CAR

  [LAMBDA (X Y)
                                                            (* gbn 
                                                                           "13-Mar-86 15:55")

    (RPLACA X Y)
    Y])

(SETF-CDR

  [LAMBDA (X Y)
                                                            (* gbn 
                                                                           "13-Mar-86 15:55")

    (RPLACD X Y)
    Y])

(STRUCTURE-PREDICATE

  [CL:LAMBDA (OBJECT TYPE)
    (LET [(DEF (OR (GET TYPE (QUOTE %%STRUCTURE-DEFINITION-IN-COMPILER))
                   (GET TYPE (QUOTE %%STRUCTURE-DEFINITION]
         (CL:IF DEF [CL:IF (EQ (DD-TYPE DEF)
                               (QUOTE LIST))
                           [BQUOTE (AND (CL:LISTP (\, OBJECT))
                                        (OR (EQ (CAR (\, OBJECT))
                                                (QUOTE (\, TYPE)))
                                            (LIST-SUB-PREDICATE
 (\, OBJECT)
                                                   (QUOTE (\, TYPE]
                           (BQUOTE (AND (SIMPLE-VECTOR-P (\, OBJECT))
                                        (TEST-STRUCTURE (\, OBJECT))
                                        (OR (EQ (SVREF (\, OBJECT)
                                                       0)
                                                (QUOTE (\, TYPE)))
                                            (VECTOR-SUB-PREDICATE
 (\, OBJECT)
                                                   (QUOTE (\, TYPE]
                (BQUOTE (STRUCTURE-TYPEP (\, OBJECT)
                               (QUOTE (\, TYPE])

(VECTOR-SUB-PREDICATE

  [CL:LAMBDA (OBJECT TYPE)
    (NOT (NULL (MEMQ TYPE (DD-INCLUDES (GET (SVREF OBJECT 0)
                                            (QUOTE %%STRUCTURE-DEFINITION])
)
(PRETTYCOMPRINT NEWDEFSTRUCTCOMS)

(RPAQQ NEWDEFSTRUCTCOMS
 
       [(RECORDS DEFSTRUCT-DESCRIPTION DEFSTRUCT-SLOT-DESCRIPTION)
        (PROP SETFN CAR CDR SYMBOL-FUNCTION)
        (FNS CONCAT-STUFF COPY-DEFSTRUCT-DESCRIPTION COPY-DEFSTRUCT-SLOT-DESCRIPTION 
             DEFAULT-STRUCTURE-PRINT DEFSTRUCT-DESCRIPTION-P DEFSTRUCT-SLOT-DESCRIPTION-P DSD-NAME 
             DEFINE-ACCESSORS CONCAT-PNAMES CONCAT-PNAMES* DEFINE-BOA-CONSTRUCTORS DEFINE-CONSTRUCTOR 
             DEFINE-COPIER DEFINE-PREDICATE DEFINE-SETTERS LIST-SUB-PREDICATE 
             MAKE-DEFSTRUCT-DESCRIPTION MAKE-DEFSTRUCT-SLOT-DESCRIPTION PARSE-NAME-AND-OPTIONS 
             PARSE-SLOT-DESCRIPTIONS PRINT-DEFSTRUCT-SLOT-DESCRIPTION SETF-CAR SETF-CDR 
             STRUCTURE-PREDICATE VECTOR-SUB-PREDICATE)
        (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                            (NLAML)
                                                                            (LAMA 
                                                                      MAKE-DEFSTRUCT-SLOT-DESCRIPTION 
                                                                           MAKE-DEFSTRUCT-DESCRIPTION
                                                                                  ])
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 MAKE-DEFSTRUCT-SLOT-DESCRIPTION MAKE-DEFSTRUCT-DESCRIPTION)
)
(DECLARE: DONTCOPY
  (FILEMAP (NIL (4805 32032 (CONCAT-STUFF 4815 . 5046) (COPY-DEFSTRUCT-DESCRIPTION 5048 . 5153) (
COPY-DEFSTRUCT-SLOT-DESCRIPTION 5155 . 5270) (DEFAULT-STRUCTURE-PRINT 5272 . 6138) (
DEFSTRUCT-DESCRIPTION-P 6140 . 6231) (DEFSTRUCT-SLOT-DESCRIPTION-P 6233 . 6334) (DSD-NAME 6336 . 6453)
 (DEFINE-ACCESSORS 6455 . 8350) (CONCAT-PNAMES 8352 . 8583) (CONCAT-PNAMES* 8585 . 8832) (
DEFINE-BOA-CONSTRUCTORS 8834 . 12632) (DEFINE-CONSTRUCTOR 12634 . 15313) (DEFINE-COPIER 15315 . 16162)
 (DEFINE-PREDICATE 16164 . 16547) (DEFINE-SETTERS 16549 . 18407) (LIST-SUB-PREDICATE 18409 . 18663) (
MAKE-DEFSTRUCT-DESCRIPTION 18665 . 19663) (MAKE-DEFSTRUCT-SLOT-DESCRIPTION 19665 . 19980) (
PARSE-NAME-AND-OPTIONS 19982 . 23857) (PARSE-SLOT-DESCRIPTIONS 23859 . 29991) (
PRINT-DEFSTRUCT-SLOT-DESCRIPTION 29993 . 30186) (SETF-CAR 30188 . 30411) (SETF-CDR 30413 . 30636) (
STRUCTURE-PREDICATE 30638 . 31839) (VECTOR-SUB-PREDICATE 31841 . 32030)))))
STOP