(FILECREATED " 6-Nov-84 11:16:45" {ERIS}<LISPNEW>PATCHES>RECORDPATCH.;1 13179
changes to: (VARS RECORDPATCHCOMS)
(FNS \RECORDBLOCK/MAKECREATE1))
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT RECORDPATCHCOMS)
(RPAQQ RECORDPATCHCOMS ((FNS \RECORDBLOCK/MAKECREATE1)))
(DEFINEQ
(\RECORDBLOCK/MAKECREATE1
[LAMBDA (TYPE CREATEINFO NEEDACELL) (* lmm "30-Oct-84 15:39")
(PROG (DEF TEM TEM3 VAL SMASHFIELDS (USINGTYPE USINGTYPE)
BINDINGS
(CKVALFLG T))
(AND HASHLINKS (SETQ NEEDACELL T))
[if (EQ USINGTYPE (QUOTE smashing))
then
(SETQ DEF
(SELECTQ
TYPE
(RECORD (if (LISTP CREATEINFO)
then (\RECORDBLOCK/SMASHPATTERN USINGEXPR CREATEINFO)
else (\RECORDBLOCK/MAKECREATELST CREATEINFO USINGEXPR NEEDACELL)))
[TYPERECORD (\RECORDBLOCK/SMASHPATTERN USINGEXPR CREATEINFO (LIST (QUOTE QUOTE)
(CAR CREATEINFO]
[ARRAYRECORD (SETQ SMASHFIELDS
(DREVERSE (for FIELD in (\RECORDBLOCK/CREATEFIELDS (CDR CREATEINFO))
when (NEQ (SETQ VAL (\RECORDBLOCK/GETFIELDFORCREATE
FIELD USINGEXPR T T USINGTYPE))
MSBLIP)
collect (LIST FIELD VAL]
((ARRAYBLOCK DATATYPE)
(SETQ DEF USINGEXPR)
(for FIELD in (DREVERSE (\RECORDBLOCK/CREATEFIELDS (CADR CREATEINFO)))
when (NEQ (SETQ VAL (\RECORDBLOCK/GETFIELDFORCREATE FIELD USINGEXPR 0 T
USINGTYPE (CADDR
CREATEINFO)))
MSBLIP)
do (SETQ DEF (LIST (COND
((NULL CKVALFLG)
(QUOTE FREPLACEFIELDVAL))
(T (SETQ CKVALFLG)
(QUOTE REPLACEFIELDVAL)))
[KWOTE (CDDR (FASSOC FIELD (CDDDR CREATEINFO]
DEF VAL)))
DEF)
[CCREATE (* a form to be evaluated)
(PROG (FIELD.USAGE [SPECIALFIELDS (COPY (QUOTE ((DATUM CREATE)
(OLDDATUM USING]
(DECLST (QUOTE (FAST)))
VAR1
(SUBSTYPE (QUOTE CREATE)))
[SETQ DEF (\RECORDBLOCK/CSUBST (COND
((EQ TYPE (QUOTE CCREATE))
(EVAL (CAR CREATEINFO)))
(T (CAR CREATEINFO]
[COND
((EQ (CADAR SPECIALFIELDS)
(QUOTE CREATE))
(* if this wasn't an "advice" -- i.e. if didn't do the regular create when we saw DATUM , then need to make sure
that the using/copying/default fields are incorporated)
(SETQ SMASHFIELDS
(for X in FIELDINFO
when (NOT (OR (NULL (CAR X))
(FASSOC (CAR X)
FIELD.USAGE)
(FASSOC (CAR X)
FIELDS.IN.CREATE)
(EQ (SETQ TEM (\RECORDBLOCK/GETFIELDFORCREATE
(CAR X)
USINGEXPR NIL T (SELECTQ
USINGTYPE
(reusing (QUOTE using))
USINGTYPE)))
MSBLIP)))
collect (LIST (CAR X)
TEM]
(RETURN (\RECORDBLOCK/EMBEDPROG DEF]
(GO SMASHING)))
else
(SETQ DEF
(SELECTQ
TYPE
(RECORD (\RECORDBLOCK/MAKECREATELST CREATEINFO USINGEXPR NEEDACELL))
(TYPERECORD (COND
((NEQ MSBLIP (SETQ TEM (\RECORDBLOCK/MAKECREATELST
(CDR CREATEINFO)
(AND USINGEXPR (SETQ TEM3 (LIST (QUOTE CDR)
USINGEXPR)))
NEEDACELL)))
(LIST (QUOTE CONS)
(KWOTE (CAR CREATEINFO))
TEM))
(T MSBLIP)))
[(PROPRECORD ASSOCRECORD)
(SELECTQ USINGTYPE
[(NIL reusing)
(SETQ TEM (for X in (\RECORDBLOCK/CREATEFIELDS CREATEINFO)
when (NEQ [SETQ TEM3 (\RECORDBLOCK/GETFIELDFORCREATE
X USINGEXPR (QUOTE NOTNIL)
T
(AND USINGTYPE (QUOTE reusing]
MSBLIP)
collect (CONS X TEM3]
NIL)
(* \RECORDBLOCK/GETFIELDFORCREATE returns MSBLIP if USINGTYPE = (QUOTE reusing) and the field does not occur.
All other reusing types are handled later, thus USINGTYPE is re-bound)
(* TEM is the list of VALUES specified, where FIELD←VAL is included; plain USING expressions are not, and only
non-nil universal defaults are handled, but explicit defaults are there)
(SELECTQ USINGTYPE
[NIL [COND
((NULL TEM)
(* You cannot create an assocrecord or proprecord with NO fields, since the value would be NIL and you couldn't
smash into it. Thus, a dummy FIELD←NIL is inserted)
(SETQ TEM (LIST (CONS (CAR CREATEINFO)
NIL]
(CONS (QUOTE LIST)
(COND
[(EQ TYPE (QUOTE ASSOCRECORD))
(for X in (DREVERSE TEM)
collect (LIST (QUOTE CONS)
(KWOTE (CAR X))
(CDR X]
(T (for X in (DREVERSE TEM)
join (LIST (KWOTE (CAR X))
(CDR X]
(reusing
(COND
(TEM
(* This says that if you are REUSING an ASSOCRECORD, just CONS the new entries onto the beginning.
This is not good if you do a lot of CREATE REUSING's, but , oh well)
[for X in TEM
do (SETQ USINGEXPR
(SELECTQ TYPE
(ASSOCRECORD (LIST (QUOTE CONS)
(LIST (QUOTE CONS)
(KWOTE (CAR X))
(CDR X))
USINGEXPR))
(PROPRECORD (LIST (QUOTE CONS)
(KWOTE (CAR X))
(LIST (QUOTE CONS)
(CDR X)
USINGEXPR)))
(SHOULDNT]
USINGEXPR)
(NEEDACELL (LIST (QUOTE APPEND)
USINGEXPR))
(T MSBLIP)))
(PROGN (* otherwise, we just copy the "using" expression
appropriately and smash in the fields given in the
create later)
(SELECTQ USINGTYPE
(copying (CONS (FUNCTION COPYALL)
(LIST USINGEXPR)))
(COND
[(EQ TYPE (QUOTE ASSOCRECORD))
(LIST (QUOTE MAPCAR)
USINGEXPR
(QUOTE (FUNCTION (LAMBDA (X)
(CONS (CAR X)
(CDR X]
(T (CONS (FUNCTION APPEND)
(LIST USINGEXPR]
(ATOMRECORD (SELECTQ USINGTYPE
[(NIL reusing)
(SETQ TEM (for X in (\RECORDBLOCK/CREATEFIELDS CREATEINFO)
when (NEQ [SETQ TEM3 (
\RECORDBLOCK/GETFIELDFORCREATE
X USINGEXPR (QUOTE NOTNIL)
T
(AND USINGTYPE (QUOTE reusing]
MSBLIP)
collect (LIST X TEM3]
NIL)
(* \RECORDBLOCK/GETFIELDFORCREATE returns MSBLIP if USINGTYPE = (QUOTE reusing) and the field does not occur.
All other reusing types are handled later, thus USINGTYPE is re-bound)
(* TEM is the list of VALUES specified, where FIELD←VAL is included; plain USING expressions are not, and only
non-nil universal defaults are handled, but explicit defaults are there)
(SETQ DEF (QUOTE (GENSYM)))
(SELECTQ USINGTYPE
(NIL (SETQ SMASHFIELDS TEM)
DEF)
(LIST (QUOTE PROGN)
[LIST (QUOTE SETPROPLIST)
(SETQ DEF (\RECORDBLOCK/RECORDBIND DEF))
(SELECTQ USINGTYPE
[copying
(CONS (FUNCTION COPYALL)
(LIST (LIST (QUOTE GETPROPLIST)
USINGEXPR]
(CONS (FUNCTION APPEND)
(LIST (LIST (QUOTE GETPROPLIST)
USINGEXPR]
DEF)))
(ARRAYRECORD [SETQ SMASHFIELDS
(DREVERSE (for FIELD in (\RECORDBLOCK/CREATEFIELDS (CDR CREATEINFO))
when (NEQ (SETQ VAL (\RECORDBLOCK/GETFIELDFORCREATE
FIELD USINGEXPR T T USINGTYPE))
MSBLIP)
collect (LIST FIELD VAL]
(SELECTQ USINGTYPE
[(using reusing)
(COND
((OR SMASHFIELDS NEEDACELL)
(SETQ SMASHFIELDS)
(SETQ CKVALFLG)
(LIST (QUOTE COPYARRAY)
USINGEXPR))
(T (RETURN MSBLIP]
(copying (SETQ SMASHFIELDS)
(LIST (QUOTE COPYALL)
USINGEXPR))
(NIL (SETQ SMASHFIELDS (SUBSET SMASHFIELDS
(FUNCTION CADR)))
(SETQ CKVALFLG)
(LIST (QUOTE ARRAY)
(CAR CREATEINFO)))
(SHOULDNT)))
((ARRAYBLOCK DATATYPE)
[SETQ DEF (SELECTQ USINGTYPE
(copying (LIST (QUOTE COPYALL)
USINGEXPR))
(COND
[(EQ TYPE (QUOTE ARRAYBLOCK))
(SETQ CKVALFLG)
(COND
(USINGTYPE (LIST (QUOTE COPYARRAY)
USINGEXPR))
(T (LIST (QUOTE ARRAY)
(CAAR CREATEINFO)
(CDAR CREATEINFO]
(T (SETQ CKVALFLG)
(CONS (QUOTE NCREATE)
(CONS (KWOTE (CAR CREATEINFO))
(AND USINGTYPE (LIST USINGEXPR]
(for FIELD in (DREVERSE (\RECORDBLOCK/CREATEFIELDS (CADR CREATEINFO)))
when (NEQ (SETQ VAL (\RECORDBLOCK/GETFIELDFORCREATE FIELD USINGEXPR 0 T
(SELECTQ USINGTYPE
(NIL USINGTYPE)
(QUOTE reusing))
(CADDR CREATEINFO)))
MSBLIP)
do (SETQ DEF (LIST (COND
((NULL CKVALFLG)
(QUOTE FREPLACEFIELDVAL))
(T (SETQ CKVALFLG)
(QUOTE REPLACEFIELDVAL)))
[KWOTE (CDDR (FASSOC FIELD (CDDDR CREATEINFO]
DEF VAL)))
(COND
((AND (NOT NEEDACELL)
(EQ USINGTYPE (QUOTE reusing))
(NEQ (CAR DEF)
(QUOTE FREPLACEFIELD)))
(RETURN MSBLIP)))
DEF)
[(CREATE CCREATE) (* a form to be subst'd or evaluated)
(PROG (FIELD.USAGE [SPECIALFIELDS (COPY (QUOTE ((DATUM CREATE)
(OLDDATUM USING]
(DECLST (QUOTE (FAST)))
VAR1
(SUBSTYPE (QUOTE CREATE)))
[SETQ DEF (\RECORDBLOCK/CSUBST (COND
((EQ TYPE (QUOTE CCREATE))
(EVAL (CAR CREATEINFO)))
(T (CAR CREATEINFO]
[COND
((EQ (CADAR SPECIALFIELDS)
(QUOTE CREATE))
(* if this wasn't an "advice" -- i.e. if didn't do the regular create when we saw DATUM , then need to make sure
that the using/copying/default fields are incorporated)
(SETQ SMASHFIELDS
(for X in FIELDINFO
when (NOT (OR (NULL (CAR X))
(FASSOC (CAR X)
FIELD.USAGE)
(FASSOC (CAR X)
FIELDS.IN.CREATE)
(EQ (SETQ TEM (\RECORDBLOCK/GETFIELDFORCREATE
(CAR X)
USINGEXPR NIL T (SELECTQ USINGTYPE
(reusing
(QUOTE using))
USINGTYPE)))
MSBLIP)))
collect (LIST (CAR X)
TEM]
(RETURN (\RECORDBLOCK/EMBEDPROG DEF]
(\RECORDBLOCK/RECORDERROR (QUOTE CREATE)
TYPE RECORDEXPRESSION]
EXIT[COND
(SMASHFIELDS (PROG (BINDINGS (DECLST (CONS (OR CKVALFLG (QUOTE FAST))
DECLST)))
[SETQ DEF (LIST (SETQ TEM (\RECORDBLOCK/RECORDBINDVAL DEF]
(for X in (DREVERSE SMASHFIELDS)
do (SETQ DEF (CONS (\RECORDBLOCK/MAKEACCESS
(CAR (\RECORDBLOCK/ACCESSDEF4
(LIST (CAR X))
RECORD.TRAN))
TEM
(CDR X)
(QUOTE replace))
DEF))
(FRPLACA DECLST (QUOTE FAST)))
(SETQ DEF (\RECORDBLOCK/EMBEDPROG (MKPROGN DEF]
[RETURN (\RECORDBLOCK/EMBEDPROG (COND
(HASHLINKS (\RECORDBLOCK/MAKEHASHLINKS DEF HASHLINKS))
(T DEF]
SMASHING
(SETQ DEF USINGEXPR)
[SETQ SMASHFIELDS (for FIELD in FIELDINFO collect (LIST (CAR FIELD)
(\RECORDBLOCK/GETFIELDFORCREATE
(CAR FIELD)
NIL T]
(GO EXIT])
)
(PUTPROPS RECORDPATCH COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (330 13097 (\RECORDBLOCK/MAKECREATE1 340 . 13095)))))
STOP