perm filename RECORD.NEW[PAT,LMM] blob sn#077068 filedate 1973-12-12 generic text, type T, neo UTF8
(FILECREATED "12-DEC-73 22:12:28" RECORD.NEW

     changes to:  MYSUBST,FIELDSIN2,RECORDVARS,RECORD,HASHLINK,
RECORDECL,CHECKDEFAULT,ACCESSDEF,COMPOSE,FIXALIST1,RECORD1,
FIXUPDEC,FIELDDEFS,GETSETQ,RECCOMPOSE,CLISPRECORDTYPES,CREATEINFO
)


  (LISPXPRINT (QUOTE RECORDVARS)
              T)
  [RPAQQ
    RECORDVARS
    ((FNS RECORD PROPRECORD TYPERECORD HASHLINK)
     (FNS RECORD1 RECORDECL FIXUPDEC CHECKDEFAULT CREATEINFO 
          FIXALIST1 DWIMIFYREC COMPOSE GETSETQ FIELDDEFS 
          RECORDERROR)
     (FNS ADDGLOBVAR CLISPNOTRAN RECORDERROR)
     (FNS CLISPRECORD SETDEF ACCESSDEF GETLOCALDEC MYSUBST 
          RECLISPLOOKUP RECRESPELL REALATOM MAKERPLAC2)
     (FNS RECCOMPOSE0 RECORDWORD RECLOOK MAKEALIST RECCOMPOSE 
          SETPACK RECCOMPOSE1 EASYCOMPUTE 'CDR 'CAR RECCOMPOSE2)
     (FNS PUTL PUTLA PUTLD)
     (VARS CLISPRECORDTYPES CLISPRECORDWORDS CRLIST
           (RECORDSPLIST (LIST NIL))
           (CHANGEDRECLST NIL)
           (USERRECORDS NIL)
           (RECORDSUBSTFLG T)
           (ACCESSNOTRANFLG T))
     (P (SETQ NLAMA (APPEND CLISPRECORDTYPES NLAMA))
        (SETQ NOFIXFNSLST (APPEND CLISPRECORDTYPES NOFIXFNSLST)))
     (PROP CLISPWORD * CLISPRECORDWORDS)
     (PROP PRETTYTYPE RECORDS)
     [ADDVARS
       (PRETTYTYPELST (CHANGEDRECLST RECORDS "records"))
       (PRETTYMACROS
         (RECORDS
           X
           (PD
             *
             (MAPCAR
               (QUOTE X)
               (FUNCTION
                 (LAMBDA
                   (Z TEM)
                   (OR
                     (FMEMB [CAR (SETQ
                                   TEM
                                   (LISTP (GETP Z (QUOTE 
                                                 CLISPRECORD]
                            CLISPRECORDTYPES)
                     (ERROR Z "not a record"))
                   TEM]
     (BLOCKS (RECORDBLOCK (ENTRIES RECORD TYPERECORD PROPRECORD 
                                   CLISPRECORD RECCOMPOSE0 
                                   RECORDECL RECORDERROR RECORD1 
                                   HASHLINK CLISPNOTRAN)
                          RECORD PROPRECORD TYPERECORD HASHLINK 
                          RECORD1 RECORDECL FIXUPDEC 
                          CHECKDEFAULT FIXALIST1 DWIMIFYREC 
                          COMPOSE GETSETQ FIELDDEFS RECORDERROR 
                          ADDGLOBVAR CLISPNOTRAN RECORDERROR 
                          CLISPRECORD SETDEF ACCESSDEF 
                          GETLOCALDEC MYSUBST RECLISPLOOKUP 
                          RECRESPELL REALATOM MAKERPLAC2 
                          RECCOMPOSE0 RECORDWORD RECLOOK 
                          MAKEALIST RECCOMPOSE SETPACK 
                          RECCOMPOSE1 EASYCOMPUTE 'CDR 'CAR 
                          RECCOMPOSE2 PUTL PUTLA PUTLD
                          (SPECVARS VARS FAULTFN CLISPCHANGE 
                                    EXPR REDECLARELST)
                          (GLOBALVARS CRLIST RECORDSPLIST 
                                      CLISPRECORDWORDS 
                                      CLISPRECORDTYPES 
                                      RECORDSUBSTFLG 
                                      ACCESSNOTRANFLG 
                                      USERRECORDS CHANGEDRECLST)
                          (LOCALFREEVARS BLIP FIELD.ALIST 
                                         GETHASH.DECLARATION 
                                         USINGTYPE USING 
                                         RECORDECLARATION]
(DEFINEQ

(RECORD
  [NLAMBDA NAME&FIELDS

          (* All top level functions just create a form 
          which looks like what would appear in a local 
          declaration; and then put that form on the 
          property lists of the fields 
          (under CLISPRECORDFIELD) and under the name 
          (under CLISPRECORD); then the look up 
          functions can deal with the declaration in a 
          uniform way, whether or not it finds it in 
          the local declarations or on the properties)


    (RECORD1 (CONS (QUOTE RECORD)
                   NAME&FIELDS])

(PROPRECORD
  [NLAMBDA NAME&FIELDS
    (RECORD1 (CONS (QUOTE PROPRECORD)
                   NAME&FIELDS])

(TYPERECORD
  [NLAMBDA NAME&FIELDS
    (RECORD1 (CONS (QUOTE TYPERECORD)
                   NAME&FIELDS])

(HASHLINK
  [NLAMBDA NAME&FIELDS

          (* HASHLINK has to go thru A slight extra 
          hair so that it can set up the hash array)


    (PROG (ARRAYNAME TEM (DECL (CONS (QUOTE HASHLINK)
                                     NAME&FIELDS)))
          (SETQ TEM (RECORD1 DECL))
          [OR (NULL ARRAYNAME)
              [ARRAYP (CAR (SETQ ARRAYNAME (CADR (CADDR DECL]
              (AND (LISTP (CAR ARRAYNAME))
                   (ARRAYP (CAAR ARRAYNAME)))
              (SAVESET ARRAYNAME
                       (CONS (HARRAY (OR (CADDR (CADDR DECL))
                                         100]   (* ARRAYNAME = 
                                                NIL MEANS 
                                                SYSHASHARRAY)
          (RETURN TEM])
)
(DEFINEQ

(RECORD1
  [LAMBDA (DECL)

          (* This function does the work of the top 
          level RECORD declaration functions;
          the "NAME" of the RECORD must be 
          (CADR DECL); and the fields contained in it 
          must be (CAR (RECORDECL DECL)); other than 
          that, all of the translating information is 
          stored via RECORDECL; this just keeps track 
          of the PROPS and of those RECORD expressions 
          which have been changed 
          (notice the MAPHASH thru the CLISPARRAY at 
          the end))


    (PROG ((FAULTFN (QUOTE TYPE-IN?))
           VARS
           (EXPR DECL)
           GETHASH REDECLARELST TEM NAME)

          (* EXPR, VARS, and FAULTFN are rebound 
          because dwimifying the defaults with 
          DWIMIFY1B, which assumes them)


      RETRY
          (COND
            ([AND (NULL TEM)
                  (NULL (CDDR DECL))
                  (EQ (CAR DECL)
                      (CAR (SETQ TEM (GETP (CADR DECL)
                                           (QUOTE CLISPRECORD]

          (* Feature: saying (RECORD FOO) if FOO has a 
          CLISPRECORD PROP, just redeclares FOO -
          Useful if you edit the property -
          Check for TEM keeps this from looping 
          infinitely)


              (SETQ DECL (CONS (CAR TEM)
                               (CDR TEM)))
              (GO RETRY)))
          (SETQ GETHASH (RECORDECL DECL T))
          (COND
            ((SETQ NAME (CADR DECL))
              [COND
                ((SETQ TEM (GETP NAME (QUOTE CLISPRECORD)))
                  (SETQ REDECLARELST
                    (LIST (CAR (SETQ TEM (RECORDECL TEM)))
                          NAME))

          (* REDCLARELST is used for the MAPHASH -
          Here we get the RECORD name -
          Note that REDECLARELST has the format 
          ((list of fields) recordname))


                  [MAPC (CAR TEM)
                        (FUNCTION (LAMBDA (X)
                            (/REMPROP X (QUOTE CLISPRECORDFIELD))
                            (/DREMOVE X RECORDSPLIST]
                  (AND (NULL DFNFLG)
                       (LISPXPRINT
                         [CONS (QUOTE record)
                               (CONS NAME (QUOTE (redeclared]
                         T]
              (ADDGLOBVAR NAME (QUOTE USERRECORDS))
              (/PUT NAME (QUOTE CLISPRECORD)
                    DECL)))
          (AND FILEPKGFLG (ADDGLOBVAR (OR NAME DECL)
                                      (QUOTE CHANGEDRECLST)))
          [MAPC
            (CAR GETHASH)
            (FUNCTION (LAMBDA (FIELD)
                (PROG (TEM)
                      [COND
                        ((SETQ TEM (GETP FIELD (QUOTE 
                                            CLISPRECORDFIELD)))
                          [COND
                            [REDECLARELST
                              (OR (FMEMB FIELD (CAR REDECLARELST)
                                         )
                                  (FRPLACA REDECLARELST
                                           (CONS FIELD
                                                 (CAR 
                                                REDECLARELST]
                            (T (SETQ REDECLARELST
                                 (LIST (LIST FIELD]
                          (AND
                            (NULL DFNFLG)
                            (LISPXPRINT
                              [CONS
                                (QUOTE field)
                                (CONS
                                  FIELD
                                  (NCONC1
                                    [COND
                                      ((NLISTP (CADR TEM))
                                        (LIST
                                          (LIST (QUOTE of)
                                                (CADR TEM]
                                    (QUOTE redeclared]
                              T]
                      (ADDSPELL FIELD RECORDSPLIST)
                      (/PUT FIELD (QUOTE CLISPRECORDFIELD)
                            DECL]
          [AND REDECLARELST CLISPARRAY
               (MAPHASH
                 CLISPARRAY
                 (FUNCTION (LAMBDA (X Y)
                     (AND X
                          [COND
                            ((FMEMB (CAR Y)
                                    (QUOTE (fetch FETCH
                                                    replace
                                                      REPLACE)))
                              (FMEMB (CADR Y)
                                     (CAR REDECLARELST)))
                            ((FMEMB (CAR Y)
                                    CLISPRECORDWORDS)
                              (EQ (CADR Y)
                                  (CADR REDECLARELST]
                          (/PUTHASH Y NIL CLISPARRAY]
          (RETURN NAME])

(RECORDECL
  [LAMBDA (DECL FLG)

          (* Fixes up the RECORD declaration DECL and 
          returns the "MEANING" of the declaration;
          if FLG is NIL, just are interested in 
          (CAR (RECORDECL --)); i.e. the list of field 
          names within)



          (* Get the "MEANING" of the declaration;
          the meaning of a declaration is stored: 
          (FIELDS.DEFINED STATE.OF.DECLARATION 
          CREATE.INFO . FIELD.ALIST) where 
          FIELDS.DEFINED is the list of field names;
          STATE.OF.DECLARATION is a list of flags such 
          as "DEFAULTSNOTDWIM'D" and FIELD.ALIST is an 
          association list of (FIELD.NAME ACCESSDEF 
          SETDEF SUBFIELDS DEFAULT.INFO))


    (COND
      ((NLISTP DECL)
        NIL)
      ((EQ (CAR DECL)
           CLISPTRANFLG)                        (* Already been 
                                                clisptran'ed)
        (AND (FMEMB (CADDR DECL)
                    CLISPRECORDTYPES)
             (CHECKDEFAULT (CADR DECL)
                           (CDDR DECL)
                           FLG)))
      ((NOT (FMEMB (CAR DECL)
                   CLISPRECORDTYPES))           (* NOT A RECORD 
                                                DECLARATION)
        NIL)
      (T (CHECKDEFAULT (OR (GETHASH DECL CLISPARRAY)
                           (PROG (TEM)
                                 (FIXUPDEC DECL)
                                 (CLISPTRAN DECL (SETQ TEM
                                              (LIST NIL T)))
                                 (RETURN TEM)))
                       DECL FLG])

(FIXUPDEC
  [LAMBDA (DECL)
    (SELECTQ (CAR DECL)
             [HASHLINK [COND
                         ((LISTP (CADR DECL))
                           (/RPLACD DECL (CONS (CAADR DECL)
                                               (CDR DECL]
                       (COND
                         ((NULL (CDR (CADDR DECL)))
                           (/RPLACD (CADDR DECL)
                                    (LIST (CADR DECL]
             ((PROPRECORD OPTIONS)
               [COND
                 ((LISTP (CADR DECL))
                   (/RPLACD DECL (CONS NIL (CDR DECL]
               (OR (EVERY (CADDR DECL)
                          (QUOTE LITATOM))
                   (RECORDERROR (QUOTE BADEC)
                                NIL DECL)))
             [RECORD [COND
                       ((LISTP (CADR DECL))
                         (/RPLACD DECL (CONS NIL (CDR DECL]
                     (COND
                       ((NLISTP (CADDR DECL))
                         (RECORDERROR (QUOTE BADEC)
                                      NIL DECL]
             [TYPRECORD (COND
                          ((LISTP (CADR DECL))
                            (RECORDERROR (QUOTE BADEC)
                                         NIL DECL]
             (PROG [(TEM (GETP (CAR DECL)
                               (QUOTE RECORDTYPE]
                   (COND
                     ((NULL TEM)
                       (RECORDERROR (QUOTE BADEC)
                                    NIL DECL))
                     ((NULL (CADR TEM))
                       T)
                     (T (APPLY* (CADR TEM)
                                DECL])

(CHECKDEFAULT
  [LAMBDA (RECORDINFO DECLARATION FLG)

          (* FLG is either NIL meaning that the fields 
          only are needed, T meaning that ALL the info 
          is needed, or a "superior" record declaration 
          meaning that this is an internal 
          (sub-record) declaration)


    (COND
      ([OR (NULL (CDDDR RECORDINFO))
           (NOT (NULL (CADR RECORDINFO]

          (* if the dwimifycation of the record hasn't 
          been done yet or hasn't been completed)


        [PROG ((DEFAULTTAIL (CDDDR DECLARATION))
               DECLST LOCALVARS TEM1 FOUNDENTRY)
              (RPLNODE RECORDINFO
                       (MAPCAR (SETQ TEM1 (FIXALIST1 RECORDINFO 
                                                 DECLARATION FLG)
                                 )
                               (FUNCTION CAR))
                       (CONS T (CONS (CREATEINFO DECL)
                                     TEM1)))
              (OR DEFAULTTAIL (RETURN))
              (DWIMIFYREC DEFAULTTAIL (SETQ LOCALVARS
                            (CONS (QUOTE DEFAULT)
                                  (CAR RECORDINFO)))
                          DECLARATION)
          LP  (COND
                (DEFAULTTAIL
                  [SETQ DEFAULTTAIL
                    (COND
                      ((EQ (CAR DEFAULTTAIL)
                           (QUOTE DEFAULT))
                        (CDR DEFAULTTAIL))
                      ((FMEMB (CAR (LISTP (CAR DEFAULTTAIL)))
                              CLISPRECORDTYPES)
                                                (* Fix up both 
                                                alist and fields)
                        (SETQ TEM1 (RECORDECL (CAR DEFAULTTAIL)
                                              DECLARATION))
                        [NCONC
                          RECORDINFO
                          (MAPCAR
                            (CDDDR TEM1)
                            (FUNCTION (LAMBDA (ENTRY TEM2)
                                                (* ENTRY is 
                                                interior name, 
                                                interior defs;
                                                want to COMPOSE 
                                                with top)
                                [SETQ FOUNDENTRY
                                  (COND
                                    ((SETQ TEM2
                                        (FASSOC (CADAR 
                                                 DEFAULTTAIL)
                                                (CDDDR 
                                                  RECORDINFO)))

          (* Look up the name in the superior field;
          mark it's subfields as this sub-record 
          declaration; and get the access definition of 
          the interior)


                                      (FRPLACD
                                        (CDDR TEM2)
                                        (CONS (CAR DEFAULTTAIL)
                                              (CDDDDR TEM2)))
                                      (CADR TEM1))
                                    ((EQ (CADAR DEFAULTTAIL)
                                         (CADR DECLARATION))
                                      (QUOTE X))
                                    (T (RECORDERROR
                                         (QUOTE MISMATCH)
                                         DEFAULTTAIL DECLARATION]
                                (LIST (CAR ENTRY)
                                      (COMPOSE (CADR ENTRY)
                                               FOUNDENTRY)
                                      (COMPOSE (CADDR ENTRY)
                                               FOUNDENTRY T]
                        (NCONC (CAR RECORDINFO)
                               (MAPCAR (CDDDR TEM1)
                                       (FUNCTION CAR)))
                        (CDR DEFAULTTAIL))
                      (T (GETSETQ DEFAULTTAIL (CDDDR RECORDINFO)
                                  LOCALVARS DECLARATION T]
                  (GO LP]
        (FRPLACA (CDR RECORDINFO)
                 NIL)))
    RECORDINFO])

(CREATEINFO
  [LAMBDA (DECL FIELDS)
    (SELECTQ DECL:1
             ((RECORD TYPERECORD)
               NIL)
             (HELP])

(FIXALIST1
  [LAMBDA (GETHASH RECORDECLARATION FLG)

          (* This function creates the association list 
          of "MEANINGS" of RECORD fields;
          it uses the RECORDECLARATION and possibly the 
          value of the "GETHASH" set up by CREATEINFO, 
          and possibly FLG ≠which is a "superior" 
          record declaration if this is an internal 
          record, and NIL or T if it as a top level 
          one)


    (SELECTQ
      (CAR RECORDECLARATION)
      (RECORD (FIELDDEFS (CADDR RECORDECLARATION)))
      [TYPERECORD (FIELDDEFS (CONS NIL (CADDR RECORDECLARATION]
      [HASHLINK (LIST (LIST (CAR (CADDR RECORDECLARATION))
                            (LIST (QUOTE GETHASH)
                                  (QUOTE X)
                                  (CADR (CADDR RECORDECLARATION))
                                  )
                            (LIST (QUOTE PUTHASH)
                                  (QUOTE X)
                                  (QUOTE Y)
                                  (CADR (CADDR RECORDECLARATION]
      [(PROPRECORD OPTIONS)

          (* The decision of when to "CAR SKIP" 
          (i.e. to insert an extra field at the 
          beginning of the record in order to have 
          something to RPLAC into is: Yes, if this is a 
          top-level declaration, or if it isn't the 
          subfield of a RECORD or TYPERECORD))


        [SETQ FLG (OR (EQ (CAR FLG)
                          (QUOTE RECORD))
                      (EQ (CAR FLG)
                          (QUOTE TYPERECORD]
        (for X in (CADDR RECORDECLARATION)
           collect (LIST X (LIST (QUOTE GET)
                                 [COND
                                   (FLG (QUOTE X))
                                   (T (QUOTE (CDR X]
                                 (KWOTE X))
                         (LIST (COND
                                 (FLG (QUOTE PUTL))
                                 (T (QUOTE PUTLD)))
                               (QUOTE X)
                               (KWOTE X)
                               (QUOTE Y]
      (OR (AND (SETQ GETHASH (GETP (CAR RECORDECLARATION)
                                   (QUOTE RECORDTYPE)))
               (APPLY* (CAR GETHASH)
                       RECORDECLARATION))
          (RECORDERROR (QUOTE BADDEC)
                       NIL RECORDECLARATION])

(DWIMIFYREC
  [LAMBDA (TAIL NEWVARS PARENT)
    (PROG ((VARS (APPEND NEWVARS VARS)))
          (AND RECORDSUBSTFLG (SETQ VARS (CONS (QUOTE @)
                                               VARS)))
          (DWIMIFY1B TAIL PARENT TAIL T NIL FAULTFN])

(COMPOSE
  [LAMBDA (EXPR1 EXPR2 RPLFLG)
    (PROG NIL
          [COND
            ((LISTP EXPR2))
            ((EQ EXPR2 (QUOTE X))
              (RETURN EXPR1))
            (T (SETQ EXPR2 (LIST EXPR2 (QUOTE X]
          (COND
            [(AND RPLFLG (EQ (CAR EXPR1)
                             (QUOTE PUTL)))
              (PROG ((TEM2 (FASSOC (CAR EXPR2)
                                   CRLIST)))
                    (RETURN
                      (LIST (SELECTQ (CADDDR TEM2)
                                     (CAR (QUOTE PUTLA))
                                     (CDR (QUOTE PUTLD))
                                     (GO NOCARCDR))
                            (COND
                              ((CAR (CDDDDR TEM2))
                                (LIST (CAR (CDDDDR TEM2))
                                      (CADR EXPR2)))
                              (T (CADR EXPR2)))
                            (QUOTE Y)))
                NOCARCDR

          (* EXPR1 IS (PUTL X ...) want 
          (PUTL EXPR2 ...) or (replace EXPR2 with 
          (PUTL EXPR2 ...)) or (replace expr2:1 of 
          expr2:2 with (PUTL EXPR2 ...)))


                    (RETURN
                      (CONS
                        [LIST
                          (QUOTE LAMBDA)
                          (QUOTE ($$TEM))
                          (LIST
                            (QUOTE replace)
                            (CAR EXPR2)
                            (QUOTE of)
                            (QUOTE $$TEM)
                            (QUOTE with)
                            (CONS (QUOTE PUTL)
                                  (CONS (LIST (CAR EXPR2)
                                              (QUOTE $$TEM))
                                        (CDDR EXPR1]
                        (CDR EXPR2]
            [(NLISTP EXPR1)
              (CONS EXPR1 (CONS EXPR2 (COND
                                  (RPLFLG (QUOTE (Y)))
                                  (T NIL]
            (T (SUBST EXPR2 (QUOTE X)
                      EXPR1])

(GETSETQ
  [LAMBDA (TAIL ALIST FIELDS PARENT ALISTFLG)   (* DECLARATIONS: 
                                                FAST)
    (PROG (TEM1 ERRORTYPE)
      LP2 [COND
            ((NLISTP (CAR TAIL))
              (COND
                ([AND (FMEMB (CAR TAIL)
                             FIELDS)
                      (OR (NLISTP (CADR TAIL))
                          [NOT (FMEMB (CAADR TAIL)
                                      (QUOTE (SETQ SETQQ 
                                               SAVESETQ 
                                               SAVESETQQ]
                          (NOT (FMEMB (CADR (CADR TAIL))
                                      FIELDS]   (* Cases where "←"
                                                was omitted;
                                                inserts it)
                  (/RPLNODE TAIL (LIST (QUOTE SETQ)
                                       (CAR TAIL)
                                       (CADR TAIL))
                            (CDDR TAIL))
                  (GO LP2))
                (T (SETQ ERRORTYPE (QUOTE NOFIELDS))
                   (GO ERROR]
          (SELECTQ (CAAR TAIL)
                   ((SETQ SAVESETQ))
                   [(SETQQ SAVESETQQ)
                     (/RPLNODE
                       (CAR TAIL)
                       (QUOTE SETQ)
                       (LIST (CADAR TAIL)
                             (KWOTE (CADDR (CAR TAIL]
                   (PROGN (SETQ ERRORTYPE (QUOTE NOFIELD))
                          (GO ERROR)))
          [COND
            [(SETQ TEM1 (FASSOC (CADAR TAIL)
                                ALIST))
              [COND
                (ALISTFLG (SETQ TEM1 (CDDR TEM1))
                          (OR (LISTP TEM1)
                              (HELP))
                          (COND
                            ((NULL (CDR TEM1))
                              (FRPLACD TEM1 (LIST NIL]
              (COND
                ((CDR TEM1)
                  (SETQ ERRORTYPE "field specified twice"))
                (T
                  (FRPLACD TEM1 (OR (CDDAR TAIL)
                                    (LIST NIL)))
                  (RETURN
                    (PROG1
                      (CDR TAIL)
                      (/RPLNODE
                        TAIL
                        (CADAR TAIL)
                        (CONS (QUOTE ←)
                              (CONS (CADDR (CAR TAIL))
                                    (CDR TAIL]
            ((FIXSPELL (CADAR TAIL)
                       70 FIELDS NIL (CDAR TAIL)
                       NIL T)
              (GO LP2))
            (T (SETQ ERRORTYPE (QUOTE FIELDS]
      ERROR
          (RECORDERROR ERRORTYPE TAIL PARENT])

(FIELDDEFS
  [LAMBDA (FORMAT RCROPS)
    (COND
      ((NULL FORMAT)
        NIL)
      [(LISTP FORMAT)
        (NCONC (AND (CAR FORMAT)
                    (FIELDDEFS (CAR FORMAT)
                               (CONS (QUOTE A)
                                     RCROPS)))
               (AND (CDR FORMAT)
                    (FIELDDEFS (CDR FORMAT)
                               (CONS (QUOTE D)
                                     RCROPS]
      [(LITATOM FORMAT)
        (LIST (LIST FORMAT (SETQ FORMAT (MAKECROPFN1 RCROPS))
                    (MAKERPLAC2 FORMAT]
      (T (RECORDERROR "Invalid record field" FORMAT 
                      RECORDECLARATION])

(RECORDERROR
  [LAMBDA (MESSAGE AT IN)
    (CLISPERROR
      (LIST
        (SELECTQ
          MESSAGE
          (BADEC "bad record declaration")
          ((NOFIELD NOFIELDS)
            "missing 'field←'")
          (MISMATCH
            
"Record subfield with no corresponding name in primary record")
          (FIELDS "unrecognized field←")
          MESSAGE)
        AT IN)
      T)                                        (* Tell it that 
                                                this is an 
                                                external call)
    (ERROR!])
)
(DEFINEQ

(ADDGLOBVAR
  [LAMBDA (VAL AT)
    (OR [COND
          ((LISTP VAL)
            (MEMBER VAL (CAR AT)))
          (T (FMEMB VAL (CAR AT]
        (/RPLACA AT (CONS VAL (CAR AT])

(CLISPNOTRAN
  [LAMBDA (X)

          (* This function doesn't really do much;
          it is just A canonical way of checking for 
          the CLISPTRANFLG; i really shouldn't worry 
          about it working when the CLISPARRAY is off;
          but, well, i did it)


    (COND
      ((AND (LISTP X)
            (EQ (CAR X)
                CLISPTRANFLG))
        (CDDR X))
      (T X])

(RECORDERROR
  [LAMBDA (MESSAGE AT IN)
    (CLISPERROR
      (LIST
        (SELECTQ
          MESSAGE
          (BADEC "bad record declaration")
          ((NOFIELD NOFIELDS)
            "missing 'field←'")
          (MISMATCH
            
"Record subfield with no corresponding name in primary record")
          (FIELDS "unrecognized field←")
          MESSAGE)
        AT IN)
      T)                                        (* Tell it that 
                                                this is an 
                                                external call)
    (ERROR!])
)
(DEFINEQ

(CLISPRECORD
  [LAMBDA (RECEXPR FIELD SETQFLG)
    (PROG (DEF (DECLST (GETLOCALDEC EXPR FAULTFN))
               (CHECKFIELD FIELD)
               TAIL)

          (* Handles records. When FIELD is NIL, 
          RECEXPR is an expression such as 
          (fetch --) or (replace --). In this case, 
          CLISPRECORD is to do the appropriate lookups 
          and construct the appropriate expresson, 
          which it returns as its value.
          it should also do the hashing.
          Note that even if there are no local 
          declaration, only global ones, it shuld still 
          construct the expression and hash on it.
          If there are no local or global declaration, 
          return NIL. I will handle the error.)


      RETRY
          (COND
            [(AND FIELD (NLISTP FIELD))         (* X : FIELD 
                                                input)
              (COND
                [SETQFLG (COND
                           ((SETQ DEF (SETDEF FIELD DECLST 
                                              RECEXPR))
                                                (* Return 
                                                intermediate 
                                                result for next 
                                                call)
                             (RETURN (LIST (QUOTE replace)
                                           FIELD DEF RECEXPR)))
                           (T (GO ERROR]
                ((SETQ DEF (ACCESSDEF FIELD DECLST RECEXPR))
                  (SETQ RECEXPR (LIST (QUOTE fetch)
                                      FIELD
                                      (QUOTE of)
                                      RECEXPR))
                  (GO GOTDEF))
                (T (GO ERROR]
            (SETQFLG [OR (EQ (CAR RECEXPR)
                             (QUOTE replace))
                         (HELP (QUOTE (BAD ARG TO CLISPRECORD]
                                                (* Second pass -
                                                Already done 
                                                spelling 
                                                correction)
                     (SETQ DEF (CADDR RECEXPR))
                     (FRPLACA (CDDR RECEXPR)
                              (QUOTE of))
                     (FRPLACD (CDDDR RECEXPR)
                              (CONS (QUOTE with)
                                    FIELD))
                     (GO GOTDEF))
            (T                                  (* User typein)
              (SETQ CHECKFIELD (CADR RECEXPR))
              (SETQ TAIL (CDR RECEXPR))
              (SETQ DEF
                (OR (SELECTQ (CAR RECEXPR)
                             ((fetch FETCH)
                               (ACCESSDEF CHECKFIELD DECLST
                                          (CADDDR RECEXPR)))
                             ((replace REPLACE)
                               (SETDEF CHECKFIELD DECLST
                                       (CADDDR RECEXPR)))
                             (HELP "BAD ARG TO CLISPRECORD" 
                                   RECEXPR))
                    (GO ERROR)))
              [COND
                ((LISTP CHECKFIELD))
                (T [SELECTQ (CADDR RECEXPR)
                            ((of OF))
                            (OR (FIXSPELL (CADDR RECEXPR)
                                          70
                                          (QUOTE (OF of))
                                          NIL
                                          (CDDR RECEXPR)
                                          NIL T)
                                (/ATTACH (QUOTE of)
                                         (CDDR RECEXPR]
                   (SETQ TAIL (CDDDR RECEXPR]
              (SELECTQ
                (CAR RECEXPR)
                [(REPLACE replace)
                  (SELECTQ (CADR TAIL)
                           ((with WITH))
                           (OR (FIXSPELL (CADR TAIL)
                                         70
                                         (QUOTE (WITH with))
                                         NIL
                                         (CDR TAIL)
                                         NIL T)
                               (/RPLACD TAIL
                                        (CONS (QUOTE with)
                                              (CDR TAIL]
                NIL)
              (GO GOTDEF)))
      GOTDEF

          (* DEF is either an atom;
          meaning a function of (one argument for 
          access) (two arguments for REPLACE); or 
          LISTP, meaning a FORM of with X and Y;
          X being the thing the "FIELD" IS taken of, 
          and Y , optional, being the replaced value)


          (SETQ DEF (MYSUBST DEF (COND
                               [(OR (EQ (CADDR RECEXPR)
                                        (QUOTE OF))
                                    (EQ (CADDR RECEXPR)
                                        (QUOTE of)))
                                 (CAR (SETQ TAIL (CDDDR RECEXPR]
                               (T (SETQ TAIL (CDR RECEXPR))
                                  NIL))
                             (CADDR TAIL)))
          (SETQ DEF (CONS (RECLISPLOOKUP (CAR DEF)
                                         (CADR DEF)
                                         DECLST)
                          (CDR DEF)))
          (COND
            ([AND ACCESSNOTRANFLG
                  (OR (LISTP (GETP (CAR DEF)
                                   (QUOTE ACCESSFN)))
                      (LISTP (GETP (CAR DEF)
                                   (QUOTE SETFN]
              (RETURN DEF))
            (T (CLISPTRAN RECEXPR DEF)
               (RETURN RECEXPR)))
      ERROR
          (COND
            ((SETQ CHECKFIELD (RECRESPELL CHECKFIELD DECLST TAIL)
                )
              (OR TAIL (SETQ FIELD CHECKFIELD))
              (GO RETRY])

(SETDEF
  [LAMBDA (FIELD DECLST VAR1)
    (PROG (TEM1)
          (COND
            ((LISTP FIELD)
              (RETURN (MAKERPLAC2 FIELD)))
            ([AND DECLST (SETQ TEM1
                    (CLISPLOOKUP0 FIELD VAR1 NIL DECLST NIL
                                  (QUOTE RECORDFIELD]
                                                (* Local 
                                                declaration,)
              )
            ((SETQ TEM1 (GETP FIELD (QUOTE CLISPRECORDFIELD)))
                                                (* Global 
                                                declaration)
              )
            ([AND (SETQ TEM1 (OR (REALATOM (GETP FIELD
                                                 (QUOTE ACCESSFN)
                                                 ))
                                 (AND (REALATOM FIELD)
                                      (FGETD FIELD)
                                      FIELD)))
                  (SETQ TEM1 (OR (REALATOM (GETP TEM1
                                                 (QUOTE SETFN)))
                                 (MAKERPLAC2 TEM1]
              (RETURN TEM1))
            (T (RETURN)))
          (RETURN (CADDR (FASSOC FIELD (CDDDR (RECORDECL TEM1 T])

(ACCESSDEF
  [LAMBDA (FIELD DECLST VAR1)
    (PROG (TEM1)
          (COND
            ((LISTP FIELD)
              (RETURN (AND (GETD (CAR FIELD))
                           FIELD)))
            ([AND (COND
                    ((EQ DECLST T)
                      (SETQ DECLST (GETLOCALDEC EXPR)))
                    (T DECLST))
                  (SETQ TEM1 (CLISPLOOKUP0 FIELD VAR1 NIL DECLST 
                                           NIL (QUOTE 
                                                 RECORDFIELD]
                                                (* Local 
                                                declaration,)
              )
            ((SETQ TEM1 (GETP FIELD (QUOTE CLISPRECORDFIELD)))
                                                (* Global 
                                                declaration)
              )
            ((AND (SETQ TEM1 (GETP FIELD (QUOTE ACCESSFN)))
                  (NLISTP TEM1))
              (RETURN TEM1))
            (T (RETURN)))
          (SETQ TEM1 (RECORDECL TEM1 T))
      GOT (RETURN (CADR (FASSOC FIELD (CDDDR TEM1])

(GETLOCALDEC
  [LAMBDA (EXPR FN)
    (PROG (TEM)
          (RETURN (COND
                    ((AND (EQ (CAR (SETQ TEM (CADDR EXPR)))
                              (QUOTE *))
                          (EQ (CADR TEM)
                              (QUOTE DECLARATIONS:)))
                      (CDDR TEM))
                    ((EQ (CAR TEM)
                         (QUOTE CLISP:))
                      (CLISPDEC0 TEM (OR FN FAULTFN])

(MYSUBST
  [LAMBDA (FORM XITEM YITEM)
    (COND
      ((EQ FORM (QUOTE X))
        XITEM)
      [(NLISTP FORM)
        (CONS FORM (CONS XITEM (AND YITEM (LIST YITEM]
      (T (SUBPAIR (QUOTE (X Y))
                  (LIST XITEM YITEM)
                  FORM])

(RECLISPLOOKUP
  [LAMBDA (WORD VAR1 DECLST)
    (PROG ((LISPFN (GETP WORD (QUOTE LISPFN)))
           CLASSDEF)
          (COND
            ([AND DECLST (SETQ CLASSDEF (GETP WORD (QUOTE 
                                               CLISPCLASSDEF]

          (* must do full lookup.
          Note that it is not necessary to do a call to 
          CLISPLOOKUP0 if word has a CLASS, but no 
          CLASSDEF, e.g. FGTP, FMEMB, etc., since if 
          these are ued as infix operators, they mean 
          the corresponding functin regardless of 
          declaraton. I.e. The CLASSDEF property says 
          that this is the name of an infix operator.
          The CLASS property is used as a back pointer 
          to the name of the operator/class of which 
          this word is a member.)


              (CLISPLOOKUP0 WORD VAR1 NIL DECLST LISPFN
                            (GETP WORD (QUOTE CLISPCLASS))
                            CLASSDEF))
            (T (OR LISPFN WORD])

(RECRESPELL
  [LAMBDA (FIELD DECLST TAIL)
    (FIXSPELL FIELD 70
              (NCONC [MAPCONC DECLST
                              (FUNCTION (LAMBDA (X)
                                  (APPEND (CAR (RECORDECL X]
                     RECORDSPLIST)
              NIL TAIL NIL T])

(REALATOM
  [LAMBDA (X)
    (AND (LITATOM X)
         X])

(MAKERPLAC2
  [LAMBDA (FORM)
    (PROG (TEM TEM2)
          (OR
            (SETQ TEM (CDDDR (FASSOC (COND
                                       ((LISTP FORM)
                                         (CAR FORM))
                                       (T FORM))
                                     CRLIST)))
            (RETURN
              (SELECTQ (CAR FORM)
                       [GETHASH
                         (CONS (QUOTE PUTHASH)
                               (CONS (CADR FORM)
                                     (CONS (QUOTE Y)
                                           (CDDR FORM]
                       NIL)))
          (SETQ TEM2 (SELECTQ (CAR TEM)
                              (CAR (QUOTE RPLACA))
                              (CDR (QUOTE RPLACD))
                              (HELP)))
          (COND
            ((AND (NLISTP FORM)
                  (NULL (CADR TEM)))
              TEM2)
            (T [SETQ FORM (COND
                   ((NLISTP FORM)
                     (QUOTE X))
                   (T (CADR FORM]
               (LIST TEM2 (COND
                       ((CADR TEM)
                         (LIST (CADR TEM)
                               FORM))
                       (T FORM))
                     (QUOTE Y])
)
(DEFINEQ

(RECCOMPOSE0
  [LAMBDA (COMPOSESTATEMENT)
    (COND
      ((NOT (FMEMB (CAR COMPOSESTATEMENT)
                   CLISPRECORDWORDS))
        (CLISPRECORD COMPOSESTATEMENT))
      (T
        (PROG (FIELDS DECL ALIST USINGTYPE USING TEM2 CREATE)
              (SETQ CLISPCHANGE T)              (* Tell DWIMIFY 
                                                not to process 
                                                further)
              [PROG (TEM)                       (* find the 
                                                "CREATE" 
                                                expression)
                LPX [COND
                      ([SETQ
                          CREATE
                           (SOME
                             COMPOSESTATEMENT
                             (FUNCTION (LAMBDA (X)
                                 (OR (EQ (SETQ TEM2
                                           (RECORDWORD X))
                                         (QUOTE CREATE))
                                     (EQ TEM2 (QUOTE create]
                        (SETQ FIELDS
                          (RECORDECL (SETQ DECL
                                       (RECLOOK (CADR CREATE)
                                                (CDR CREATE)
                                                (GETLOCALDEC
                                                  EXPR FAULTFN)
                                                COMPOSESTATEMENT)
                                       )
                                     T]
                    (COND
                      (TEM (OR CREATE (RECORDERROR "no CREATE" 
                                                   NIL 
                                            COMPOSESTATEMENT)))
                      (T
                        (DWIMIFYREC
                          (CDR COMPOSESTATEMENT)
                          (NCONC
                            [AND
                               CREATE
                                (APPEND (CAR FIELDS)
                                        (LIST (CADR CREATE]
                            (APPEND CLISPRECORDWORDS))
                          COMPOSESTATEMENT)
                        (COND
                          ((NOT CREATE)
                            (SETQ TEM T)
                            (GO LPX]
              (SETQ DECL (CLISPNOTRAN DECL))

          (* DECL is the actual declaration 
          (used for determining TYPERECORD) and fields 
          is the hashed declaration -
          (fieldlist defaults fields ...))


              (PROG ((TEM COMPOSESTATEMENT))

          (* Go through the create statement, picking 
          up the field←'s and the USING and/or COPYING, 
          etc)


                    (SETQ ALIST (MAKEALIST (CAR FIELDS)))
                LP2 [SETQ TEM
                      (COND
                        ([AND
                            (SETQ TEM2 (RECORDWORD (CAR TEM)))
                            (SELECTQ
                              TEM2
                              ((CREATE create)
                                                (* already 
                                                handled)
                                T)
                              (COND
                                ((FMEMB TEM2 CLISPRECORDWORDS)
                                  (AND
                                     USING
                                      (RECORDERROR
                                        (LIST (QUOTE "both")
                                              (CAR TEM)
                                              (QUOTE "and")
                                              (CAR USING))
                                        TEM COMPOSESTATEMENT))
                                  (SETQ USINGTYPE TEM2)
                                  (SETQ USING TEM]
                          (CDDR TEM))
                        (T 

          (* GETSETQ adds the info to alist, or ERROR's 
          -
          let it handle unrecognized NLISTP's as well)


                           (GETSETQ TEM ALIST (CAR FIELDS)
                                    COMPOSESTATEMENT]
                    (AND TEM (GO LP2)))
              (CLISPTRAN COMPOSESTATEMENT
                         (RECCOMPOSE DECL FIELDS ALIST USINGTYPE
                                     (CADR USING)))
              (OR
                [AND
                  (EQ (CAR COMPOSESTATEMENT)
                      (CAR CREATE))
                  (EQUAL
                    (CDR COMPOSESTATEMENT)
                    (SETQ TEM2
                      (CONS (CADR CREATE)
                            (NCONC (AND
                                      USING (LIST (CAR USING)
                                                  (CADR
                                                     USING)))
                                   (SETPACK ALIST]
                (/RPLNODE COMPOSESTATEMENT (CAR CREATE)
                          TEM2)))
        COMPOSESTATEMENT])

(RECORDWORD
  [LAMBDA (WORD)
    (AND (EQ [CAR (SETQ WORD (GETP WORD (QUOTE CLISPWORD]
             (QUOTE RECORDWORD))
         (COND
           ((LISTP (CDR WORD))
             (CADDR WORD))
           (T (CDR WORD])

(RECLOOK
  [LAMBDA (RECNAME TAIL LOCALDEC PARENT)        (* LOOKS FOR 
                                                RECORD 
                                                DECLARATION)
    (PROG (TEM)
      RETRY
          (OR
            (COND
              [(NLISTP RECNAME)
                (OR
                  (AND LOCALDEC (CLISPLOOKUP0 RECNAME NIL NIL 
                                              LOCALDEC NIL
                                              (QUOTE RECORD)))
                  (GETP RECNAME (QUOTE CLISPRECORD))
                  (COND
                    ((SETQ TEM
                        (FIXSPELL
                          RECNAME 70
                          (NCONC
                            [MAPCONC
                              LOCALDEC
                              (FUNCTION (LAMBDA (X)
                                  (AND (FMEMB (CAR X)
                                              CLISPRECORDTYPES)
                                       (NLISTP (CADR X))
                                       (LIST (CADR X]
                            USERRECORDS)
                          NIL TAIL NIL T))
                      (SETQ RECNAME TEM)
                      (GO RETRY]
              ((FMEMB (CAR RECNAME)
                      CLISPRECORDTYPES)
                RECNAME))
            (RECORDERROR (CONCAT RECNAME " not a record")
                         NIL PARENT])

(MAKEALIST
  [LAMBDA (LST)
    (MAPCAR LST (FUNCTION (LAMBDA (X)
                (LIST X])

(RECCOMPOSE
  [LAMBDA (DECLARATION GETHASH.DECLARATION FIELD.ALIST USINGTYPE 
                       USINGEXPR)
    (PROG (TEMVAR DEF TYPERECORDFLG)
          (SELECTQ
            (CAR DECLARATION)
            [(RECORD TYPERECORD)
              (PROG ((TYPERECORDFLG (AND 
                                   DECLARATION:1='TYPERECORD
                                         (CADR DECLARATION)))
                     TEMVAR DEF)
                    [SETQ DEF
                      (RECCOMPOSE1
                        (CADDR DECLARATION)
                        (AND
                          USINGTYPE
                          (COND
                            ((NOT (EASYCOMPUTE USINGEXPR))
                              [SETQ TEMVAR
                                (LIST
                                  (LIST (QUOTE $$TEM)
                                        (COND
                                          (TYPERECORDFLG
                                            ('CDR USINGEXPR))
                                          (T USINGEXPR]
                              (CAAR TEMVAR))
                            (TYPERECORDFLG ('CDR USINGEXPR))
                            (T USINGEXPR]
                    [COND
                      (TEMVAR (SETQ DEF (LIST (QUOTE PROG)
                                              TEMVAR DEF]
                    (RETURN (COND
                              (TYPERECORDFLG
                                ('CONS (KWOTE TYPERECORDFLG)
                                       DEF))
                              (T DEF]
            (HELP])

(SETPACK
  [LAMBDA (ALIST)
    (for TEM in ALIST when (CDR TEM)
       join (LIST (PACK (LIST (CAR TEM)
                              (QUOTE ←)))
                  (CADR TEM])

(RECCOMPOSE1
  [LAMBDA (FIELD DEF)
    (PROG (K (BLIP (CONS)))

          (* BLIP is used as a value of RECCOMPOSE2 
          when NO field is specified, and something 
          needs to be returned to distinguish it from 
          NIL (i.e. (CREATE FOO USING FIE FUM←NIL)))


          (COND
            ((NEQ (SETQ K (RECCOMPOSE2 FIELD DEF))
                  BLIP)                         (* RECCOMPOSE2 
                                                returns BLIP to 
                                                distinguish 
                                                FIELD←NIL from 
                                                the field being 
                                                not specified)
              K)
            (T 

          (* If no USING or COPYING were specified, 
          COPYING NIL is assumed;
          thus RECCOMPOSE returning NIL means that we 
          had a USING)


               DEF])

(EASYCOMPUTE
  [LAMBDA (X)
    (OR (NLISTP X)
        (AND (SELECTQ (CAR X)
                      ((CAR CDR)
                        T)
                      (GETP (CAR X)
                            (QUOTE CROPS)))
             (NLISTP (CADR X])

('CDR
  [LAMBDA (X)
    (AND X (PROG (TEM)
                 (COND
                   ([NULL (SETQ TEM (CADDR (FASSOC (CAR X)
                                                   CRLIST]
                     (LIST (QUOTE CDR)
                           X))
                   (T (LIST TEM (CADR X])

('CAR
  [LAMBDA (X)
    (AND X (PROG (TEM)
                 (COND
                   ([NULL (SETQ TEM (CADR (FASSOC (CAR X)
                                                  CRLIST]
                     (LIST (QUOTE CAR)
                           X))
                   (T (LIST TEM (CADR X])

(RECCOMPOSE2
  [LAMBDA (FIELD DEF CDRFLG)

          (* Constructs the composition of FIELD , 
          returning NIL if none of the fields in FIELD 
          are mentioned in the CREATE expression and 
          there isn't a default for any of the fields -
          and <consexpression> otherwise)


    (PROG (TEM1 TEM2)
          (COND
            [(LISTP FIELD)
              (SETQ TEM1 (RECCOMPOSE2 (CAR FIELD)
                                      ('CAR DEF)))
              (SETQ TEM2 (RECCOMPOSE2 (CDR FIELD)
                                      ('CDR DEF)
                                      T))

          (* if both are BLIP, means that 
          (1) REUSING specified; 
          (2) no fields were specified -
          if only one is non-BLIP, the other comes from 
          REUSING)


              (COND
                ((AND (EQ TEM1 BLIP)
                      (EQ TEM2 BLIP))
                  BLIP)
                (T ('CONS [COND
                            ((NEQ TEM1 BLIP)
                              TEM1)
                            (T (SELECTQ USINGTYPE
                                        ((COPYREUSING 
                                                 copyreusing)
                                          (LIST (QUOTE COPY)
                                                ('CAR DEF)))
                                        ('CAR DEF]
                          (COND
                            ((NEQ TEM2 BLIP)
                              TEM2)
                            (T (SELECTQ USINGTYPE
                                        ((COPYREUSING 
                                                 copyreusing)
                                          (LIST (QUOTE COPY)
                                                ('CDR DEF)))
                                        ('CDR DEF]
            [[AND FIELD (CDR (SETQ TEM1 (FASSOC FIELD 
                                                FIELD.ALIST]

          (* The field was specified -
          The SUBST here is for special option: 
          (create FOO using fie field1←< x ! @>) -
          The @ stands for fie:field1)


              (COND
                ((AND RECORDSUBSTFLG USINGTYPE)
                  (SUBPAIR (QUOTE @)
                           (SELECTQ USINGTYPE
                                    ((copying COPYING)
                                      (LIST (QUOTE COPY)
                                            DEF))
                                    DEF)
                           (CADR TEM1)))
                (T (CADR TEM1]
            (T
              (SELECTQ
                USINGTYPE
                ((reusing REUSING COPYREUSING copyreusing)

          (* Will get def back at higher level when it 
          is discovered that "other half" of the CONS 
          is needed)


                  BLIP)
                (AND
                  (OR FIELD (NOT CDRFLG))
                  (SELECTQ
                    USINGTYPE
                    ((using USING)
                      DEF)
                    ((copying COPYING)
                      (LIST (QUOTE COPY)
                            DEF))
                    (COND
                      ([AND FIELD (CDR (SETQ TEM1
                                         (FASSOC FIELD
                                                 (CDADR 
                                         GETHASH.DECLARATION]
                                                (* The field has 
                                                a default)
                        (CADR TEM1))
                      (T                        (* There is a 
                                                universal 
                                                default)
                         (CAADR GETHASH.DECLARATION])
)
(DEFINEQ

(PUTL
  [LAMBDA (LST PROP VAL)
    (COND
      ((NLISTP LST)
        (LIST PROP VAL))
      (T (PROG ((X LST))
           LOOP(COND
                 [(EQ (CAR X)
                      PROP)
                   (COND
                     ((LISTP (CDR X))
                       (FRPLACA (CDR X)
                                VAL)
                       X)
                     (T (FRPLACD X (LIST VAL]
                 [(NLISTP (CDR X))
                   (CDDR (FRPLACD X (LIST NIL PROP VAL]
                 [(NLISTP (CDDR X))
                   (CDR (FRPLACD (CDR X)
                                 (LIST PROP VAL]
                 (T (SETQ X (CDDR X))
                    (GO LOOP])

(PUTLA
  [LAMBDA (LST PROP VAL)
    (AND (NLISTP LST)
         (ERROR "PUTL ON NON-LIST" LST))
    (PROG ((X (CAR LST)))
      LOOP[COND
            [(EQ (CAR X)
                 PROP)
              (COND
                ((LISTP (CDR X))
                  (FRPLACA (CDR X)
                           VAL))
                (T (FRPLACD X (LIST VAL]
            ((LISTP (SETQ X (CDDR X)))
              (GO LOOP))
            (T (FRPLACA LST (CONS PROP (CONS VAL (CAR LST]
          (RETURN VAL])

(PUTLD
  [LAMBDA (LST PROP VAL)
    (AND (NLISTP LST)
         (NOT (AND LST (LITATOM LST)))
         (ERROR "INVALID ARG TO PUTL" LST))
    (PROG ((X LST))
      LOOP[COND
            ((NLISTP (CDR X))
              (FRPLACD X (LIST PROP VAL)))
            ((EQ (CADR X)
                 PROP)
              (FRPLACA (CDDR X)
                       VAL))
            ((SETQ X (CDDR X))
              (GO LOOP))
            (T (FRPLACD LST (CONS PROP (CONS VAL (CDR LST]
          (RETURN VAL])
)
  (RPAQQ CLISPRECORDTYPES (RECORD TYPERECORD OPTIONS PROPRECORD 
                                  HASHLINK ACCESSFN))
  (RPAQQ CLISPRECORDWORDS
         (SMASHING COPYREUSING CREATE USING COPYING REUSING 
                   create using copying reusing copyreusing 
                   smashing))
  (RPAQQ CRLIST ((CAR CAAR CDAR CAR NIL)
          (CDR CADR CDDR CDR NIL)
          (CDDDDR NIL NIL CDR CDDDR)
          (CADDDR NIL NIL CAR CDDDR)
          (CDDDR CADDDR CDDDDR CDR CDDR)
          (CDADDR NIL NIL CDR CADDR)
          (CAADDR NIL NIL CAR CADDR)
          (CADDR CAADDR CDADDR CAR CDDR)
          (CDDR CADDR CDDDR CDR CDR)
          (CDDADR NIL NIL CDR CDADR)
          (CADADR NIL NIL CAR CDADR)
          (CDADR CADADR CDDADR CDR CADR)
          (CDAADR NIL NIL CDR CAADR)
          (CAAADR NIL NIL CAR CAADR)
          (CAADR CAAADR CDAADR CAR CADR)
          (CADR CAADR CDADR CAR CDR)
          (CDDDAR NIL NIL CDR CDDAR)
          (CADDAR NIL NIL CAR CDDAR)
          (CDDAR CADDAR CDDDAR CDR CDAR)
          (CDADAR NIL NIL CDR CADAR)
          (CAADAR NIL NIL CAR CADAR)
          (CADAR CAADAR CDADAR CAR CDAR)
          (CDAR CADAR CDDAR CDR CAR)
          (CDDAAR NIL NIL CDR CDAAR)
          (CADAAR NIL NIL CAR CDAAR)
          (CDAAR CADAAR CDDAAR CDR CAAR)
          (CDAAAR NIL NIL CDR CAAAR)
          (CAAAAR NIL NIL CAR CAAAR)
          (CAAAR CAAAAR CDAAAR CAR CAAR)
          (CAAR CAAAR CDAAR CAR CAR)))
  (RPAQ RECORDSPLIST (LIST NIL))
  (RPAQ CHANGEDRECLST NIL)
  (RPAQ USERRECORDS NIL)
  (RPAQ RECORDSUBSTFLG T)
  (RPAQ ACCESSNOTRANFLG T)
  (SETQ NLAMA (APPEND CLISPRECORDTYPES NLAMA))
  (SETQ NOFIXFNSLST (APPEND CLISPRECORDTYPES NOFIXFNSLST))
(DEFLIST(QUOTE(
  (SMASHING NIL)
  (COPYREUSING NIL)
  (CREATE (RECORDWORD . create))
  (USING (RECORDWORD . using))
  (COPYING (RECORDWORD . copying))
  (REUSING (RECORDWORD . reusing))
  (create (RECORDWORD . create))
  (using (RECORDWORD . using))
  (copying (RECORDWORD . copying))
  (reusing (RECORDWORD . reusing))
  (copyreusing NIL)
  (smashing NIL)
))(QUOTE CLISPWORD))

(DEFLIST(QUOTE(
  [RECORDS (LAMBDA (X Y)
                   (AND (EQ (CAR X)
                            Y)
                        (CDR X]
))(QUOTE PRETTYTYPE))

  (ADDTOVAR PRETTYTYPELST (CHANGEDRECLST RECORDS "records"))
  [ADDTOVAR
    PRETTYMACROS
    (RECORDS
      X
      (PD
        *
        (MAPCAR
          (QUOTE X)
          (FUNCTION
            (LAMBDA
              (Z TEM)
              (OR (FMEMB [CAR (SETQ TEM
                                    (LISTP (GETP Z (QUOTE 
                                                 CLISPRECORD]
                         CLISPRECORDTYPES)
                  (ERROR Z "not a record"))
              TEM]
(DECLARE
  (BLOCK: RECORDBLOCK
          (ENTRIES RECORD TYPERECORD PROPRECORD CLISPRECORD 
                   RECCOMPOSE0 RECORDECL RECORDERROR RECORD1 
                   HASHLINK CLISPNOTRAN)
          RECORD PROPRECORD TYPERECORD HASHLINK RECORD1 
          RECORDECL FIXUPDEC CHECKDEFAULT FIXALIST1 DWIMIFYREC 
          COMPOSE GETSETQ FIELDDEFS RECORDERROR ADDGLOBVAR 
          CLISPNOTRAN RECORDERROR CLISPRECORD SETDEF ACCESSDEF 
          GETLOCALDEC MYSUBST RECLISPLOOKUP RECRESPELL REALATOM 
          MAKERPLAC2 RECCOMPOSE0 RECORDWORD RECLOOK MAKEALIST 
          RECCOMPOSE SETPACK RECCOMPOSE1 EASYCOMPUTE 'CDR 'CAR 
          RECCOMPOSE2 PUTL PUTLA PUTLD
          (SPECVARS VARS FAULTFN CLISPCHANGE EXPR REDECLARELST)
          (GLOBALVARS CRLIST RECORDSPLIST CLISPRECORDWORDS 
                      CLISPRECORDTYPES RECORDSUBSTFLG 
                      ACCESSNOTRANFLG USERRECORDS CHANGEDRECLST)
          (LOCALFREEVARS BLIP FIELD.ALIST GETHASH.DECLARATION 
                         USINGTYPE USING RECORDECLARATION))
)STOP