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