Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
(FILECREATED "14-SEP-82 22:18:53" <LISPUSERS>DECL.;13 118747
changes to: (FNS INITDECLTYPES)
previous date: "28-JUN-82 12:44:59" <LISPUSERS>DECL.;12)
(PRETTYCOMPRINT DECLCOMS)
(RPAQQ DECLCOMS [(* DECLTYPE machinery, declaration translator, and declaration enforcer)
(LOCALVARS . T)
(GLOBALVARS FILEPKGFLG CLISPCHANGE CLISPARRAY DWIMESSGAG NOSPELLFLG MSDATABASELST
DECLTYPESARRAY COMMENTFLG CLISPCHARS DECLATOMS LCASEFLG DECLMESSAGES
CLISPRETRANFLG)
(E (RESETSAVE CLISPIFYPRETTYFLG NIL)
(RESETSAVE PRETTYPRINTMACROS (APPEND (QUOTE ((DECL . QUOTE)
(DPROGN . QUOTE)
(DLAMBDA . QUOTE)
(DPROG . QUOTE)))
PRETTYPRINTMACROS)))
(COMS (* Interface to file package)
(FNS DECLTYPE DECLTYPES DUMPDECLTYPES GETDECLDEF)
(FILEPKGCOMS DECLTYPES IGNOREDECL)
(PROP ARGNAMES DECLTYPE))
(* User functions)
(FNS COVERS GETDECLTYPEPROP SETDECLTYPEPROP SUBTYPES SUPERTYPES)
(MACROS SELCOVERSQ SELTYPEQ)
(ALISTS (PRETTYEQUIVLST SELCOVERSQ SELTYPEQ)
(DWIMEQUIVLST SELCOVERSQ SELTYPEQ))
[P (SETSYNONYM (QUOTE (THE TYPE))
(QUOTE (AS A TYPE]
(* Internal machinery)
(DECLARE: DONTCOPY (RECORDS TYPEBLOCK TYPEDEF)
(ALISTS (PRETTYPRINTYPEMACROS TYPEBLOCK)))
(INITRECORDS TYPEBLOCK)
(P (DEFPRINT (QUOTE TYPEBLOCK)
(QUOTE TBDEFPRINT)))
(FNS CHECKTYPEXP COLLECTTYPES COVERSCTYPE COVERSTB COVERSTE CREATEFNPROP CREATEFNVAL
DECLERROR DELETETB FINDDECLTYPE FINDPROP FINDTYPEXP GETCTYPE GETDECLTYPE
GETDECLTYPE.NOERROR GETTBPROP INHERITPROP INITDECLTYPES LCCTYPE LCC2 MAKECTYPE
MAKEDECLTYPE MAKEBINDFN MAKESETFN MAPTYPEUSERS NOTICETB PPDTYPE RECDTYPE
DECLCHANGERECORD RECDEFTYPE REPROPTB SETTBPROP TBDEFPRINT TETYPE TYPEMSANAL TYPEMSANAL1
UNCOMPLETE UNSAVETYPE USERDECLTYPE USESTYPE)
(BLOCKS (LCCTYPE LCCTYPE LCC2)
(TYPEMSANAL TYPEMSANAL TYPEMSANAL1))
(* Test fn creation block)
(FNS MAKETESTFN MAKETESTFNBLOCK COMBINE.TESTS FUNIFY MKNTHCAR MKNTHCDR OF.TESTFN TUPLE.TESTFN
WHOSE.TESTFN)
(BLOCKS (MAKETESTFNBLOCK MAKETESTFNBLOCK COMBINE.TESTS FUNIFY MKNTHCAR MKNTHCDR OF.TESTFN
TUPLE.TESTFN WHOSE.TESTFN))
(* Machinery to compile recursive testfns)
(FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
LABEL)
(* Idioms. Expressed as macros for now)
(DECLARE: DONTCOPY EVAL@COMPILE (VARS DefaultBindFn DefaultSetFn)
(ADDVARS (NLAMA MAKEDECLTYPEQ))
(MACROS ANYC DECLVARERROR DTYPENAME foreachTB GETCGETD KWOTEBOX LAMBIND LAMVAL
MAKEDECLTYPEQ NONEC TESTFORM)
(FNS TESTFORM)
(ADDVARS (DONTCOMPILEFNS TESTFORM))
(TEMPLATES foreachTB MAKEDECLTYPEQ))
(* Runtime utility functions)
(FNS EVERYCHAR LARGEP DECLRECURSING SMASHCAR)
(DECLARE: EVAL@COMPILE (MACROS LARGEP))
(DECLARE: DONTCOPY EVAL@COMPILE (MACROS SMASHCAR))
(* translator of dprogs and dlambdas)
(FNS ASSERT ASSERTFAULT ASSERTMAC *DECL *DECLMAC CHKINIT CHKINITMAC DECLCONSTANTP DD
DECLCLISPTRAN DECLMSG DECLDWIMERROR DECLDWIMTESTFN DECLSET DECLSETQ DECLSETQQ DECLTRAN
DECLVAR DLAMARGLIST DTYPE?TRAN EDITNEWSATLIST FORMUSESTB IGNOREDECL MAKETESTFORM PPDECL
PPVARLIST SETQMAC THETRAN VALUEERROR VARASRT VARASRT1 VARSETFN)
(BLOCKS (DECLTRAN DECLTRAN DECLVAR)
(PPDECL PPDECL PPVARLIST)
(VARASRT VARASRT VARASRT1))
(* Declaration database fns)
(FNS DECLOF DECLOF1 TBOF TYPEBLOCKOF VARDECL)
(BLOCKS (DECLOFBLK DECLOF DECLOF1 TBOF TYPEBLOCKOF VARDECL (ENTRIES DECLOF TYPEBLOCKOF)))
(* Enabling and disabling fns)
(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS FNEQUIVS)
(MACROS MOVEPROP PUTIFPROP))
(FNS STARTDECLS DODECLS)
(FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
LAMBDATRAN)
(DECLARE: EVAL@COMPILE (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
SIMPLIFY))
[DECLARE: EVAL@COMPILE DONTCOPY (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
NOBOX)
(* Definition of WITH. From <SHEIL>WITH.)
(MACROS WITH)
(TEMPLATES WITH)
(P (REMPROP (QUOTE WITH)
(QUOTE CLISPWORD))
(ADDTOVAR DWIMEQUIVLST (WITH . PROG))
(ADDTOVAR PRETTYEQUIVLST (WITH . PROG]
[P (OR (GETPROP (QUOTE LOADTIMECONSTANT)
(QUOTE FILEDATES))
(PROG ((X (FINDFILE (QUOTE LOADTIMECONSTANT.COM)
T LISPUSERSDIRECTORIES)))
(COND (X (LOAD X (QUOTE SYSLOAD)))
((NOT (GETPROP (QUOTE LOADTIMECONSTANT)
(QUOTE MACRO)))
(PUTPROP (QUOTE LOADTIMECONSTANT)
(QUOTE MACRO)
(QUOTE ((FORM)
(CONSTANT FORM]
(ADDVARS (OPENFNS DECLPROGN CHKVAL CHKINIT ASSERT *DECL VARASRT))
(PROP CLISPWORD DPROG DPROGN THE the)
(PROP INFO DLAMBDA DPROG DPROGN)
(VARS (SATISFIESLIST)
(CSATISFIESLIST)
(NEWSATLIST T))
[ADDVARS (DECLATOMS DLAMBDA DPROG DPROGN)
(LAMBDASPLST DLAMBDA)
(DECLMESSAGES)
(COMPILEIGNOREDECL)
(SYSLOCALVARS VALUE)
[DESCRIBELST ("types: " (GETRELATION FN (QUOTE (USE TYPE]
(BAKTRACELST (DECLPROGN (DPROGN APPLY
*PROG*LAM *DECL *ENV*)
(NIL APPLY *PROG*LAM *DECL))
(PROG (DPROG DECLPROGN
APPLY
*PROG*LAM
*DECL)]
(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS SLISTENTRY VARDECL))
(ALISTS (LAMBDATRANFNS DLAMBDA))
[DECLARE: DONTEVAL@LOAD (E (* Declare is so PRETTYPRINTMACROS don't get set up during
LOADFROM, when PPDECL is not being defined. Don't use ALIST for
print macros cause entries are removed while DECL is being
dumped))
(ADDVARS (PRETTYPRINTMACROS (DPROGN . PPDECL)
(DECL . PPDECL)
(DLAMBDA . PPDECL)
(DPROG . PPDECL]
(PROP INFO ASSERT)
(MACROS ASSERT .CBIND. CHKINIT CHKVAL *DECL DECL DECLMSGMAC REALSETQ)
(MACROS REALSET)
[P (AND (GETD (QUOTE STARTDECLS))
(STARTDECLS))
(PROG [(COM (CDR (ASSOC (QUOTE DW)
EDITMACROS]
(AND COM (RPLACD COM (CONS (APPEND (QUOTE (RESETVAR NEWSATLIST (EDITNEWSATLIST)))
(CDR COM]
(* Builtin DECLOF properties)
(PROP DECLOF APPEND CONS EQ LIST LISTP NCONC)
[DECLARE: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG NIL)
(AND (GETD (QUOTE DODECLS))
(RESETSAVE (DODECLS)
(QUOTE (DODECLS T]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA DECLSETQ DECLMSG DD CHKINIT *DECL ASSERT DECLTYPES DECLTYPE)
(NLAML DECLSETQQ TYPEMSANAL)
(LAMA DECLDWIMERROR])
(* DECLTYPE machinery, declaration translator, and declaration enforcer)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS FILEPKGFLG CLISPCHANGE CLISPARRAY DWIMESSGAG NOSPELLFLG MSDATABASELST
DECLTYPESARRAY COMMENTFLG CLISPCHARS DECLATOMS LCASEFLG DECLMESSAGES CLISPRETRANFLG)
)
(* Interface to file package)
(DEFINEQ
(DECLTYPE
[NLAMBDA X (* bas: " 7-NOV-79 16:22")
(USERDECLTYPE (CAR X)
(CADR X)
(CDDR X])
(DECLTYPES
[NLAMBDA DTS (* bas: " 7-NOV-79 16:24")
(* Defines a list of decltypes)
(for D in DTS collect (USERDECLTYPE (CAR D)
(CADR D)
(CDDR D])
(DUMPDECLTYPES
[LAMBDA (TL) (* rmk: " 7-SEP-81 04:50")
(WITH [[TWOFLG (OR (NLISTP TL)
(LISTP (CDR TL]
(FFLG (NEQ T (OUTPUT] (* Don't do the plural and extra parens if only one, and don't do the
EVAL@COMPILE stuff if going to T=SHOWDEF)
(if FFLG
then (printout NIL T "(DECLARE: EVAL@COMPILE" T T))
(printout NIL (if TWOFLG
then "(DECLTYPES"
else "(DECLTYPE "))
(for D in TL do (if TWOFLG
then (printout NIL 11 "("))
[if (LISTP D)
then (printout NIL .P2 (CAR D)
, .P2 (CAR D)
, .P2 (CADR D)
, .PPV (GETDECLTYPEPROP (CAR D)
(CADR D)))
else [SETQ D (CDR (GETDECLDEF D NIL (QUOTE NOCOPY]
(printout NIL .P2 (CAR D)
,)
(for TAIL (POS _(POSITION)) on (CDDR D) by (CDDR TAIL)
first (PRINTDEF (CADR D)
POS)
do (printout NIL .TAB POS .P2 (CAR TAIL)
, .PPF (CADR TAIL]
(if TWOFLG
then (printout NIL ")")))
(printout NIL ")" T)
(if FFLG
then (printout NIL ")" T])
(GETDECLDEF
[LAMBDA (NAME FPTYPE OPTIONS) (* bas: " 9-OCT-79 23:04")
(* This is the GETDEF function for DECLTYPE.
FPTYPE is the file-package-type argument, which we ignore.)
(WITH ((TB (FINDDECLTYPE NAME))
(NOCOPYP (EQMEMB (QUOTE NOCOPY)
OPTIONS)))
(if TB
then [CONS (QUOTE DECLTYPE)
(CONS NAME (CONS (WITH ((TE (fetch TYPEXP of TB)))
(if NOCOPYP
then TE
else (COPY TE)))
(WITH ((TP (fetch PROPS of TB)))
(if NOCOPYP
then TP
else (COPY TP]
elseif (EQMEMB (QUOTE NOERROR)
OPTIONS)
then NIL
else (DECLERROR NAME "is not a DECLTYPE"])
)
(PUTDEF (QUOTE DECLTYPES) (QUOTE FILEPKGCOMS) [QUOTE ([COM MACRO (X (E (DUMPDECLTYPES (QUOTE X]
(TYPE DESCRIPTION "type declarations" GETDEF
GETDECLDEF DELDEF
(LAMBDA (NAME)
(DELETETB (OR (FINDDECLTYPE
NAME)
(DECLERROR
"Can't delete non-existent type:"
NAME])
(PUTDEF (QUOTE IGNOREDECL) (QUOTE FILEPKGCOMS) [QUOTE
((COM MACRO
(X (DECLARE: DOEVAL@COMPILE DONTEVAL@LOAD
DONTCOPY
(P (RESETSAVE COMPILEIGNOREDECL
(QUOTE X])
(PUTPROPS DECLTYPE ARGNAMES (NIL (NAME TYPE PROP1 VAL1 ...) . X))
(* User functions)
(DEFINEQ
(COVERS
[LAMBDA (HI LO) (* bas: "16-OCT-79 11:22")
(AND (COVERSTB (GETDECLTYPE HI)
(GETDECLTYPE LO))
T])
(GETDECLTYPEPROP
[LAMBDA (TYPE PROP) (* bas: " 9-OCT-79 22:56")
(GETTBPROP (GETDECLTYPE TYPE)
PROP])
(SETDECLTYPEPROP
[LAMBDA (NAME PROP VAL) (* rmk: " 2-AUG-81 08:41")
(OR (LITATOM NAME)
(DECLERROR "Can't set property of non-atomic type:" NAME))
(REPROPTB (OR (FINDDECLTYPE NAME)
(DECLERROR "Can't set property of non-existent type:" NAME))
(LIST PROP VAL))
(MARKASCHANGED (LIST NAME PROP)
(QUOTE DECLTYPES))
VAL])
(SUBTYPES
[LAMBDA (NAME) (* bas: "16-OCT-79 18:59")
(PROG (TYPES CT (BT (GETDECLTYPE NAME)))
(DECLARE (SPECVARS TYPES CT))
(SETQ CT (GETCTYPE BT))
(if (NONEC CT)
elseif (EQ (CAR (fetch TYPEXP of BT))
(QUOTE ONEOF))
then [RETURN (APPEND (CDR (fetch TYPEXP of BT]
else [foreachTB S (AND (LITATOM (fetch NAME of S))
(FMEMB CT (GETCTYPE S))
(push TYPES (fetch NAME of S]
(RETURN (OR TYPES (LIST (QUOTE NONE])
(SUPERTYPES
[LAMBDA (NAME) (* bas: "16-OCT-79 18:20")
(PROG (TYPES (CN (GETCGETD NAME)))
(DECLARE (SPECVARS TYPES CN))
[if (ANYC CN)
then NIL
else (foreachTB TB (AND (LITATOM (fetch NAME of TB))
(if (NONEC CN)
then (* Very expensive, but kinda wierd)
(NULL (SUBTYPES (fetch NAME of TB)))
else (* Any sups will be complete so we dont need to complete here)
(FMEMB (fetch CTYPE of (fetch DEF of TB))
CN))
(push TYPES (fetch NAME of TB]
(RETURN TYPES])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS SELCOVERSQ MACRO [F (LIST [LIST (QUOTE LAMBDA)
(QUOTE ($$TMP))
(CONS (QUOTE COND)
(MAPLIST (CDR F)
(FUNCTION (LAMBDA (I)
(COND
((CDR I)
(CONS (LIST (QUOTE COVERS)
(KWOTE (CAAR I))
(QUOTE $$TMP))
(CDAR I)))
(T (LIST T (CAR I]
(LIST (QUOTE DECLOF)
(CAR F])
(PUTPROPS SELTYPEQ MACRO (F (APPLYFORM [LIST (QUOTE LAMBDA)
(QUOTE ($$TMP))
(CONS (QUOTE COND)
(MAPLIST (CDR F)
(FUNCTION (LAMBDA (I)
(COND
((CDR I)
(CONS (LIST (QUOTE TYPE?)
(CAAR I)
(QUOTE $$TMP))
(CDAR I)))
(T (LIST T (CAR I]
(CAR F))))
)
(ADDTOVAR PRETTYEQUIVLST (SELCOVERSQ . SELECTQ)
(SELTYPEQ . SELECTQ))
(ADDTOVAR DWIMEQUIVLST (SELCOVERSQ . SELECTQ)
(SELTYPEQ . SELECTQ))
(SETSYNONYM (QUOTE (THE TYPE))
(QUOTE (AS A TYPE)))
(* Internal machinery)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(DATATYPE TYPEBLOCK (NAME DEF BF SF TF PROPS)
[ACCESSFNS TYPEBLOCK ([TYPEXP (fetch TEXP of (fetch DEF of DATUM))
(replace DEF of DATUM with (create TYPEDEF
TEXP _(COPY
NEWVALUE]
(BINDFN (OR (fetch BF of DATUM)
(MAKEBINDFN DATUM))
(replace BF of DATUM with NEWVALUE))
(SETFN (OR (fetch SF of DATUM)
(MAKESETFN DATUM))
(replace SF of DATUM with NEWVALUE))
(TESTFN (OR (fetch TF of DATUM)
(MAKETESTFN DATUM))
(replace TF of DATUM with NEWVALUE]
[CCREATE (PROGN (OR (FASSOC (QUOTE NAME)
FIELDS.IN.CREATE)
(HELP "No NAME field in TYPEBLOCK create"))
(OR (FASSOC (QUOTE TYPEXP)
FIELDS.IN.CREATE)
(FASSOC (QUOTE DEF)
FIELDS.IN.CREATE)
(HELP "No type expression in TYPEBLOCK create"))
(LIST (QUOTE NOTICETB)
(QUOTE DATUM)
(CADR (FASSOC (QUOTE NAME)
FIELDS.IN.CREATE])
(RECORD TYPEDEF (TEXP . CTYPE))
]
(/DECLAREDATATYPE (QUOTE TYPEBLOCK)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER)))
(ADDTOVAR PRETTYPRINTYPEMACROS (TYPEBLOCK . PPDTYPE))
)
(/DECLAREDATATYPE (QUOTE TYPEBLOCK)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER)))
(DEFPRINT (QUOTE TYPEBLOCK)
(QUOTE TBDEFPRINT))
(DEFINEQ
(CHECKTYPEXP
[LAMBDA (TE) (* bas: "18-OCT-79 16:58")
(* Checks that a type expression is structurally valid)
(OR (TETYPE TE)
(DECLERROR "Invalid type expression" TE])
(COLLECTTYPES
[LAMBDA (TYPES MERGE) (* bas: " 9-OCT-79 22:53")
(* Converts a list of type names into a list of typeblocks merging together those that lie on the same sup-sub chain to the highest or
lowest member of that chain as specified by MERGE)
(for SCR I VAL in TYPES eachtime (SETQ I (GETDECLTYPE SCR))
unless [for J in VAL thereis (OR (EQ I J)
(SELECTQ MERGE
(UP (COVERSTB J I))
(DOWN (COVERSTB I J))
(SHOULDNT]
do (SETQ VAL (CONS I VAL)) (* Add to VAL unless dominated by an already existing entry)
finally (* Walk back down list throwing out anything that is dominated by a
subsequent addition)
(SETQ SCR VAL)
(SETQ VAL NIL)
[while SCR do (SETQ SCR (PROG1 (CDR SCR)
(if (for J in VAL
never (SELECTQ MERGE
(UP (COVERSTB J (CAR SCR)))
(DOWN (COVERSTB (CAR SCR)
J))
(SHOULDNT)))
then (RPLACD SCR VAL)
(SETQ VAL SCR]
(RETURN VAL])
(COVERSCTYPE
[LAMBDA (H L) (* bas: "11-OCT-79 11:35")
(* COVERS for CTYPEs)
(PROG NIL (* We use a PROG so we can chase singleton supertypes which are the
common case by looping rather than recursion.)
LP (if (EQ H L)
then (RETURN T)
elseif (NLISTP L)
then (RETURN (NONEC L)) (* Either we had NONE to start or we have arrived at ANY)
elseif (CDR L)
then (RETURN (for I in L thereis (COVERSCTYPE H I)))
else (SETQ L (CAR L)) (* Single supertype)
(GO LP])
(COVERSTB
[LAMBDA (H L) (* bas: "19-OCT-79 17:40")
(* COVERS for type blocks. COVERSTE gets some cases that are difficult
from the lattice.)
(OR (EQ H L)
(COVERSCTYPE (GETCTYPE H)
(GETCTYPE L))
(COVERSTE (fetch TYPEXP of H)
(fetch TYPEXP of L])
(COVERSTE
[LAMBDA (H L) (* bas: "31-OCT-79 14:34")
(* COVERS for type expressions. We pick off MEMQ and ONEOFs here
because they cannot be efficiently linked into the type lattice.)
(SELECTQ (TETYPE H)
[ONEOF (SELECTQ (TETYPE L)
[ONEOF (for I in (CDR L) always (for J in (CDR H)
thereis (COVERS J I]
(for I in (CDR H) thereis (COVERS I L]
(MEMQ (SELECTQ (TETYPE L)
[MEMQ (for I in (CDR L) always (MEMBER I (CDR H]
NIL))
NIL])
(CREATEFNPROP
[LAMBDA (PL PN) (* bas: " 7-NOV-79 16:51")
(* If a value for prop PN appears on PL, CREATEFNVAL it.
NIL will indicate that no specification has yet been made.)
(WITH ((PE (FINDPROP PL PN)))
(AND PE (CREATEFNVAL (CADR PE)
PN])
(CREATEFNVAL
[LAMBDA (FVAL FNAME) (* bas: " 7-NOV-79 16:53")
(* Gets given a purported FNVAL. If that value is NIL, use the default.
Dwimify a list value.)
(DECLARE (USEDFREE DWIMFLG))
(if FVAL
then (AND DWIMFLG (LISTP FVAL)
(DWIMIFY FVAL T))
FVAL
else (SELECTQ FNAME
(BINDFN (CONSTANT DefaultBindFn))
(SETFN (CONSTANT DefaultSetFn))
NIL])
(DECLERROR
[LAMBDA (MSG1 MSG2) (* bas: "25-NOV-78 18:25")
(if (BOUNDP (QUOTE DECLERROR))
then (SETQ DECLERROR T)
(ERROR!)
else (ERROR MSG1 MSG2])
(DELETETB
[LAMBDA (TB) (* rmk: "19-AUG-81 00:15")
(* Dissasociates TB from its name and undoes any dependencies on it)
(WITH ((NAME (fetch NAME of TB)))
(SELECTQ NAME
((ANY NONE)
(DECLERROR "(Futile) attempt to delete" NAME))
NIL)
(UNSAVETYPE TB) (* Unsave dependent code)
(UNCOMPLETE TB) (* Undo the cached values and dependent types)
(NOTICETB NIL NAME) (* Snap name association)
(replace NAME of TB with (PACK* (QUOTE Deleted)
NAME])
(FINDDECLTYPE
[LAMBDA (TE) (* bas: "10-OCT-79 01:46")
(* Finds the existing typeblock for a type expression if any)
(if (LISTP TE)
then (* TE must be in CLISPARRAY to detect edits of the type expression)
(AND (GETHASH TE CLISPARRAY)
(GETHASH TE DECLTYPESARRAY))
else (OR (GETHASH TE DECLTYPESARRAY)
(RECDTYPE TE])
(FINDPROP
[LAMBDA (L P) (* bas: "23-MAR-79 14:41")
(for old L by (CDDR L) while L thereis (EQ P (CAR L])
(FINDTYPEXP
[LAMBDA (TYPE) (* bas: "16-OCT-79 14:17")
(* Tries to find an equivalent TYPEBLOCK for the expression TYPE)
(DECLARE (SPECVARS TYPE))
(foreachTB TB (if (AND (LISTP (fetch NAME of TB))
(EQUAL TYPE (fetch TYPEXP of TB)))
then (OR (EQUAL TYPE (fetch NAME of TB))
(replace NAME of TB with TYPE))
(* NAME has been edited)
(NOTICETB TB TYPE) (* Remember this path)
(RETFROM (QUOTE FINDTYPEXP)
TB)))
NIL])
(GETCTYPE
[LAMBDA (TB) (* rmk: "29-NOV-81 14:33")
(OR (fetch CTYPE of (fetch DEF of TB))
(if (DECLRECURSING (QUOTE GETCTYPE)
TB)
then (DECLERROR "Invalid recursive type definition" (fetch TYPEXP of TB)))
(replace CTYPE of (fetch DEF of TB) with (MAKECTYPE (fetch TYPEXP of TB])
(GETDECLTYPE
[LAMBDA (TE VARNAME) (* bas: "18-OCT-79 15:38")
(* Either finds a typeblock with TE as its type expression or creates one. We smuggle the name thru in the PROPS field as anyone who
specifies a VARNAME is unnamed so neither has nor can acquire any properties.)
(OR (FINDDECLTYPE TE)
(AND (LISTP TE)
(OR (FINDTYPEXP TE)
(MAKEDECLTYPE TE TE VARNAME)))
(DECLERROR TE "is not a DECLTYPE"])
(GETDECLTYPE.NOERROR
[LAMBDA (TE VAR) (* bas: "19-OCT-79 16:05")
(* Makes and completes a typeblock for TE suppressing
any DECLERRORs)
(WITH ((DECLERROR))
(DECLARE (SPECVARS DECLERROR))
(OR (CAR (ERSETQ (WITH ((TB (GETDECLTYPE TE VAR)))
(* Force completion so any errors will happen now under
the ERSETQ)
(GETCTYPE TB)
(fetch TESTFN of TB)
TB)))
(COND
(DECLERROR NIL)
(T (ERROR!])
(GETTBPROP
[LAMBDA (TB P) (* bas: "15-AUG-79 23:49")
(SELECTQ P
(BINDFN (fetch BINDFN of TB))
(SETFN (fetch SETFN of TB))
(TESTFN (fetch TESTFN of TB))
(WITH ((PL (FINDPROP (fetch PROPS of TB)
P)))
(if PL
then (CADR PL)
else (INHERITPROP TB P])
(INHERITPROP
[LAMBDA (TB PROP) (* bas: "19-OCT-79 16:45")
(* Determines how types inherit their properties on the basis of the
way they were formed from other types)
(WITH ((TE (fetch TYPEXP of TB)))
(AND (LISTP TE)
(GETDECLTYPEPROP (SELECTQ (TETYPE TE)
[(ALLOF ONEOF)
(WITH ((V (GETDECLTYPEPROP (CADR TE)
PROP))
(ANYVAL (GETDECLTYPEPROP (QUOTE ANY)
PROP)))
(RETFROM (QUOTE INHERITPROP)
(if [OR (EQ V ANYVAL)
(for I in (CDDR TE)
always
(EQ V (GETDECLTYPEPROP I PROP]
then V
else ANYVAL]
((OF SATISFIES WHOSE)
(CAR TE))
[MEMQ (CONS (QUOTE ONEOF)
(for I in (CDR TE) collect (DTYPENAME I]
(SHARED (if (EQ PROP (QUOTE BINDFN))
then (RETFROM (QUOTE INHERITPROP)
(CONSTANT DefaultBindFn))
else (CADR TE)))
((SUBTYPE SYNONYM)
(CADR TE))
(TUPLE (QUOTE LISTP))
(QUOTE ANY))
PROP])
(INITDECLTYPES
[LAMBDA NIL (* rmk: "14-SEP-82 22:17")
(* Initializes DECLTYPES hash array)
[COND
((BOUNDP (QUOTE DECLTYPESARRAY))
(CLRHASH DECLTYPESARRAY))
(T (SETQ DECLTYPESARRAY (CONS (HARRAY 128)
128]
(FILEPKGCHANGES (QUOTE DECLTYPES)
NIL) (* Make FILEPKG forget about any types it may have
noticed.)
(RESETVARS (FILEPKGFLG)
[for I in (QUOTE (ANY NONE)) do (create TYPEBLOCK
NAME _ I
DEF _(create TYPEDEF
TEXP _ I
CTYPE _ I)
BINDFN _(CONSTANT DefaultBindFn)
SETFN _(CONSTANT DefaultSetFn)
TESTFN _(LAMVAL (EQ I (QUOTE ANY]
(* ANY and NONE are created complete)
(MAKEDECLTYPEQ ARRAYP (SUBTYPE ANY)
(TESTFN ARRAYP))
(MAKEDECLTYPEQ HARRAYP (SUBTYPE ARRAYP)
(TESTFN HARRAYP))
(MAKEDECLTYPEQ LISTP (SUBTYPE ANY)
(TESTFN LISTP EVERYFN EVERY))
[MAKEDECLTYPEQ HASHARRAY (ONEOF HARRAYP (LISTP (WHOSE (CAR HARRAYP]
(MAKEDECLTYPEQ READTABLEP (SUBTYPE ARRAYP)
(TESTFN READTABLEP))
(MAKEDECLTYPEQ ATOM (SUBTYPE ANY)
(TESTFN ATOM))
(MAKEDECLTYPEQ LITATOM (SUBTYPE ATOM)
(TESTFN LITATOM))
(MAKEDECLTYPEQ BOOL (MEMQ NIL T))
(MAKEDECLTYPEQ NUMBERP (SUBTYPE ATOM)
(TESTFN NUMBERP))
(MAKEDECLTYPEQ FIXP (SUBTYPE NUMBERP)
(TESTFN FIXP))
[MAKEDECLTYPEQ CARDINAL (FIXP (SATISFIES (IGEQ VALUE 0]
(MAKEDECLTYPEQ SMALLP (SUBTYPE FIXP)
(TESTFN SMALLP))
(MAKEDECLTYPEQ LARGEP (SUBTYPE FIXP)
(TESTFN LARGEP))
(MAKEDECLTYPEQ FLOATP (SUBTYPE NUMBERP)
(TESTFN FLOATP))
(MAKEDECLTYPEQ FUNCTION (SUBTYPE ANY)
(TESTFN FNTYP))
(MAKEDECLTYPEQ NIL (MEMQ NIL)
(TESTFN NULL))
(MAKEDECLTYPEQ LST (ONEOF LISTP NIL)
(EVERYFN EVERY))
(MAKEDECLTYPEQ ALIST (LST OF LISTP))
(MAKEDECLTYPEQ STACKP (SUBTYPE ANY)
(TESTFN STACKP))
(MAKEDECLTYPEQ STRINGP (SUBTYPE ANY)
(TESTFN STRINGP EVERYFN EVERYCHAR])
(LCCTYPE
[LAMBDA (TL) (* bas: "18-SEP-79 17:24")
(* Returns the lowest common ctype for the type names in
TL)
(WITH [(C1 (GETCGETD (CAR TL]
(if (CDR TL)
then (LCC2 C1 (LCCTYPE (CDR TL)))
else C1])
(LCC2
[LAMBDA (A B) (* bas: "10-OCT-79 19:12")
(* Returns the lcd of A and B)
(if (COVERSCTYPE A B)
then A
elseif (COVERSCTYPE B A)
then B
else (for I C in A do (WITH ((D (LCC2 I B)))
(if (OR (NULL C)
(COVERSCTYPE C D))
then (SETQ C D)))
finally (RETURN C])
(MAKECTYPE
[LAMBDA (TE) (* bas: "31-OCT-79 16:44")
(* Computes the real sup types of TE)
(SELECTQ (TETYPE TE)
[ALLOF (WITH [(S (COLLECTTYPES (CDR TE)
(QUOTE DOWN]
(if (CDR S)
then (SMASHCAR S (FUNCTION GETCTYPE))
else (* They are all on the same path)
(GETCTYPE (CAR S]
[ONEOF (WITH [(S (COLLECTTYPES (CDR TE)
(QUOTE UP]
(* Rather than having the subtypes point to this new ctype, we pick that case up in COVERS to avoid making the supertype structure
bushy.)
(if (CDR S)
then (LIST (LCCTYPE (CDR TE)))
else (* All on the same path)
(GETCTYPE (CAR S]
((SHARED SYNONYM)
(GETCGETD (CADR TE)))
(LIST (SELECTQ (TETYPE TE)
[MEMQ (LCCTYPE (for I in (CDR TE) scratchcollect (DTYPENAME I]
(GETCGETD (SELECTQ (TETYPE TE)
((OF SATISFIES WHOSE)
(CAR TE))
(SUBTYPE (CADR TE))
(TUPLE (if (CDR TE)
then (QUOTE LISTP)
else (QUOTE NIL)))
(SHOULDNT])
(MAKEDECLTYPE
[LAMBDA (NAME DECL PROPS) (* bas: " 7-NOV-79 16:33")
(* Defines the type specified by the type expression DECL)
(CHECKTYPEXP DECL) (* Provides an early check on well formedness)
(WITH [(TB (create TYPEBLOCK
NAME _ NAME
TYPEXP _ DECL
PROPS _(COPY PROPS]
(if (LISTP PROPS)
then (replace BINDFN of TB with (CREATEFNPROP PROPS (QUOTE BINDFN)))
(replace SETFN of TB with (CREATEFNPROP PROPS (QUOTE SETFN)))
(replace TESTFN of TB with (CREATEFNPROP PROPS (QUOTE TESTFN)))
(CREATEFNPROP PROPS (QUOTE EVERYFN)))
TB])
(MAKEBINDFN
[LAMBDA (TB) (* bas: "18-OCT-79 18:17")
(* Finds a BINDFN for TB)
(replace BINDFN of TB with (INHERITPROP TB (QUOTE BINDFN])
(MAKESETFN
[LAMBDA (TB) (* bas: "18-OCT-79 21:17")
(* Finds a SETFN for TB)
(replace SETFN of TB with (INHERITPROP TB (QUOTE SETFN])
(MAPTYPEUSERS
[LAMBDA (NAME FN) (* bas: "28-AUG-79 22:18")
(DECLARE (SPECVARS . T))
(foreachTB TB (AND (USESTYPE NAME (fetch TYPEXP of TB))
(APPLY* FN TB])
(NOTICETB
[LAMBDA (TBLOCK TEXP) (* rmk: " 7-SEP-81 03:26")
(* Enters hash links so TBLOCK can be found given type expression TEXP)
(if (LISTP TEXP)
then (PUTHASH TEXP TEXP CLISPARRAY) (* Access name is also in CLISPARRAY to detect changes)
)
(PUTHASH TEXP TBLOCK DECLTYPESARRAY])
(PPDTYPE
[LAMBDA (TYPE) (* bas: "18-OCT-79 17:57")
(* PPs typeblock, completing unless NOCOMPFLG)
(WITH [(LM (IPLUS 4 (POSITION)))
(TB (if (type? TYPEBLOCK TYPE)
then TYPE
else (GETDECLTYPE TYPE]
(printout NIL "DECLTYPE: " (fetch NAME of TB)
" = "
(OR (fetch TYPEXP of TB)
"No type expression"))
(printout NIL .TAB LM "Suptypes: ")
(if (fetch CTYPE of (fetch DEF of TB))
then (for I in (GETCTYPE TB) declare (SPECVARS I)
do (printout NIL .TAB0 (IPLUS LM 10))
(* Start each new suptype list on a new line)
(foreachTB S (AND (EQ I (fetch CTYPE of (fetch DEF of S)))
(printout NIL (fetch NAME of S)
,)))
(* Dont force a completion to get the CTYPE)
)
else (printout NIL "... not completed..."))
(if (fetch BF of TB)
then (printout NIL .TAB LM "Bindfn: " .PPF (fetch BF of TB)))
(if (fetch SF of TB)
then (printout NIL .TAB LM "Setfn: " .PPF (fetch SF of TB)))
(if (fetch TF of TB)
then (printout NIL .TAB LM "Testfn: " .PPF (fetch TF of TB)))
[if (fetch PROPS of TB)
then (printout NIL .TAB LM "Property: ")
(for P on (fetch PROPS of TB) by (CDDR P) do (printout NIL .TAB0 (IPLUS LM 10)
(CAR P)
" = " .P2 (CADR P]
(TERPRI)
TB])
(RECDTYPE
[LAMBDA (R) (* rmk: " 6-SEP-81 04:29")
(WITH [RDECL TB (TST (LIST (QUOTE type?)
R
(CONS (QUOTE NILL] (* The CONS produces a unique, dwim-immune object to give RECORDTRAN to
dwimify. We can then substitute for it to build the testfn.)
(COND
([RESETVARS (CLISPCHANGE (DWIMESSGAG T)) (* CLISPCHANGE bound cause RECORDTRAN sets it)
(* If the record package translation bombs, simply return NIL to
GETDECLTYPE, which might then print an error message.)
(RETURN (NLSETQ (RECORDTRAN TST (QUOTE DTYPE?TRAN]
(SETQ RDECL (RECLOOK R))
[SETQ TB (create TYPEBLOCK
NAME _ R
TYPEXP _(LIST (QUOTE SUBTYPE)
(RECDEFTYPE RDECL]
(* Use SETTBPROP to store TESTFN rather than doing it in the create, so that it also shows up on the property list.
Then the decltype will print with all its info.)
[SETTBPROP TB (QUOTE TESTFN)
(LAMVAL (LIST COMMENTFLG (QUOTE ASSERT:)
(LIST (QUOTE RECORD)
R))
(SUBST (QUOTE VALUE)
(CADDR TST)
(PROG1 (GETHASH TST CLISPARRAY)
(PUTHASH TST NIL CLISPARRAY]
(* The record package stores the DECL form in 9th car of the
translation)
(for X on (CDAR (FNTH (GETHASH RDECL CLISPARRAY)
9))
by (CDDR X) do (SETTBPROP TB (CAR X)
(CADR X)))
TB])
(DECLCHANGERECORD
[LAMBDA (RNAME RFIELDS OLDFLG) (* rmk: " 7-SEP-81 04:17")
(* CHANGERECORD is the default value of RECORDCHANGEFN, which is applied by RECREDECLARE. This makes sure that a record change wipes out
a dependent decltype)
(REALCHANGERECORD RNAME RFIELDS OLDFLG)
(AND OLDFLG (WITH (TEMP (TB (GETHASH RNAME DECLTYPESARRAY)))
(* This is a marginal guess at the dependency: we would be wrong if the user had, e.g., dumped a record-derived decltype and loaded it
into a system without the record.)
(if (AND TB (SETQ TEMP (fetch TESTFN of TB))
[EQ COMMENTFLG (CAR (SETQ TEMP (CADDR TEMP]
(EQ (CADR TEMP)
(QUOTE ASSERT:))
(EQ (CAR (SETQ TEMP (CADDR TEMP)))
(QUOTE RECORD))
(EQ RNAME (CADR TEMP)))
then (DELETETB TB])
(RECDEFTYPE
[LAMBDA (RD) (* bas: "21-SEP-79 14:53")
(* Computes the DECLOF type corresponding to a record package type
expression)
(SELECTQ (CAR RD)
[ACCESSFNS (WITH ((CRF (FASSOC (QUOTE CREATE)
RD)))
(if CRF
then (DECLOF (CADR CRF))
else (QUOTE ANY]
(ARRAYRECORD (QUOTE ARRAYP))
(ASSOCRECORD (QUOTE ALIST))
(ATOMRECORD (QUOTE LITATOM))
(DATATYPE (if (LISTP (CADR RD))
then (CADADR RD)
else (QUOTE ANY)))
(HASHLINK (QUOTE HARRAYP))
(PROPRECORD (QUOTE LST))
[RECORD (WITH ((FLDS (CADDR RD)))
(if (LISTP FLDS)
then (QUOTE LST)
elseif [AND FLDS (EQ FLDS (CADR (FASSOC (QUOTE SUBRECORD)
RD]
then (* The declaration has a top-level field equal to the subrecord name)
FLDS
else (QUOTE ANY]
(TYPERECORD (QUOTE LISTP))
(QUOTE ANY])
(REPROPTB
[LAMBDA (TB PROPS INHERITING) (* bas: " 7-NOV-79 15:46")
(* Propgates changes in properties)
(PROG [(NEWP (for old PROPS by (CDDR PROPS) while PROPS
unless [if INHERITING
then (FINDPROP (fetch PROPS of TB)
(CAR PROPS))
else (EQUAL (CADR PROPS)
(LISTGET (fetch PROPS of TB)
(CAR PROPS]
join (SETTBPROP TB (CAR PROPS)
(COPY (CADR PROPS))
INHERITING)
(LIST (CAR PROPS)
(CADR PROPS]
(DECLARE (SPECVARS NEWP))
[if NEWP
then (UNSAVETYPE TB) (* Probably not necessary, but we cant tell)
(MAPTYPEUSERS (fetch NAME of TB)
(FUNCTION (LAMBDA (X)
(REPROPTB X NEWP T]
(* Any recursions bottom out b/c the change will have been made the
first time the type is reached)
(RETURN NEWP) (* Indicate if any changes)
])
(SETTBPROP
[LAMBDA (TB P V BLKONLY) (* bas: " 7-NOV-79 16:55")
(SELECTQ P
[BINDFN (replace BINDFN of TB with (CREATEFNVAL V (QUOTE BINDFN]
(EVERYFN (CREATEFNVAL V (QUOTE EVERYFN)))
[SETFN (replace SETFN of TB with (CREATEFNVAL V (QUOTE SETFN]
[TESTFN (SELECTQ (fetch NAME of TB)
((ANY NONE)
(DECLERROR "(Futile) attempt to change TESTFN of" (fetch NAME
of TB)))
(replace TESTFN of TB with (CREATEFNVAL V (QUOTE TESTFN]
NIL) (* Unless BLKONLY, must also put on property list so it is known)
(if BLKONLY
elseif (fetch PROPS of TB)
then (LISTPUT (fetch PROPS of TB)
P V)
else (replace PROPS of TB with (LIST P V])
(TBDEFPRINT
[LAMBDA (TB) (* bas: "22-NOV-78 14:32")
(* DEFPRINTer for TYPEBLOCKs. Made a function to allow supression of
constant cons)
(CBOX (CONCAT "{DECLTYPE: " (fetch NAME of TB)
"}")
(PACK])
(TETYPE
[LAMBDA (TE) (* bas: "16-AUG-79 16:16")
(* returns the type of a type expression)
(if (LITATOM TE)
then (QUOTE PRIMITIVE)
else (SELECTQ (CAR (LISTP TE))
((ALLOF MEMQ ONEOF SHARED SUBTYPE SYNONYM TUPLE)
(CAR TE))
(AND (LISTP (CDR TE))
(SELECTQ (CADR TE)
(OF (QUOTE OF))
(SELECTQ (CAR (LISTP (CADR TE)))
((SATISFIES WHOSE)
(CAADR TE))
NIL])
(TYPEMSANAL
[NLAMBDA (KIND) (* rmk: " 7-SEP-81 03:27")
(* Returns the information that the various templates expect.)
(DECLARE (USEDFREE EXPR FNNAME))
(SELECTQ KIND
(COVERS (SCRATCHLIST (CBOX)
(TYPEMSANAL1 EXPR)))
[(type? the)
(LBOX KIND (SCRATCHLIST (CBOX)
(TYPEMSANAL1 (CADR EXPR)))
(OR (GETHASH EXPR CLISPARRAY)
(RESETVARS (FILEPKGFLG (NOSPELLFLG T)
(DWIMESSGAG T))
(PROG (LISPXHIST)
(DECLARE (SPECVARS LISPXHIST))
(DWIMIFY0? EXPR EXPR NIL NIL NIL FNNAME))
(RETURN (GETHASH EXPR CLISPARRAY]
[*DECL
(* We assume that the *DECL came from a previous dwimification which also got the testfn. The typeblock should already exist, but
sometimes it isn't found cause the clisparray gets cleared. The MAKEAPPLYFORM means that bogus VALUE's are most likely eliminated)
(LBOX [SCRATCHLIST (CBOX)
(TYPEMSANAL1 (fetch DECL of (fetch VARDECL of EXPR]
(APPLYFORM [fetch TESTFN of (GETDECLTYPE (fetch DECL
of (fetch VARDECL of EXPR]
(fetch VARNAME of EXPR]
(SHOULDNT])
(TYPEMSANAL1
[LAMBDA (TYPEXP) (* bas: "16-AUG-79 11:55")
(* Collects from a type expression the names of all the named types
that it uses)
(if (LITATOM TYPEXP)
then (ADDTOSCRATCHLIST TYPEXP)
elseif (LISTP TYPEXP)
then [SELECTQ (CAR TYPEXP)
((ALLOF ONEOF SHARED SUBTYPE TUPLE)
(for X in (CDR TYPEXP) do (TYPEMSANAL1 X)))
(MEMQ NIL)
(PROGN (* Infix operator so CAR is a type)
(TYPEMSANAL1 (CAR TYPEXP))
(* CDR TYPEXP must also be a listp)
(if (EQ (CADR TYPEXP)
(QUOTE OF))
then [TYPEMSANAL1 (CAR (LISTP (CDDR TYPEXP]
else (SELECTQ (CAR (LISTP (CADR TYPEXP)))
(SATISFIES NIL)
[WHOSE (for I in (CDADR TYPEXP)
do (TYPEMSANAL1 (CADR I]
(SHOULDNT]
else (SHOULDNT])
(UNCOMPLETE
[LAMBDA (TB) (* bas: " 7-NOV-79 16:08")
(* Reinitializes the TYPEBLOCK for NAME, recursing if necessary)
(replace BINDFN of TB with (CREATEFNPROP (fetch PROPS of TB)
(QUOTE BINDFN)))
(replace SETFN of TB with (CREATEFNPROP (fetch PROPS of TB)
(QUOTE SETFN)))
(replace TESTFN of TB with (CREATEFNPROP (fetch PROPS of TB)
(QUOTE TESTFN)))
(if (fetch CTYPE of (fetch DEF of TB))
then (replace CTYPE of (fetch DEF of TB) with NIL)
(MAPTYPEUSERS (fetch NAME of TB)
(FUNCTION UNCOMPLETE])
(UNSAVETYPE
[LAMBDA (TYPE) (* rmk: " 7-SEP-81 03:44")
(DECLARE (SPECVARS TYPE))
[MAPHASH CLISPARRAY (FUNCTION (LAMBDA (TRAN ORIG)
(if (FORMUSESTB ORIG TRAN TYPE)
then (PUTHASH ORIG NIL CLISPARRAY]
(* Clear translations that depend on this type)
(AND MSDATABASELST (MSNEEDUNSAVE (GETRELATION (fetch NAME of TYPE)
(QUOTE (USE TYPE))
T)
"type declarations" T])
(USERDECLTYPE
[LAMBDA (NAME DECL PROPS) (* rmk: " 2-AUG-81 08:42")
(* User entry to MAKEDECLTYPE)
(if (LITATOM NAME)
then (WITH ((TB (GETHASH NAME DECLTYPESARRAY)))
(* We use GETHASH to avoid creating record based types)
(if [OR (EQ DECL NAME)
(AND TB (EQUAL DECL (fetch TYPEXP of TB]
then (AND (REPROPTB (GETDECLTYPE NAME)
PROPS)
(MARKASCHANGED NAME (QUOTE DECLTYPES)))
(* Adding properties to existing type)
else (SELECTQ NAME
((ANY NONE)
(DECLERROR "(Futile) attempt to redefine" NAME))
NIL)
[MARKASCHANGED NAME (QUOTE DECLTYPES)
(COND
(TB (QUOTE CHANGED))
(T (QUOTE DEFINED]
(if TB
then (DELETETB TB)) (* Forget it if it exists then remake it)
(MAKEDECLTYPE NAME (OR (LISTP DECL)
(LIST (QUOTE SYNONYM)
DECL))
PROPS)))
NAME
else (DECLERROR "Non-atomic DECLTYPE name" NAME])
(USESTYPE
[LAMBDA (NAME TE) (* bas: "10-OCT-79 17:05")
(* Computes whether NAME appears in TE)
(OR (EQ NAME TE)
(SELECTQ (TETYPE TE)
((ALLOF ONEOF SHARED SUBTYPE SYNONYM)
(for I in (CDR TE) thereis (USESTYPE NAME I)))
[MEMQ (for I in (CDR TE) thereis (EQ I (DTYPENAME I]
[OF (OR (USESTYPE NAME (CAR TE))
(USESTYPE NAME (CADDR TE]
(PRIMITIVE NIL)
(SATISFIES (USESTYPE (CAR TE)))
[TUPLE (OR (EQ NAME (if (CDR TE)
then (QUOTE LISTP)
else NIL))
(USESTYPE NAME (CONS (QUOTE ALLOF)
(CDR TE]
[WHOSE (OR (USESTYPE NAME (CAR TE))
(for I in (CADR TE) thereis (USESTYPE NAME (CADR I]
(SHOULDNT])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: LCCTYPE LCCTYPE LCC2)
(BLOCK: TYPEMSANAL TYPEMSANAL TYPEMSANAL1)
]
(* Test fn creation block)
(DEFINEQ
(MAKETESTFN
[LAMBDA (TB) (* rmk: "29-NOV-81 22:41")
(* Computes the test fn for a type block. Called from TESTFN fetch function. This is not a part of the
MAKETESTFNBLOCK, so that the name MAKETESTFN is a reliable indicator for checking recursion
(DECLRECURSING))
(MAKETESTFNBLOCK TB])
(MAKETESTFNBLOCK
[LAMBDA (TB) (* rmk: " 6-FEB-82 14:25")
(* Computes the test fn for a type block)
(WITH [(TE (fetch TYPEXP of TB))
(BINDINGNAME (OR (AND (LITATOM (fetch PROPS of TB))
(fetch PROPS of TB))
(QUOTE VALUE]
(DECLARE (SPECVARS BINDINGNAME))
(COND
[(DECLRECURSING (QUOTE MAKETESTFNBLOCK)
TB) (* Name will be returned)
(replace TESTFN of TB with (PACK* (fetch NAME of TB)
(QUOTE .TestFn]
(T (WITH [(DEF (SELECTQ (TETYPE TE)
(ALLOF (COMBINE.TESTS (SMASHCAR (COLLECTTYPES (CDR TE)
(QUOTE DOWN))
(FUNCTION TESTFORM))
(QUOTE AND)))
[MEMQ (LAMBIND (COND
[(COVERSTB (GETDECLTYPE (QUOTE (ONEOF LITATOM
SMALLP)))
TB)
(COND
((CDDR TE)
(LIST (QUOTE SELECTQ)
BINDINGNAME
(LIST (CDR TE)
T)
NIL))
(T (LIST (QUOTE EQ)
BINDINGNAME
(KWOTE (CADR TE]
(T (COND
[(CDDR TE)
(LIST (QUOTE MEMBER)
BINDINGNAME
(KWOTE (CDR TE]
(T (LIST (QUOTE EQUAL)
BINDINGNAME
(KWOTE (CADR TE]
[OF (OF.TESTFN (GETDECLTYPE (CAR TE))
(GETDECLTYPE (COND
((CDDDR TE)
(CDDR TE))
(T (CADDR TE]
(ONEOF (COMBINE.TESTS (SMASHCAR (COLLECTTYPES (CDR TE)
(QUOTE UP))
(FUNCTION TESTFORM))
(QUOTE OR)))
(SATISFIES (COMBINE.TESTS [LIST (TESTFORM (GETDECLTYPE
(CAR TE)))
(COND
((CDDR (CADR TE))
(* There might be multiple forms or disconnected CLISP)
(CONS (QUOTE AND)
(CDADR TE)))
(T (CADR (CADR TE]
(QUOTE AND)))
[(SHARED SUBTYPE SYNONYM)
(fetch TESTFN of (GETDECLTYPE (CADR TE]
(TUPLE (TUPLE.TESTFN (CDR TE)))
(WHOSE (WHOSE.TESTFN TB (CAR TE)
(CDADR TE)))
(SHOULDNT]
(WITH ((TF (fetch TF of TB)))
(replace TESTFN of TB with (COND
[TF
(* Must be recursive with TF being the atom name.TestFn and DEF being a lambda expression. Convert to a LABEL
expression, then translate it using DOLABEL from LABEL package.)
(DOLABEL (CONS (QUOTE LABEL)
(CONS TF (CDR DEF]
(T DEF])
(COMBINE.TESTS
[LAMBDA (TESTS ANDOR) (* bas: "28-AUG-79 13:29")
(* Composes TESTS under either AND or OR composition)
(FUNIFY [for TST in TESTS join (COND
((EQ (CAR (LISTP TST))
ANDOR)
(APPEND (CDR TST)))
((EQ TST (EQ ANDOR (QUOTE AND)))
(* AND T or OR NIL)
NIL)
((EQ TST (EQ ANDOR (QUOTE OR)))
(* AND NIL or OR T)
(RETURN (LIST TST)))
(T (LIST TST]
ANDOR])
(FUNIFY
[LAMBDA (TEST ANDOR) (* bas: "11-OCT-79 18:05")
(* Provides LAMBDA abstraction for COMBINE.TESTS)
(LAMBIND (COND
((NLISTP TEST) (* No tests)
(EQ ANDOR (QUOTE AND)))
((CDR TEST) (* More than one clause)
(CONS ANDOR TEST))
(T (CAR TEST])
(MKNTHCAR
[LAMBDA (L N) (* bas: " 8-MAR-79 17:55")
(* Constructs an expression for getting the Nth car of L)
(PROG [(F (MKNTHCDR L (SUB1 N]
(RETURN (SELECTQ (CAR F)
(CDR (CONS (QUOTE CADR)
(CDR F)))
(CDDR (CONS (QUOTE CADDR)
(CDR F)))
(CDDDR (CONS (QUOTE CADDDR)
(CDR F)))
(LIST (QUOTE CAR)
F])
(MKNTHCDR
[LAMBDA (L N) (* bas: " 9-MAR-79 14:50")
(* Constructs an expresssion for getting the Nth cdr of L)
(if (ZEROP N)
then L
elseif (ILESSP N 5)
then (LIST (SELECTQ N
(1 (QUOTE CDR))
(2 (QUOTE CDDR))
(3 (QUOTE CDDDR))
(4 (QUOTE CDDDDR))
(SHOULDNT))
L)
elseif (ILESSP N 9)
then (MKNTHCDR (LIST (QUOTE CDDDDR)
L)
(IDIFFERENCE N 4))
else (LIST (QUOTE FNTH)
L
(ADD1 N])
(OF.TESTFN
[LAMBDA (AGG ELT) (* rmk: "19-AUG-81 00:08")
(COMBINE.TESTS [LIST (TESTFORM AGG)
(LIST (OR (GETTBPROP AGG (QUOTE EVERYFN))
(DECLERROR "OF construction used with non-aggregate type"))
BINDINGNAME
(LIST (QUOTE FUNCTION)
(fetch TESTFN of ELT]
(QUOTE AND])
(TUPLE.TESTFN
[LAMBDA (TYPES) (* rmk: "19-AUG-81 00:16")
(* Constructs the test function for TUPLEs)
(COND
(TYPES (COMBINE.TESTS [CONS (LIST (QUOTE EQLENGTH)
BINDINGNAME
(LENGTH TYPES))
(for I in TYPES as J from 1 collect (APPLYFORM (fetch TESTFN
of (GETDECLTYPE
I))
(MKNTHCAR
BINDINGNAME J]
(QUOTE AND)))
(T (QUOTE NULL])
(WHOSE.TESTFN
[LAMBDA (TB SNAM TAIL) (* bas: " 6-NOV-79 16:56")
(* Constructs TESTFN for WHOSE expressions)
(COMBINE.TESTS [CONS (TESTFORM (GETDECLTYPE SNAM))
(for I in TAIL
collect (APPLYFORM [fetch TESTFN of (GETDECLTYPE (COND
((EQLENGTH I 2)
(CADR I))
(T (CDR I]
(COND
[(EQ SNAM (QUOTE LISTP))
(WITH ((V (CAR I)))
(SELECTQ V
((CAR CDR CADR CDDR CAAR CDAR)
(LIST V BINDINGNAME))
(COND
((AND (FIXP V)
(NOT (MINUSP V)))
(MKNTHCAR BINDINGNAME V]
((FMEMB (CAR I)
(RECORDFIELDNAMES SNAM))
(LIST (QUOTE FETCH)
(LIST SNAM (CAR I))
(QUOTE OF)
BINDINGNAME))
(T (DECLERROR (CAR I)
" is not a valid fieldname"]
(QUOTE AND])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: MAKETESTFNBLOCK MAKETESTFNBLOCK COMBINE.TESTS FUNIFY MKNTHCAR MKNTHCDR OF.TESTFN TUPLE.TESTFN
WHOSE.TESTFN)
]
(* Machinery to compile recursive testfns)
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
LABEL)
(* Idioms. Expressed as macros for now)
(DECLARE: DONTCOPY EVAL@COMPILE
(RPAQQ DefaultBindFn PROGN)
(RPAQQ DefaultSetFn REALSETQ)
(ADDTOVAR NLAMA MAKEDECLTYPEQ)
(DECLARE: EVAL@COMPILE
(PUTPROPS ANYC MACRO ((C)
(EQ C (QUOTE ANY))))
(PUTPROPS DECLVARERROR MACRO [ARGS (LSUBST ARGS (QUOTE ARGS)
(QUOTE (DECLDWIMERROR ARGS T " inside " VARD])
(PUTPROPS DTYPENAME MACRO [(X)
(COND
((LARGEP X)
(QUOTE LARGEP))
(T (TYPENAME X])
(PUTPROPS foreachTB MACRO [ARGS (LIST (QUOTE MAPHASH)
(QUOTE DECLTYPESARRAY)
(LIST (QUOTE FUNCTION)
(CONS (QUOTE LAMBDA)
(CONS (LIST (CAR ARGS))
(CDR ARGS])
(PUTPROPS GETCGETD MACRO ((X)
(GETCTYPE (GETDECLTYPE X))))
(PUTPROPS KWOTEBOX MACRO [(V)
([LAMBDA ($$8)
(DECLARE (LOCALVARS $$8))
(FRPLACA (CDR $$8)
V)
$$8]
(QUOTE (QUOTE Q])
(PUTPROPS LAMBIND MACRO (ARGS (APPEND (QUOTE (LIST (QUOTE LAMBDA)
(LIST BINDINGNAME)))
ARGS)))
(PUTPROPS LAMVAL MACRO (ARGS (APPEND [QUOTE (LIST (QUOTE LAMBDA)
(QUOTE (VALUE]
ARGS)))
(PUTPROPS MAKEDECLTYPEQ MACRO ((NAME DEF PROPS)
(MAKEDECLTYPE (QUOTE NAME)
(QUOTE DEF)
(QUOTE PROPS))))
(PUTPROPS NONEC MACRO ((C)
(EQ C (QUOTE NONE))))
(PUTPROPS TESTFORM MACRO ((TB)
(APPLYFORM (fetch TESTFN of TB)
BINDINGNAME)))
)
(DEFINEQ
(TESTFORM
[LAMBDA (TB) (* rmk: "24-NOV-81 22:17")
(* Doesn't get compiled, cause it is macroed out.
Symbolic definition exists because it get's APPLY*, not
EVALed)
(APPLYFORM (fetch TESTFN of TB)
BINDINGNAME])
)
(ADDTOVAR DONTCOMPILEFNS TESTFORM)
(SETTEMPLATE (QUOTE foreachTB)
(QUOTE (CALL BIND .. EFFECT)))
(SETTEMPLATE (QUOTE MAKEDECLTYPEQ)
(QUOTE (CALL NIL NIL NIL . PPE)))
)
(* Runtime utility functions)
(DEFINEQ
(EVERYCHAR
[LAMBDA (STRNG FN) (* bas: " 6-MAR-79 17:58")
(* The EVERY function for strings)
(for I to (NCHARS STRNG) always (APPLY* FN (NTHCHAR STRNG I])
(LARGEP
[LAMBDA (X) (* rmk: "24-MAY-79 09:10")
(* For LARGEP type-tests)
(AND (FIXP X)
(NOT (SMALLP X])
(DECLRECURSING
[LAMBDA (NAME ARG) (* rmk: "29-NOV-81 14:48")
(* NAME is the name of a potentially looping function in our call chain. ARG is the first arg in that lowest call to
NAME. Determines whether the function NAME exists higher on the stack with ARG as its first argument.
Used to check for recursive loops.)
(bind (S_(STKPOS NAME -1)) while (STKPOS NAME -2 S S) when (EQ ARG (STKARG 1 S))
do
(* At each step we back off one from the last frame we checked b/c it would otherwise be found by STKPOS, and search
for the next one. S is reused by both stack fns and released if the loop terminates with it pointing to anything.)
(RELSTK S)
(RETURN T])
(SMASHCAR
[LAMBDA (L FN) (* bas: "31-OCT-79 17:11")
(* Maps over L smashing the result of applying FN to each car into that
car)
[MAP L (FUNCTION (LAMBDA (X)
(FRPLACA X (APPLY* FN (CAR X]
L])
)
(DECLARE: EVAL@COMPILE
(DECLARE: EVAL@COMPILE
(PUTPROPS LARGEP 10MACRO ((X)
(EQ (NTYP X)
18)))
)
)
(DECLARE: DONTCOPY EVAL@COMPILE
(DECLARE: EVAL@COMPILE
(PUTPROPS SMASHCAR MACRO [ARGS (SUBST [SELECTQ (CAADR ARGS)
[(FUNCTION QUOTE)
(APPLYFORM (CADADR ARGS)
(QUOTE (CAR I]
(LIST (QUOTE APPLY*)
(CADR ARGS)
(QUOTE (CAR I]
(QUOTE NEWVAL)
(LIST (QUOTE [LAMBDA (L)
(DECLARE (LOCALVARS L))
[MAP L (FUNCTION (LAMBDA (I)
(DECLARE (LOCALVARS I))
(FRPLACA I NEWVAL]
L])
(CAR ARGS])
)
)
(* translator of dprogs and dlambdas)
(DEFINEQ
(ASSERT
[NLAMBDA ARGS (* bas: "31-JUL-79 14:00")
(* ARGS is a mixed list of variable names and forms. Forms must be true, and the test function for variables must be true too.)
(DECLARE (LOCALVARS . T))
(for V in ARGS do (if (LITATOM V)
then (VARASRT V)
elseif (LISTP V)
then (OR (EVAL V (QUOTE INTERNAL))
(ASSERTFAULT V NIL))
else (ERRORX (LIST 27 V])
(ASSERTFAULT
[LAMBDA (DECL VARNAME) (* bas: "19-OCT-79 15:44")
(* Prints out the assertion error messages.)
(LISPXTERPRI T)
(LISPXPRIN1 (if VARNAME
then "DECLARATION"
else "ASSERTION")
T)
(LISPXPRIN1 " NOT SATISFIED IN " T)
(LISPXPRIN2 (STKNAME (REALSTKNTH -1 (QUOTE ASSERTFAULT)))
T)
(APPLY* (FUNCTION BREAK1)
NIL T (if VARNAME
then (LIST VARNAME DECL)
else DECL])
(ASSERTMAC
[LAMBDA (ARGS) (* rmk: " 2-AUG-79 23:21")
(* Compiler for ASSERT forms.)
(if (IGNOREDECL)
then (CBOX COMMENTFLG (LBOX (CBOX (QUOTE ASSERT)
ARGS)))
else (for V in ARGS collect (if (LISTP V)
then (LIST (QUOTE OR)
V
(LIST (QUOTE ASSERTFAULT)
(KWOTE V)))
elseif (LITATOM V)
then (MAKETESTFORM V (TYPEBLOCKOF V))
else (ERRORX (LIST 27 V)))
finally (RETURN (if (CDR $$VAL)
then (CONS (QUOTE PROGN)
$$VAL)
else (CAR $$VAL])
(*DECL
[NLAMBDA ARGS (* DECLARATIONS: (RECORD ARGRECORD (SL . FORMS)))
(* rmk: "20-NOV-78 21:46")
(* This maintains the proper bindings of SATISFIESLIST.
It is wrapped around function bodies by dprog's and dlambda's.
Compiles open, depending on COMPILEIGNOREDECL.)
(PROG [(SATISFIESLIST (if [OR (NULL (fetch SL of ARGS))
(LISTP (CAAR (fetch SL of ARGS]
then
(* If NIL, then this is the top binding for a declarative without any bindings. If LISTP, then this is the first binding in this lexical
scope.)
(fetch SL of ARGS)
else (CONS (fetch SL of ARGS)
SATISFIESLIST]
(DECLARE (SPECVARS SATISFIESLIST)) (* Use DECLPROGN instead of PROGN so BAKTRACELST can recognize us)
(RETURN (APPLY (FUNCTION DECLPROGN)
(fetch FORMS of ARGS)
(QUOTE INTERNAL])
(*DECLMAC
[LAMBDA (ARGS) (* DECLARATIONS: (RECORD ARGRECORD (SL . FORMS)))
(* rmk: "14-MAY-79 23:43")
(DECLARE (USEDFREE CSATISFIESLIST FREEVARS))
(PROG [FIRSTSL (FV FREEVARS)
(SL (fetch SL of ARGS))
(FORM (if (CDR (fetch FORMS of ARGS))
then (CONS (QUOTE PROGN)
(fetch FORMS of ARGS))
else (CAR (fetch FORMS of ARGS]
[SETQ FIRSTSL (OR (NULL SL)
(LISTP (CAAR SL] (* The first declaration in this function)
(* Maintain list of free variables for the benefit of clisp words
arising in macros)
(for V in (if FIRSTSL
then (CAR SL)
else SL)
when (EQ (fetch PROGNFLAG of (fetch VARDECL of V))
(QUOTE FREE))
do (push FV (fetch VARNAME of V)))
[SETQ SL (LIST (QUOTE CSATISFIESLIST)
(KWOTE (if FIRSTSL
then SL
else (CONS SL CSATISFIESLIST]
(* Assumes that *DECLMAC is executed in the same compiletime context as CBIND. If this is the first declaration, we bind
COMPILEIGNOREDECL for the benefit of compiler-generated sub-functions)
(RETURN (LIST (QUOTE .CBIND.)
[CONS SL (NCONC [if (NEQ FV FREEVARS)
then (LIST (LIST (QUOTE FREEVARS)
(KWOTE FV]
(if FIRSTSL
then (LIST (LIST (QUOTE COMPILEIGNOREDECL)
(IGNOREDECL]
FORM])
(CHKINIT
[NLAMBDA ARGS (* bas: " 9-OCT-79 23:15")
(* ARGS is a list of variable names whose nearest assertions are to be checked. Calls to CHKINIT are generated by DLAMTRAN just for
variables that have inital values and test-forms in the nearest SATISFIESLIST entry.)
(DECLARE (LOCALVARS . T))
(for V D in ARGS unless (APPLY* (fetch TESTFN
of (GETDECLTYPE [SETQ D
(fetch DECL
of (fetch VARDECL
of (ASSOC V (CAR SATISFIESLIST]
V))
(EVALV V))
do (ASSERTFAULT D V])
(CHKINITMAC
[LAMBDA (ARGS) (* rmk: "16-AUG-81 23:11")
(* Compiler for CHKINIT forms.)
(DECLARE (USEDFREE COMMENTFLG CSATISFIESLIST))
(if (IGNOREDECL)
then (CBOX COMMENTFLG (CBOX (QUOTE CHKINIT)
ARGS))
else (* The CHKINIT only includes variables whose testform is not T)
(for V D TEMP in ARGS
collect (LIST (QUOTE OR)
(APPLYFORM (fetch TESTFN
of (GETDECLTYPE [SETQ D
(fetch DECL
of (fetch VARDECL
of (ASSOC V (CAR CSATISFIESLIST]
V))
V)
(LIST (QUOTE ASSERTFAULT)
(if (LISTP D)
then (CONS (QUOTE DECLMSGMAC)
D)
else (KWOTE D))
(KWOTE V)))
finally (RETURN (if (CDR $$VAL)
then (CONS (QUOTE PROGN)
$$VAL)
else (CAR $$VAL])
(DECLCONSTANTP
[LAMBDA (X) (* bas: " 9-OCT-79 21:32")
(OR (NULL X)
(EQ X T)
(NUMBERP X)
(STRINGP X)
(AND (LISTP X)
(SELECTQ (CAR X)
((QUOTE CONSTANT)
T)
(WITH ((TEMP (if (GETP (CAR X)
(QUOTE MACRO))
then (EXPANDMACRO X T)
else X)))
(* If we did a DECLOF and got a MEMQ, we'd have a constant. Thus, this code wouldn't have to duplicate what goes on in DECLOF, and we
would get the funny PROG and SELECTQ cases for free.)
(if (AND (NEQ TEMP X)
(NEQ TEMP (QUOTE IGNOREMACRO)))
then (DECLCONSTANTP TEMP)
elseif (SELECTQ (CAR X)
((SELECTQ CLOSER GO PROG COND)
(* CLOSER has side-effects. The others have CTYPE properties but their
arguments can't be simply checked)
NIL)
(GETP (CAR X)
(QUOTE CTYPE)))
then (* The test we really want is that the function doesn't reference
freevariables or cause side-effects.)
(EVERY (CDR X)
(FUNCTION DECLCONSTANTP])
(DD
[NLAMBDA X (* DECLARATIONS: (RECORD ARGRECORD (NAME . DEF)
(RECORD DEF (ARGS . BODY))))
(* rmk: "24-JUL-78 08:13")
(* For Defining DLambda functions. NAME is the function name and DEF
the rest of its definition.)
(DEFINE [LIST (LIST (fetch NAME of X)
(CONS (QUOTE DLAMBDA)
(fetch DEF of X]
T])
(DECLCLISPTRAN
[LAMBDA (X TRAN) (* rmk: "21-DEC-78 15:08")
[PROG (DECL DFORM DPROGFLAG RETURNS
(DECLARETAGS (QUOTE (LOCALVARS SPECVARS ADDTOVAR DEFLIST PUTPROPS CONSTANTS SETQQ
USEDFREE))))
(if [AND (LISTP TRAN)
[EQ (QUOTE FORWORD)
(CAR (GETPROP (CAR (LISTP X))
(QUOTE CLISPWORD]
[if (EQ (QUOTE PROG)
(CAR TRAN))
then (SETQ DPROGFLAG T)
(SETQ DFORM TRAN)
elseif (AND [EQ (QUOTE FUNCTION)
(CAR (SETQ DFORM (CAR (LISTP (CDR (LISTP (CDR TRAN]
(EQ (QUOTE LAMBDA)
(CAR (SETQ DFORM (CAR (LISTP (CDR DFORM]
(OR (NULL NEWSATLIST)
(for D in (CDR (ASSOC (QUOTE DECLARE)
DFORM))
thereis (AND (LISTP D)
(NOT (FMEMB (CAR D)
DECLARETAGS]
then (FRPLACA DFORM (if DPROGFLAG
then (QUOTE DPROG)
else (QUOTE DLAMBDA)))
[for F (PROGVARS _(AND DPROGFLAG (CADR DFORM))) in (CDDR DFORM)
when (EQ (CAR F)
(QUOTE DECLARE))
do (for D V DCLARE in (CDR F)
do (if (OR (NLISTP D)
(FMEMB (CAR D)
DECLARETAGS))
then (push DCLARE D)
elseif DPROGFLAG
then (* Distribute declarations of local variables in the DPROG bindings.
This means that initial values will be taken into account)
(for L on PROGVARS
do (if (EQ (CAR D)
(CAR L))
then [FRPLACA L (CONS (CAR L)
(CONS NIL (CDR D]
(RETURN)
elseif (AND (LISTP (CAR L))
(EQ (CAR D)
(CAAR L)))
then [if (NLISTP (CDAR L))
then (FRPLACD (CAR L)
(LIST (CDAR L]
(* In case it's a list with no CADR)
(NCONC (CAR L)
(CDR D))
(RETURN))
finally (push DECL D))
elseif (EQ (CAR D)
(QUOTE RETURNS))
then (push RETURNS D)
else (push DECL D))
finally (FRPLACD F (DREVERSE DCLARE]
[if DECL
then (push (CDDR DFORM)
(CONS (QUOTE DECL)
(DREVERSE DECL]
(RESETVARS (CLISPRETRANFLG) (* Resetting this flag avoids redundancies in a !DW)
(if RETURNS
then (SETQ TRAN (LIST (QUOTE DPROGN)
(DREVERSE RETURNS)
TRAN))
(DWIMIFY0? TRAN TRAN NIL NIL NIL FAULTFN)
(* Only happens for a MAPC/AR etc that has a RETURNS)
(SETQ TRAN (PROG1 (CAR (CDDDDR (GETHASH TRAN CLISPARRAY)))
(PUTHASH TRAN NIL CLISPARRAY)))
(* Skip down to the CHECKVALUE)
else (DWIMIFY0? DFORM DFORM NIL NIL NIL FAULTFN)))
(if (PROG1 (SETQ DECL (GETHASH DFORM CLISPARRAY))
(PUTHASH DFORM NIL CLISPARRAY))
then (* Don't clobber DFORM with an empty translation, which probably comes
from a lower-level error)
(FRPLNODE2 DFORM DECL)
else (SETQ TRAN NIL]
(REALCLISPTRAN X TRAN])
(DECLMSG
[NLAMBDA DECLMSG (* rmk: "16-AUG-81 23:17")
(* Purely for saving storage. For list declarations, the DECL argument of ASSERTFAULT and VALUEERROR is compiled as a call to DECLMSGMAC
which has a macro that calls DECLMSG as a compiletime or loadtime constant. We attempt to find an already existing copy of that
list-structure, and if we do, we return a pointer to that instead)
(DECLARE (SPECVARS DECLMSG)
(GLOBALVARS DECLTYPESARRAY DECLMESSAGES))
(if (GETHASH DECLMSG DECLTYPESARRAY)
then (* This never works when we're loading from a file, but always works
when we are storing the compiled code directly into core.)
DECLMSG
else [foreachTB TB (if (EQUAL DECLMSG (fetch NAME of TB))
then (RETFROM (QUOTE DECLMSG)
(fetch NAME of TB]
(* Fall through if didn't locate it.
Look it up on our special message database list.)
(CAR (OR (MEMBER DECLMSG DECLMESSAGES)
(push DECLMESSAGES DECLMSG])
(DECLDWIMERROR
[LAMBDA ARGS (* bas: "10-OCT-79 18:24")
(DECLARE (USEDFREE FAULTFN))
(LISPXTERPRI T)
(LISPXPRIN1 "{in " T)
(LISPXPRIN1 FAULTFN T)
(LISPXPRIN1 "} " T)
(for I to ARGS do (if (EQ T (ARG ARGS I))
then (LISPXTERPRI T)
else (LISPXPRIN1 (ARG ARGS I)
T)))
(LISPXTERPRI T)
(ERROR!])
(DECLDWIMTESTFN
[LAMBDA (TB) (* rmk: " 6-FEB-82 14:26")
(* Returns the dwimified TESTFN of TB)
(DECLARE (USEDFREE FAULTFN))
(PROG ((FN (fetch TESTFN of TB)))
(if [AND (LISTP FN)
(OR CLISPRETRANFLG (NOT (GETHASH FN CLISPARRAY]
then (DWIMIFY0? FN FN NIL NIL NIL FAULTFN)
(* We hash the FN to itself to avoid repetitive dwimification unless CLISPRETRANFLG is on. But we're careful to
avoid circularity if FN begins with a CLISPWORD.)
(OR (GETHASH FN CLISPARRAY)
(PUTHASH FN FN CLISPARRAY)))
(RETURN FN])
(DECLSET
[LAMBDA (VAR VAL) (* bas: "19-OCT-79 15:04")
(* Version of SET that does ASSERT checks. This is moved to SET when DECLTRAN is loaded. The old definition of SET is available through
the name REALSET. Uses VARSETFN to find the run-time type-dependent SETFN, which will be that for the lowest declaration on the
satisfieslist for a DPROGN)
(DECLARE (LOCALVARS . T))
(PROG1 (APPLY (VARSETFN VAR)
(LBOX VAR (KWOTEBOX VAL)))
(VARASRT VAR])
(DECLSETQ
[NLAMBDA U (* bas: " 6-NOV-79 15:46")
(* Version of SETQ that does ASSERT checks. The old definition of SETQ is available through the name REALSETQ. The contortions are so
DWIM gets to see the value forms in the environment of the running function.)
(DECLARE (LOCALVARS . T))
(WITH [(V (APPLY (FUNCTION PROG1)
(CDR U)
(QUOTE INTERNAL] (* Bind the value so no recursion thru the LBOX)
(PROG1 (APPLY (VARSETFN (CAR U))
(LBOX (CAR U)
(KWOTEBOX V))
(QUOTE INTERNAL))
(VARASRT (CAR U])
(DECLSETQQ
[NLAMBDA (XSET YSET) (* bas: " 1-NOV-79 17:54")
(APPLY* (FUNCTION DECLSETQ)
XSET
(KWOTEBOX YSET])
(DECLTRAN
[LAMBDA (FORM) (* DECLARATIONS: FAST (RECORD FORM (ATOM DCLS . FORMS)))
(* rmk: "15-AUG-81 15:25")
(* Translator for declarative statements)
(DECLARE (USEDFREE VARS CLISPCHANGE)) (* Used for DPROGN variable names)
(SETQ CLISPCHANGE T)
(PROG (TEMP CLISP: DECLARE TOP BS PROGDCLS SPECVARS SAT INITVARS VARBINDFORMS RETURNS LOCALVARS
(ATOM (fetch ATOM of FORM))
(FORMS (fetch FORMS of FORM))
(VARS VARS))
(DECLARE (SPECVARS VARS PROGDCLS SPECVARS SAT INITVARS RETURNS LOCALVARS VARBINDFORMS))
(if (LISTP (SETQ TEMP (fetch DCLS of FORM)))
then [for V in old TEMP do (if (AND (EQ ATOM (QUOTE DPROG))
(EQ V (QUOTE THEN)))
then [SETQ FORMS (LIST (LIST (QUOTE RETURN)
(CONS (QUOTE DPROG)
(CONS (CDR TEMP)
FORMS]
(RETURN))
(DECLVAR V (EQ ATOM (QUOTE DPROG))
(NEQ ATOM (QUOTE DPROGN]
(SETQ PROGDCLS (DREVERSE PROGDCLS))
else (if (AND TEMP (LITATOM TEMP)
(EQ ATOM (QUOTE DLAMBDA)))
then (DECLVAR (LIST TEMP (QUOTE FIXP))
NIL T) (* Handles no-spread case; not necessary to do CHKINIT)
(SETQ INITVARS NIL))
(SETQ PROGDCLS TEMP))
(if [AND (EQ ATOM (QUOTE DLAMBDA))
(OR (EQ [CAR (SETQ TEMP (LISTP (CAR FORMS]
(QUOTE CLISP:))
(AND (EQ (CAR TEMP)
COMMENTFLG)
(EQ (CADR TEMP)
(QUOTE DECLARATIONS:]
then (SETQ CLISP: TEMP)
(SETQ FORMS (CDR FORMS)))
[if (NEQ ATOM (QUOTE DPROGN))
then (for F DECL in old FORMS do (if (NLISTP F)
then (GO $$OUT)
elseif (EQ (CAR F)
COMMENTFLG)
elseif (EQ (CAR F)
(QUOTE DECLARE))
then
(* APPEND combines multiple declares)
(SETQ DECLARE (APPEND DECLARE (CDR F)))
elseif (EQ (CAR F)
(QUOTE DECL))
then (SETQ DECL (APPEND DECL (CDR F)))
else (GO $$OUT))
finally [if (EQ ATOM (QUOTE DPROG))
then
(* This PROG represents the user's PROG, to which his RETURN and GO statements are referred. The PROG introduced below is for the actual
bindings, and allows intervening checks for variables and RETURNS to be inserted.)
(SETQ FORMS (LIST (CONS (QUOTE PROG)
(CONS NIL FORMS]
(if DECL
then (SETQ FORMS (LIST (CONS (QUOTE DPROGN)
(CONS DECL FORMS]
(* The test-functions don't appear in the code, so they have to be dwimified separately. This can't be done in MAKEDECLTYPE, because the
variables in the testfn aren't known until this whole binding set has been processed to add them to VARS. -
We don't have to worry about set and bind functions, cause they are attached only to named types and thus are dwimified when the type is
defined.)
[for V in SAT when (SETQ V (fetch VARDECL of V))
do (DECLDWIMTESTFN (OR (FINDDECLTYPE (fetch DECL of V))
(SHOULDNT]
(if SPECVARS
then (push DECLARE (CONS (QUOTE SPECVARS)
SPECVARS)))
(if LOCALVARS
then (push DECLARE (CONS (QUOTE LOCALVARS)
LOCALVARS)))
[if RETURNS
then (SETQ FORMS (LIST (CONS (QUOTE the)
(CONS RETURNS FORMS]
(if DECLARE
then (push DECLARE (QUOTE DECLARE)))
(SETQ BS (CONS (QUOTE PROGN)
(NCONC [if INITVARS
then (LIST (CONS (QUOTE CHKINIT)
(DREVERSE INITVARS]
FORMS)))
[if VARBINDFORMS
then (FRPLACD BS (NCONC (DREVERSE VARBINDFORMS)
(CDR BS] (* VARBINDFORMS is hook for type-dependent initializations)
(SELECTQ ATOM
[(DLAMBDA) (* In parens to suppress PPDECL here)
(SETQ FORMS (LIST BS))
(if DECLARE
then (push FORMS DECLARE))
[push FORMS (CONS COMMENTFLG (QUOTE (ASSERT: (CLISP DLAMBDA]
(if CLISP:
then (push FORMS CLISP:))
(SETQ TOP (CONS (QUOTE LAMBDA)
(CONS PROGDCLS FORMS]
((DPROG)
(SETQ TOP (LIST (QUOTE PROG)
PROGDCLS
(LIST (QUOTE RETURN)
BS)))
(if DECLARE
then (push (CDDR TOP)
DECLARE)))
(SETQ TOP BS)) (* DPROGN falls through)
(PROG (NEWSATLIST) (* Lower decl's are not new.)
(DECLARE (SPECVARS NEWSATLIST))
(DWIMIFY0? TOP TOP NIL NIL NIL FAULTFN))
(if (OR SAT NEWSATLIST)
then (FRPLACA BS (QUOTE *DECL)) (* If no variables were declared, leave the PROGN that was to make sure
that the forms got dwimified correctly)
(SETQ SAT (DREVERSE SAT)) (* So satlist is ordered like decls)
(push (CDR BS)
(if (AND NEWSATLIST SAT)
then (LIST SAT)
else SAT))) (* We can do the extra CONS statically when this is a newsatlist)
(RETURN (if (EQ ATOM (QUOTE DLAMBDA))
then TOP
else (REALCLISPTRAN FORM TOP)
FORM])
(DECLVAR
[LAMBDA (VARD DPROGFLAG BINDFLAG) (* DECLARATIONS: FAST)
(* rmk: "15-AUG-81 15:31")
(DECLARE (USEDFREE FAULTFN RETURNS SAT INITVARS PROGDCLS LOCALVARS SPECVARS VARBINDFORMS VARS)
(GLOBALVARS GLOBALVARS))
(PROG (TYPEBLOCK DECL TEMP TESTFORM NAME INITV REM SATFORM (PROGNFLAG (NOT BINDFLAG)))
(if (LISTP VARD)
then (SETQ NAME (CAR VARD))
(SELECTQ NAME
((RETURNS VALUE)
(if RETURNS
then (DECLVARERROR "Multiple RETURNS/VALUE declaration"))
(SETQ DPROGFLAG (SETQ BINDFLAG NIL))
(SETQQ NAME VALUE))
NIL)
(SETQ REM (CDR VARD))
(if DPROGFLAG
then (RESETVARS ((NOSPELLFLG T)
(DWIMESSGAG T))
(DWIMIFY0? REM VARD REM NIL NIL FAULTFN))
(* This will glue all the components of the initial value together. It will also walk through the declarations, but no spelling
corrections will be done. Corrections in the SATISFIES will happen when the whole translation is dwimified in DECLTRAN.)
(SETQ INITV (pop REM)))
else (SETQ NAME VARD))
(if (NOT (AND NAME (LITATOM NAME)))
then (DECLVARERROR "Illegal variable name"))
(for V in REM
do (* RETRY is a label)
RETRY
(if (if BINDFLAG
then [SELECTQ V
(SPECIAL (if (FMEMB NAME LOCALVARS)
then (DECLVARERROR
"Variable can't be both LOCAL and SPECIAL: "
NAME)
else (push SPECVARS NAME)))
(LOCAL (if (FMEMB NAME SPECVARS)
then (DECLVARERROR
"Variable can't be both LOCAL and SPECIAL: "
NAME)
else (push LOCALVARS NAME)))
(if (EQ (CAR (LISTP V))
(QUOTE USEDIN))
then (if (FMEMB NAME LOCALVARS)
then (DECLVARERROR
"Variable can't be both LOCAL and USEDIN: "
NAME)
else (push SPECVARS NAME]
elseif (EQ V (QUOTE GLOBAL))
then (pushnew GLOBALVARS NAME)
elseif (OR (EQ V (QUOTE FREE))
(EQ (CAR (LISTP V))
(QUOTE BOUNDIN)))
then (SETQ PROGNFLAG (QUOTE FREE)))
elseif (EQ (CAR (LISTP V))
(QUOTE SATISFIES))
then (if SATFORM
then (DECLVARERROR "Multiple SATISFIES"))
(SETQ SATFORM V)
elseif (EQ (CAR (LISTP V))
COMMENTFLG)
elseif (SETQ TEMP (GETDECLTYPE.NOERROR V NAME))
then (if TYPEBLOCK
then (DECLVARERROR "more than one type declaration: " V))
(SETQ TYPEBLOCK TEMP)
(SETQ DECL V)
elseif (AND (LISTP V)
(FIXSPELL (CAR V)
80
(QUOTE (SATISFIES BOUNDIN USEDIN))
T V))
then (AND FAULTFN (NEQ FAULTFN (QUOTE TYPE-IN))
(MARKASCHANGED FAULTFN (QUOTE FNS)))
(GO RETRY)
else (DECLVARERROR "invalid declaration: " V)))
(if (NULL TYPEBLOCK)
then (SETQQ DECL ANY))
(if SATFORM
then (SETQ DECL (LIST DECL SATFORM))
(if (NULL (SETQ TYPEBLOCK (GETDECLTYPE.NOERROR DECL NAME)))
then (DECLVARERROR "invalid declaration: " DECL)))
(if (EQ NAME (QUOTE VALUE))
then (SETQ RETURNS DECL) (* This gets reprocessed by THETRAN)
(RETURN))
(if BINDFLAG
then (for D in PROGDCLS when [OR (EQ NAME D)
(EQ NAME (CAR (LISTP D]
do (DECLVARERROR "more than one binding for " NAME)))
(* TYPEBLOCK=NIL if default ANY with no SATISFIES)
[if (AND TYPEBLOCK (NEQ (SETQ TEMP (fetch BINDFN of TYPEBLOCK))
(CONSTANT DefaultBindFn)))
then (if DPROGFLAG
then [SETQ INITV (CONS TEMP (if INITV
then (LIST INITV)
else
(* Indicate that the initialization is not to be checked)
(SETQ DPROGFLAG NIL]
else (push VARBINDFORMS (LIST (QUOTE REALSETQ)
NAME
(LIST TEMP NAME]
(if (NEQ DECL (QUOTE ANY))
then (* A missing VARDECL is interpreted as ANY, so don't bother to stick
one in.)
(push SAT (create SLISTENTRY
VARNAME _ NAME
VARDECL _(create VARDECL
DECL _ DECL
PROGNFLAG _ PROGNFLAG)))
(* PROGNFLAG means that inherited declarations will be checked)
(if (if INITV
then DPROGFLAG
elseif (NULL DPROGFLAG))
then (push INITVARS NAME))
elseif BINDFLAG
then (* The empty VARDECL conceals type information for higher declarations)
(push SAT (create SLISTENTRY
VARNAME _ NAME
VARDECL _ NIL)))
(if BINDFLAG
then (push PROGDCLS (if INITV
then (LIST NAME INITV)
else NAME)))
(push VARS NAME])
(DLAMARGLIST
[LAMBDA (DEF) (* rmk: " 6-APR-78 10:13")
(if (LISTP (CADR DEF))
then (for A in (CADR DEF) unless (EQ (CAR (LISTP A))
(QUOTE RETURNS))
collect (if (LISTP A)
then (CAR A)
else A))
else (CADR DEF])
(DTYPE?TRAN
[LAMBDA (FORM) (* bas: " 6-NOV-79 16:58")
(SETQ CLISPCHANGE T)
(if LCASEFLG
then (/RPLACA FORM (QUOTE type?)))
[PROG (TESTFORM (TYPEBLOCK (GETDECLTYPE.NOERROR (CADR FORM)))
(FORMS (CDDR FORM)))
(if (NULL TYPEBLOCK)
then (DECLDWIMERROR "invalid type declaration: " (CADR FORM)))
(DWIMIFY0? FORMS FORM NIL NIL NIL FAULTFN) (* The forms are dwimified first so that we can decide whether the
testform should be set-up for a bound VALUE.)
(SETQ FORMS (if (CDR FORMS)
then (CONS (QUOTE PROGN)
FORMS)
else (CAR FORMS)))
(SETQ TESTFORM (APPLYFORM (DECLDWIMTESTFN TYPEBLOCK)
FORMS))
(REALCLISPTRAN FORM (if (NEQ TESTFORM T)
then TESTFORM
elseif (LISTP FORMS)
then (LIST (QUOTE PROGN)
FORMS T)
else (* Cause PPT prints a non-list translation funny)
(QUOTE (PROGN T]
FORM])
(EDITNEWSATLIST
[LAMBDA NIL (* rmk: " 7-SEP-81 03:31")
(* Called from DW edit macro. True if there is no higher declarative on
the current edit chain.)
(DECLARE (USEDFREE L))
(NOTANY (CDR L)
(FUNCTION (LAMBDA (X)
(AND (LISTP X)
[OR (LITATOM (SETQ X (CAR X)))
(LITATOM (SETQ X (CAR X]
(OR (FMEMB X DECLATOMS)
(EQ (CAR (GETPROP X (QUOTE CLISPWORD)))
(QUOTE FORWORD])
(FORMUSESTB
[LAMBDA (FORM TRANS TB) (* rmk: "28-JAN-82 08:39")
(* Decides if FORM or its TRANSlation made use of the definition of the typeblock TB (Currently, T for any decl
expression regardless of typeblock))
(OR [AND (LISTP FORM)
(FMEMB (CAR FORM)
(QUOTE (type? TYPE? the THE DLAMBDA DPROG DPROGN]
(AND (LISTP TRAN)
(OR (EQ (CAR TRAN)
(QUOTE *DECL))
(AND (EQ [CAR (LISTP (GETP (CAR (LISTP FORM))
(QUOTE CLISPWORD]
(QUOTE FORWORD))
(EQ [CAR (LISTP (SETQ TRAN (CAR (LAST TRAN]
(QUOTE RETURN))
(EQ [CAR (LISTP (CAR (LISTP (CDR TRAN]
(QUOTE *DECL])
(IGNOREDECL
[LAMBDA NIL (* rmk: " 4-APR-79 00:04")
(* Should be called only in macros; T if the function currently being
compiled should have debug information suppressed)
(* FN is bound by COMPILE1 during ordinary compile, XXX during block compile. The LISTP check inhibits the EVALV, and is necessary when
called from CHECKVALUEMAC inside masterscope.)
(DECLARE (USEDFREE COMPILEIGNOREDECL))
(OR (EQ COMPILEIGNOREDECL T)
(AND (LISTP COMPILEIGNOREDECL)
(MEMB (EVALV (QUOTE FN)
(QUOTE COMPILE1))
COMPILEIGNOREDECL)
T])
(MAKETESTFORM
[LAMBDA (VAR TYPE) (* rmk: "16-AUG-81 23:12")
(* Makes a form that tests VAR to be of type TYPE and reports errors if
test fails)
(WITH ((TEST (APPLYFORM (fetch TESTFN of TYPE)
VAR)))
(if (EQ TEST T)
then (CBOX COMMENTFLG (LBOX (LBOX (QUOTE ASSERT)
VAR)))
else (LIST (QUOTE OR)
TEST
(LIST (QUOTE ASSERTFAULT)
(WITH ((TN (fetch NAME of TYPE)))
(if (LISTP TN)
then (CONS (QUOTE DECLMSGMAC)
TN)
else (KWOTE TN)))
(KWOTE VAR])
(PPDECL
[LAMBDA (FORM) (* rmk: "28-JUN-82 12:44" posted: "17-MAY-77 22:06")
(* Special prettyprinter for DLAMBDA's and DPROG's.
Called from PRETTYPRINTMACROS)
(DECLARE (GLOBALVARS #RPARS CLISPARRAY PRETTYTRANFLG COMMENTFLG))
(COND
((OR (NLISTP (CDR FORM))
(AND PRETTYTRANFLG (GETHASH FORM CLISPARRAY)))
FORM)
(T (SELECTQ (CAR FORM)
[DLAMBDA (PROG [(FORMPOS (IPLUS 2 (POSITION]
(PRIN1 (COND
(#RPARS "[")
(T "(")))
(PRIN1 "DLAMBDA ")
(PPVARLIST (CADR FORM))
(COND
((AND (LISTP (SETQ FORM (CDDR FORM)))
(NEQ (CAR FORM)
COMMENTFLG))
(printout NIL .TAB0 FORMPOS)))
(PRINTDEF FORM FORMPOS T T FNSLST)
(PRIN1 (COND
(#RPARS "]")
(T ")"]
(DPROG (PROG [FORMPOS (LABELPOS (ADD1 (POSITION]
(* For DPROG's. Highlights the THEN's in the argument
list and formats initial values)
(SETQ FORMPOS (IPLUS LABELPOS 4))
(PRIN1 "(DPROG ")
[COND
((LISTP (CADR FORM))
(PRIN1 "(")
[for V VTAIL (LASTLIST _ T)
(VARPOS _(IPLUS LABELPOS 7)) in (CADR FORM)
do (COND
((LISTP V)
(printout NIL .TAB0 VARPOS "(" .P2 (CAR V))
[COND
((SETQ VTAIL (CDR V))
(SPACES 1)
(for X in old VTAIL do (PRINTDEF X (POSITION)
T NIL FNSLST)
repeatwhile (FMEMB (COND
((AND (LISTP X)
(NLISTP (CADR VTAIL)))
(NTHCHAR (CADR VTAIL)
1))
((AND (NLISTP X)
(LISTP (CADR VTAIL)))
(NTHCHAR X -1)))
CLISPCHARS)
finally (SETQ VTAIL (CDR VTAIL)))
(* Supress spaces in clisp initial values)
(for X in VTAIL do (SPACES 1)
(PRINTDEF X (POSITION)
T NIL FNSLST]
(COND
((ILESSP (POSITION)
VARPOS)
(TAB VARPOS)
(PRIN1 ")"))
(T (PRIN3 ")")))
(SETQ LASTLIST T))
((EQ V (QUOTE THEN))
(printout NIL .TAB0 (IPLUS LABELPOS 2)
(QUOTE THEN)))
(T (COND
(LASTLIST (TAB VARPOS 0))
(T (SPACES 1)))
(SETQ LASTLIST NIL)
(PRIN2 V]
(PRIN3 ")"))
(T (PRIN2 (CADR FORM]
[for F in (CDDR FORM) do (COND
((LITATOM F)
(printout NIL .TAB LABELPOS .P2 F))
(T (COND
((NEQ (CAR (LISTP F))
COMMENTFLG)
(printout NIL .TAB0 FORMPOS)))
(PRINTDEF F (POSITION)
T NIL FNSLST]
(PRIN1 ")")))
(DECL (PRIN1 "(DECL ")
(PPVARLIST (CDR FORM)
T)
(PRIN3 ")"))
(DPROGN (PROG [(FORMPOS (IPLUS 3 (POSITION]
(PRIN1 "(DPROGN ")
(PPVARLIST (CADR FORM))
(COND
((AND (LISTP (SETQ FORM (CDDR FORM)))
(NEQ (CAR FORM)
COMMENTFLG))
(printout NIL .TAB0 FORMPOS)))
(PRINTDEF FORM FORMPOS T T FNSLST)
(PRIN1 ")")))
NIL)
NIL])
(PPVARLIST
[LAMBDA (VLIST TAILFLG) (* rmk: "12-JUN-78 16:07")
(* Pretty-prints the variable declarations for DLAMBDA, DPROGN, DECL.
The list begins at the current line position;
unless TAILFLG, enclosing parens are printed)
(if (LISTP VLIST)
then (OR TAILFLG (PRIN1 "("))
(for V (VARPOS _(POSITION))
LASTLIST_T in VLIST do (if (LISTP V)
then (printout NIL .TAB0 VARPOS "(" .P2 (CAR V))
(for X in (CDR V) do (SPACES 1)
(PRINTDEF X (POSITION)
T NIL FNSLST))
(if (ILESSP (POSITION)
VARPOS)
then (TAB VARPOS)
(PRIN1 ")")
else (PRIN3 ")"))
(SETQ LASTLIST T)
else (if LASTLIST
then (TAB VARPOS 0)
else (SPACES 1))
(SETQ LASTLIST NIL)
(PRIN2 V))
finally (if $$LST1
then (PRIN1 " . ")
(PRIN2 $$LST1)))
(OR TAILFLG (PRIN3 ")"))
else (PRIN2 VLIST])
(SETQMAC
[LAMBDA (ARGS) (* bas: "18-OCT-79 18:22")
(* Compiler macro for SETQ. Enforces declarations.)
(PROG [SETFORM (TB (TYPEBLOCKOF (CAR ARGS]
(SETQ SETFORM (CONS (fetch SETFN of TB)
ARGS))
(* We can suppress the run time test if either IGNOREDECLS, type is ANY, the value is a constant which passes the test fn now, or TB
covers the possible set of values. Can't do constant evaluation if there's a setfn, cause a setfn clearly must have side-effects, and it
may be doing coercions.)
(RETURN (if [OR (IGNOREDECL)
(EQ (fetch TYPEXP of TB)
(QUOTE ANY))
[AND (EQ (fetch SETFN of TB)
(CONSTANT DefaultSetFn))
(DECLCONSTANTP (CADR ARGS))
(PROG (TEMP HELPFLAG (TST (fetch TESTFN of TB)))
(DECLARE (SPECVARS HELPFLAG))
(RETURN (AND (OR (SUBRP TST)
(NOT (FREEVARS TST)))
[NLSETQ (OR [SETQ TEMP (APPLY* TST
(EVAL (CADR ARGS]
(COMPEM
" Warning: Probable type fault in"
(CONS (QUOTE SETQ)
ARGS]
TEMP]
(COVERSTB TB (TYPEBLOCKOF (if (EQ (fetch SETFN of TB)
(CONSTANT DefaultSetFn))
then SETFORM
else (CADR ARGS]
then (* The variable's type includes the value's, so we're OK.)
SETFORM
else (* PROG1 is used rather than embedding the SETFORM in the test to give
MAKEAPPLYFORM a better chance of simplifying)
(LIST (QUOTE PROG1)
SETFORM
(MAKETESTFORM (CAR ARGS)
TB])
(THETRAN
[LAMBDA (FORM) (* rmk: "16-AUG-81 23:12")
(DECLARE (USEDFREE LCASEFLG CLISPCHANGE))
(SETQ CLISPCHANGE T)
(if LCASEFLG
then (/RPLACA FORM (QUOTE the)))
[WITH [(TYPEBLOCK (GETDECLTYPE.NOERROR (CADR FORM]
(if (NULL TYPEBLOCK)
then (DECLDWIMERROR "invalid type declaration: " (CADR FORM)))
(DWIMIFY0? (CDDR FORM)
FORM
(CDDR FORM)
NIL NIL FAULTFN)
(WITH [(TESTFORM (APPLYFORM (DECLDWIMTESTFN TYPEBLOCK)
(QUOTE VALUE)))
(VALFORM (if (CDDDR FORM)
then (CONS (QUOTE PROGN)
(CDDR FORM))
else (CADDR FORM]
(REALCLISPTRAN FORM
(if (EQ TESTFORM T)
then VALFORM
else (LIST (QUOTE CHKVAL)
(APPLYFORM
[LAMVAL (LIST (QUOTE COND)
(LIST TESTFORM (QUOTE VALUE))
(LIST T
(LIST (QUOTE VALUEERROR)
(QUOTE VALUE)
(if (LISTP (CADR FORM))
then (CONS (QUOTE
DECLMSGMAC)
(CADR FORM))
else (KWOTE (CADR FORM]
VALFORM]
FORM])
(VALUEERROR
[LAMBDA (VALUE DECL) (* rmk: "16-AUG-81 15:48")
(DECLARE (SPECVARS VALUE))
(LISPXPRIN1 "
VALUE ASSERTION NOT SATISFIED IN " T)
(bind POS when [LITATOM (STKNAME (SETQ POS (REALSTKNTH -1 (OR POS (QUOTE VALUEERROR))
NIL POS]
do (LISPXPRIN2 (STKNAME POS)
T)
(RELSTK POS)
(RETURN))
(* VALUE is the break expression so that an OK will simply return it. Also, typing the command VALUE in the break will cause VALUE to be
printed out, given the EVAL command that sets it up. There are some paradoxes though: If the user sets VALUE, he will not see the change
in the break unless he does another EVAL. Instead, he must work with !VALUE.)
(APPLY* (FUNCTION BREAK1)
(QUOTE VALUE)
T
(LIST (QUOTE VALUE)
DECL)
(QUOTE (EVAL])
(VARASRT
[LAMBDA (VARNAME) (* rmk: " 2-DEC-78 14:47")
(* Checks all the declaration predicates for VARNAME in the run-time
context.)
(DECLARE (LOCALVARS . T)
(USEDFREE SATISFIESLIST))
(VARASRT1 VARNAME SATISFIESLIST])
(VARASRT1
[LAMBDA (VARNAME SLIST) (* bas: " 9-OCT-79 23:24")
(* Checks all run-time assertions for VARNAME.
Evaluates the highest predicate in the current scope first for DPROGN
variables.)
(DECLARE (LOCALVARS . T))
(for S D in old SLIST when (SETQ D (ASSOC VARNAME S))
do (if (NULL (SETQ D (fetch VARDECL of D)))
then (RETURN))
(if (fetch PROGNFLAG of D)
then (VARASRT1 VARNAME (CDR SLIST)))
(if (APPLY* (fetch TESTFN of (GETDECLTYPE (fetch DECL of D)
VARNAME))
(EVALV VARNAME))
then (RETURN))
(ASSERTFAULT (fetch DECL of D)
VARNAME])
(VARSETFN
[LAMBDA (VARNAME) (* bas: "18-OCT-79 19:11")
(* Called by DECLSET and returns the setfn for VARNAME, or NIL if there isn't one. The setfn is the lowest one found on a DPROGN chain.
Should should be equivalent to (fetch SETFN of (VARDECL VARNAME T)), but is opencoded to avoid consing up the type each time.)
(DECLARE (USEDFREE SATISFIESLIST))
(for S TEMP D in SATISFIESLIST when (SETQ D (ASSOC VARNAME S))
do (RETURN (fetch SETFN of (GETDECLTYPE (if (NULL (SETQ D (fetch VARDECL of D)))
then (QUOTE ANY)
else (fetch DECL of D))
VARNAME)))
finally (RETURN (CONSTANT DefaultSetFn])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: DECLTRAN DECLTRAN DECLVAR)
(BLOCK: PPDECL PPDECL PPVARLIST)
(BLOCK: VARASRT VARASRT VARASRT1)
]
(* Declaration database fns)
(DEFINEQ
(DECLOF
[LAMBDA (FORM DECLCONTEXT) (* bas: "31-JUL-79 13:40")
(* Returns a declaration for FORM in the context maintained by the code
reading system DECLCONTEXT)
(DECLARE (USEDFREE CSATISFIESLIST SATISFIESLIST DECLVARSLST))
(fetch NAME of (TBOF FORM (SELECTQ DECLCONTEXT
(COMPILER CSATISFIESLIST)
(INTERPRETER SATISFIESLIST)
(NIL (if (BOUNDP DECLVARSLST)
then DECLVARSLST
else CSATISFIESLIST))
(ERRORX (LIST 27 DECLCONTEXT])
(DECLOF1
[LAMBDA (FORM) (* rmk: " 4-SEP-80 00:05")
(* Computes a declaration form for FORM.
May be redundant as it will be checked in DECLOF.)
(if (LITATOM FORM)
then (SELECTQ FORM
(NIL NIL)
(T (QUOTE (MEMQ T)))
(VARDECL FORM))
elseif (LISTP FORM)
then
[PROG (TEMP)
(RETURN
(if (LITATOM (CAR FORM))
then
[OR
(if (AND (EQ [CAR (LISTP (SETQ TEMP (GETP (CAR FORM)
(QUOTE DECLOF]
(QUOTE FUNCTION))
(NEQ (CAR (LISTP (CDR TEMP)))
(QUOTE SATISFIES)))
then (APPLY* (CADR TEMP)
FORM)
else TEMP)
(SELECTQ
(CAR FORM)
[(SETQ SETQQ)
(PROG [VSF (VD (VARDECL (CADR FORM]
(SETQ VSF (fetch SETFN of (GETDECLTYPE VD)))
(RETURN (if (EQ VSF (CONSTANT DefaultSetFn))
then [LIST (QUOTE ALLOF)
VD
(if (EQ (CAR FORM)
(QUOTE SETQQ))
then (LIST (QUOTE MEMQ)
(CADDR FORM))
else (DECLOF1 (CADDR FORM]
else (DECLOF1 (CONS VSF (CDR FORM]
[PROG (* Declaration is known only if the first and only executable statement
in the prog is a RETURN)
(for TAIL TEMP on (CDDR FORM) suchthat (SELECTQ (SETQ TEMP
(CAAR TAIL))
((ASSERT DECLARE)
NIL)
(NEQ TEMP COMMENTFLG))
finally (RETURN (if (AND (EQ TEMP (QUOTE RETURN))
(NULL (CDR TAIL)))
then (DECLOF1 (CADAR TAIL))
else (QUOTE ANY]
[PROGN (DECLOF1 (CAR (LAST FORM]
[COND (for CL D TFLAG in (CDR FORM)
unless
(if (EQ [SETQ D (DECLOF1 (CAR (LAST CL]
(QUOTE ANY))
then (RETURN (QUOTE ANY))
else (if (EQ (CAR CL)
T)
then (SETQ TFLAG T))
(MEMBER D $$VAL))
collect D finally (if (NOT (OR TFLAG (FMEMB NIL $$VAL)))
then (SETQ $$VAL (NCONC1 $$VAL NIL)))
(RETURN (if (CDR $$VAL)
then (CONS (QUOTE ONEOF)
$$VAL)
else (CAR $$VAL]
[SELECTQ (for TAIL D on (CDDR FORM)
unless (if (EQ [SETQ D (DECLOF1 (if (CDR TAIL)
then
(CAR (LAST (CDAR TAIL)))
else (CAR TAIL]
(QUOTE ANY))
then (RETURN (QUOTE ANY))
else (MEMBER D $$VAL))
collect D finally (RETURN (if (CDR $$VAL)
then (CONS (QUOTE ONEOF)
$$VAL)
else (CAR $$VAL]
((REPLACEFIELD FREPLACEFIELD /REPLACEFIELD)
(DECLOF1 (CADDDR FORM)))
(REALSETQ (DECLOF1 (CADDR FORM)))
((FETCHFIELD FFETCHFIELD)
(if (FIXP (CADR FORM))
then (SELECTQ (LRSH (LOGAND (CADR FORM)
12582912)
22)
(1 (QUOTE FIXP))
(2 (QUOTE FLOATP))
(3 (* FLAG)
(QUOTE (MEMQ NIL T)))
(PROGN
(* 0=pointer)
(QUOTE ANY)))
else (QUOTE ANY)))
(REPLACEFIELDVAL (DECLOF1 (CADDR FORM)))
(PROG1 (DECLOF1 (CADR FORM)))
[*DECL (PROG [(DECLVARSLST (if [OR (NULL (CADR FORM))
(LISTP (CAR (CAADR FORM]
then (CADR FORM)
else (CONS (CADR FORM)
DECLVARSLST]
(* Maintain proper DECLVARSLST for recursion)
(DECLARE (SPECVARS DECLVARSLST))
(RETURN (DECLOF1 (CAR (LAST (CDDR FORM]
((the THE)
(CADR FORM))
((create CREATE)
(CADR FORM))
(QUOTE (* Could be done in the constant eval, but here for efficiency cause
very common)
(LIST (QUOTE MEMQ)
(CADR FORM)))
(if (AND (NEQ FORM (SETQ TEMP (EXPANDMACRO FORM T)))
(NEQ TEMP (QUOTE IGNOREMACRO)))
then (DECLOF1 TEMP)
else
(SELECTQ (GETP (CAR FORM)
(QUOTE CTYPE))
(FNF (QUOTE FLOATP))
(INF (QUOTE FIXP))
(if [SETQ TEMP
(OR (GETHASH FORM CLISPARRAY)
(AND (GETP (CAR FORM)
(QUOTE CLISPWORD))
(RESETVARS (FILEPKGFLG (NOSPELLFLG T)
(DWIMESSGAG T))
(DWIMIFY0? FORM FORM)
(RETURN (GETHASH FORM CLISPARRAY]
then (DECLOF1 TEMP)
elseif (DECLCONSTANTP FORM)
then (LIST (QUOTE MEMQ)
(EVAL FORM))
else (QUOTE ANY]
elseif [AND (LISTP (CAR FORM))
(SETQ TEMP (SELECTQ (CAAR FORM)
[[LAMBDA NLAMBDA]
(CAR (LAST (CDDAR FORM]
(PROGN
(* Hope it's a translated LAMBDAWORD)
(GETHASH (CAR FORM)
CLISPARRAY]
then (DECLOF1 TEMP)
else (QUOTE ANY]
else (LIST (QUOTE MEMQ)
FORM])
(TBOF
[LAMBDA (FORM DECLVARSLST) (* bas: " 9-OCT-79 23:27")
(* Returns a type block for the value of form)
(DECLARE (SPECVARS DECLVARSLST)) (* DECLVARSLST is SPECIAL for an eventual call on VARDECL on an atom.)
(GETDECLTYPE (DECLOF1 FORM])
(TYPEBLOCKOF
[LAMBDA (FORM) (* bas: "31-JUL-79 13:40")
(* Gets type block for compiler declaration of FORM)
(DECLARE (USEDFREE CSATISFIESLIST))
(TBOF FORM CSATISFIESLIST])
(VARDECL
[LAMBDA (VARNAME) (* bas: "30-JUL-79 18:07")
(* Returns the declaration for VARNAME.
The declaration will include all inherited attributes for DPROGN
variables.)
(DECLARE (USEDFREE DECLVARSLST))
(for S ONE DECLS D in DECLVARSLST when (SETQ D (fetch VARDECL of (ASSOC VARNAME S)))
do (if ONE
then (SETQ DECLS (LIST (fetch DECL of D)
ONE)) (* ONE is to avoid the cons in the common single-test case)
(SETQ ONE NIL)
elseif DECLS
then (push DECLS (fetch DECL of D))
else (SETQ ONE (fetch DECL of D)))
(if (NOT (fetch PROGNFLAG of D))
then (GO $$OUT))
finally (RETURN (if DECLS
then (CONS (QUOTE ALLOF)
(DREVERSE DECLS))
elseif ONE
else (QUOTE ANY])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: DECLOFBLK DECLOF DECLOF1 TBOF TYPEBLOCKOF VARDECL (ENTRIES DECLOF TYPEBLOCKOF))
]
(* Enabling and disabling fns)
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(ACCESSFNS FNEQUIVS ((DECLFN (PACK* (QUOTE DECL)
DATUM))
(REALFN (PACK* (QUOTE REAL)
DATUM))))
]
(DECLARE: EVAL@COMPILE
(PUTPROPS MOVEPROP MACRO ((PROP FROM TO)
(PUTIFPROP TO PROP (GETPROP FROM PROP))))
(PUTPROPS PUTIFPROP MACRO [(ATM PROP VAL)
(WITH ((V VAL))
(COND
(V (PUTPROP ATM PROP V))
(T (REMPROP ATM PROP)
NIL])
)
)
(DEFINEQ
(STARTDECLS
[LAMBDA NIL (* rmk: " 3-FEB-82 22:41")
(* Repository of various code that sets up dummy function defns and other things that would require P commands in
the file coms. Distinct from DODECLS which actually activates DECLs.)
(for I in (QUOTE (DECL WHOSE)) do (MOVD? (QUOTE QUOTE)
I))
(for I in (QUOTE (CHKVAL DECLPROGN)) do (MOVD? (QUOTE PROGN)
I))
[for I in (QUOTE (CHANGERECORD CLISPTRAN SETQ SET SETQQ))
do (AND (MOVD? I (fetch REALFN of I))
(FMEMB I SYSLINKEDFNS)
(push LINKEDFNS (fetch REALFN of I]
(MOVEPROP (QUOTE BYTEMACRO)
(QUOTE SETQ)
(QUOTE REALSETQ))
(MOVEPROP (QUOTE MACRO)
(QUOTE SET)
(QUOTE REALSET))
(if (AND (BOUNDP (QUOTE DECLTYPESARRAY))
(EQ (ASKUSER DWIMWAIT (QUOTE N)
"Reinitialize DECLTYPE lattice? ")
(QUOTE N)))
else (INITDECLTYPES))
(for I in (QUOTE ((COVERS CALL (IF (EQ (CAR EXPR)
(QUOTE QUOTE))
[NIL (@(TYPEMSANAL COVERS)
(QUOTE ((.. TYPE]
EVAL)
(IF (EQ (CAR EXPR)
(QUOTE QUOTE))
[NIL (@(TYPEMSANAL COVERS)
(QUOTE ((.. TYPE]
EVAL) . PPE)
(SELCOVERSQ . MACRO)
(SELTYPEQ . MACRO)
(*DECL NIL [IF NULL NIL (IF (LISTP (CAAR EXPR))
[(.. (@(TYPEMSANAL *DECL)
(QUOTE ((.. TYPE)
TEST]
(.. (@(TYPEMSANAL *DECL)
(QUOTE ((.. TYPE)
TEST]
.. EFFECT RETURN)
(CHKINIT NIL)
(CHKVAL NIL EVAL)
(THE @(TYPEMSANAL the)
(QUOTE (CLISP (.. TYPE)
RETURN)))
(TYPE? @(TYPEMSANAL type?)
(QUOTE (CLISP (.. TYPE)
RETURN)))
(the @(TYPEMSANAL the)
(QUOTE (CLISP (.. TYPE)
RETURN)))
(type? @(TYPEMSANAL type?)
(QUOTE (CLISP (.. TYPE)
RETURN)))
(VALUEERROR NIL)))
do (PUTHASH (CAR I)
(CDR I)
MSTEMPLATES))
(DODECLS T])
(DODECLS
[LAMBDA (FLG) (* DECLARATIONS: (RECORD DSF
(ATM FN . PRPLST)))
(DECLARE (USEDFREE COMPILEIGNOREDECL)) (* rmk: " 3-FEB-82 22:42")
(* Turns decls on if FLG; off if not. If turning on when they are currently off, then the old values are saved in a
private cons so they can be restored if DECLS are turned off.)
(SETQ COMPILEIGNOREDECL (NOT FLG)) (* Reset the compile switch)
(WITH [[DECLSETFROM (QUOTE ((CHANGERECORD T)
(CLISPTRAN T)
(SET T)
(SETQ T BYTEMACRO NIL MACRO (ARGS (SETQMAC ARGS)))
(SETQQ T)
(TYPE? NIL CLISPWORD (DTYPE?TRAN . type?))
(type? NIL CLISPWORD (DTYPE?TRAN . type?]
(DECLUNSAVELST (CONSTANT (LIST NIL]
[if (AND FLG (NOT (CAR DECLUNSAVELST)))
then (* Collect the values to be restored)
(RPLACA DECLUNSAVELST (for F in DECLSETFROM
collect (create DSF
ATM _(fetch ATM of F)
FN _(GETD (fetch ATM of F))
PRPLST _(for J
on (fetch PRPLST of F)
by (CDDR J)
join
(LIST (CAR J)
(GETPROP (fetch ATM
of F)
(CAR J]
[for F in (if FLG
then DECLSETFROM
else (CAR DECLUNSAVELST))
do [WITH ((DEF (fetch FN of F)))
(AND DEF (PUTD (fetch ATM of F)
(if (AND FLG (EQ DEF T))
then (GETD (fetch DECLFN of (fetch ATM of F)))
else DEF]
(for J on (fetch PRPLST of F) by (CDDR J) do (PUTIFPROP (fetch ATM of F)
(CAR J)
(CADR J]
(if FLG
else (RPLACA DECLUNSAVELST NIL) (* Nothing saved anymore)))
FLG])
)
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
LAMBDATRAN)
(DECLARE: EVAL@COMPILE
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
SIMPLIFY)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
NOBOX)
(* Definition of WITH. From <SHEIL>WITH.)
(DECLARE: EVAL@COMPILE
(PUTPROPS WITH MACRO [ARGS (CONS (CONS (QUOTE LAMBDA)
(CONS [for I in (CAR ARGS) collect (COND
((LITATOM I)
I)
((LISTP I)
(CAR I))
(T (ERROR
"Invalid WITH form binding"
I]
(CDR ARGS)))
(for I in (CAR ARGS) collect (CADR (LISTP I])
)
(SETTEMPLATE (QUOTE WITH)
(QUOTE ((BOTH (.. (IF LISTP (NIL EVAL .. EFFECT)
NIL))
(.. (IF LISTP (BIND EVAL .. EFFECT)
BIND)))
.. EFFECT RETURN)))
(REMPROP (QUOTE WITH)
(QUOTE CLISPWORD))
(ADDTOVAR DWIMEQUIVLST (WITH . PROG))
(ADDTOVAR PRETTYEQUIVLST (WITH . PROG))
)
[OR (GETPROP (QUOTE LOADTIMECONSTANT)
(QUOTE FILEDATES))
(PROG ((X (FINDFILE (QUOTE LOADTIMECONSTANT.COM)
T LISPUSERSDIRECTORIES)))
(COND (X (LOAD X (QUOTE SYSLOAD)))
((NOT (GETPROP (QUOTE LOADTIMECONSTANT)
(QUOTE MACRO)))
(PUTPROP (QUOTE LOADTIMECONSTANT)
(QUOTE MACRO)
(QUOTE ((FORM)
(CONSTANT FORM]
(ADDTOVAR OPENFNS DECLPROGN CHKVAL CHKINIT ASSERT *DECL VARASRT)
(PUTPROPS DPROG CLISPWORD (DECLTRAN . DPROG))
(PUTPROPS DPROGN CLISPWORD (DECLTRAN . DPROGN))
(PUTPROPS THE CLISPWORD (THETRAN . the))
(PUTPROPS the CLISPWORD (THETRAN . the))
(PUTPROPS DLAMBDA INFO BINDS)
(PUTPROPS DPROG INFO (BINDS LABELS))
(PUTPROPS DPROGN INFO EVAL)
(RPAQQ SATISFIESLIST NIL)
(RPAQQ CSATISFIESLIST NIL)
(RPAQQ NEWSATLIST T)
(ADDTOVAR DECLATOMS DLAMBDA DPROG DPROGN)
(ADDTOVAR LAMBDASPLST DLAMBDA)
(ADDTOVAR DECLMESSAGES )
(ADDTOVAR COMPILEIGNOREDECL )
(ADDTOVAR SYSLOCALVARS VALUE)
(ADDTOVAR DESCRIBELST ["types: " (GETRELATION FN (QUOTE (USE TYPE])
(ADDTOVAR BAKTRACELST (DECLPROGN (DPROGN APPLY *PROG*LAM *DECL *ENV*)
(NIL APPLY *PROG*LAM *DECL))
(PROG (DPROG DECLPROGN APPLY *PROG*LAM *DECL)))
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD SLISTENTRY (VARNAME . VARDECL))
(RECORD VARDECL (DECL . PROGNFLAG))
]
)
(ADDTOVAR LAMBDATRANFNS (DLAMBDA DECLTRAN EXPR DLAMARGLIST))
(DECLARE: DONTEVAL@LOAD
(ADDTOVAR PRETTYPRINTMACROS (DPROGN . PPDECL)
(DECL . PPDECL)
(DLAMBDA . PPDECL)
(DPROG . PPDECL))
)
(PUTPROPS ASSERT INFO EVAL)
(DECLARE: EVAL@COMPILE
(PUTPROPS ASSERT MACRO (ARGS (ASSERTMAC ARGS)))
(PUTPROPS .CBIND. BYTEMACRO [APPLY (LAMBDA (PV BODY)
(APPLY* (QUOTE PROG)
PV
(QUOTE (RETURN (CEXP1 BODY])
(PUTPROPS .CBIND. 10MACRO (X (APPLY* (QUOTE PROG)
(CAR X)
(QUOTE (COMP (CADR X)
VCF PCF PIF NCF)))
(SETQ PCF (SETQ NCF))
(QUOTE INSTRUCTIONS)))
(PUTPROPS .CBIND. MACRO (X (HELP "Compiler dependent macro must be supplied for .CBIND.")))
(PUTPROPS CHKINIT MACRO (ARGS (CHKINITMAC ARGS)))
(PUTPROPS CHKVAL MACRO [ARGS (COND
[(IGNOREDECL)
(COND
((EQ (CAAR ARGS)
(QUOTE COND))
(CADADR (CAR ARGS)))
(T (CADAR ARGS]
(T (CAR ARGS])
(PUTPROPS *DECL MACRO (ARGS (*DECLMAC ARGS)))
(PUTPROPS DECL MACRO (X (COMPEM "DECL in illegal location" (CONS (QUOTE DECL)
X))))
(PUTPROPS DECLMSGMAC DMACRO ((X . Y)
(CONSTANT (DECLMSG X . Y))))
(PUTPROPS DECLMSGMAC MACRO ((X . Y)
(LOADTIMECONSTANT (DECLMSG X . Y))))
(PUTPROPS REALSETQ MACRO (X (CEXP (CADR X))
(VARCOMP (CAR X))
(STORIN (LIST (QUOTE STV)
(CAR X)
SP))
(QUOTE INSTRUCTIONS)))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS REALSET DMACRO T)
)
(AND (GETD (QUOTE STARTDECLS))
(STARTDECLS))
[PROG [(COM (CDR (ASSOC (QUOTE DW)
EDITMACROS]
(AND COM (RPLACD COM (CONS (APPEND (QUOTE (RESETVAR NEWSATLIST (EDITNEWSATLIST)))
(CDR COM]
(* Builtin DECLOF properties)
(PUTPROPS APPEND DECLOF LST)
(PUTPROPS CONS DECLOF LISTP)
(PUTPROPS EQ DECLOF (MEMQ T NIL))
(PUTPROPS LIST DECLOF [FUNCTION (LAMBDA (FORM)
(AND (CDR FORM)
(QUOTE LISTP])
(PUTPROPS LISTP DECLOF LST)
(PUTPROPS NCONC DECLOF LST)
(DECLARE: EVAL@COMPILE DONTCOPY
(RESETSAVE DWIMIFYCOMPFLG NIL)
[AND (GETD (QUOTE DODECLS))
(RESETSAVE (DODECLS)
(QUOTE (DODECLS T]
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DECLSETQ DECLMSG DD CHKINIT *DECL ASSERT DECLTYPES DECLTYPE)
(ADDTOVAR NLAML DECLSETQQ TYPEMSANAL)
(ADDTOVAR LAMA DECLDWIMERROR)
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (6998 9668 (DECLTYPE 7010 . 7170) (DECLTYPES 7174 . 7463) (DUMPDECLTYPES 7467 . 8805) (
GETDECLDEF 8809 . 9665)) (10365 12480 (COVERS 10377 . 10555) (GETDECLTYPEPROP 10559 . 10725) (
SETDECLTYPEPROP 10729 . 11140) (SUBTYPES 11144 . 11753) (SUPERTYPES 11757 . 12477)) (15047 46448 (
CHECKTYPEXP 15059 . 15351) (COLLECTTYPES 15355 . 16630) (COVERSCTYPE 16634 . 17409) (COVERSTB 17413 .
17840) (COVERSTE 17844 . 18535) (CREATEFNPROP 18539 . 18939) (CREATEFNVAL 18943 . 19471) (DECLERROR
19475 . 19701) (DELETETB 19705 . 20471) (FINDDECLTYPE 20475 . 20996) (FINDPROP 21000 . 21179) (
FINDTYPEXP 21183 . 21892) (GETCTYPE 21896 . 22323) (GETDECLTYPE 22327 . 22833) (GETDECLTYPE.NOERROR
22837 . 23537) (GETTBPROP 23541 . 23950) (INHERITPROP 23954 . 25210) (INITDECLTYPES 25214 . 27625) (
LCCTYPE 27629 . 28012) (LCC2 28016 . 28507) (MAKECTYPE 28511 . 29859) (MAKEDECLTYPE 29863 . 30671) (
MAKEBINDFN 30675 . 30943) (MAKESETFN 30947 . 31211) (MAPTYPEUSERS 31215 . 31452) (NOTICETB 31456 .
31874) (PPDTYPE 31878 . 33748) (RECDTYPE 33752 . 35417) (DECLCHANGERECORD 35421 . 36340) (RECDEFTYPE
36344 . 37464) (REPROPTB 37468 . 38672) (SETTBPROP 38676 . 39593) (TBDEFPRINT 39597 . 39944) (TETYPE
39948 . 40502) (TYPEMSANAL 40506 . 41868) (TYPEMSANAL1 41872 . 42963) (UNCOMPLETE 42967 . 43768) (
UNSAVETYPE 43772 . 44317) (USERDECLTYPE 44321 . 45578) (USESTYPE 45582 . 46445)) (46617 54170 (
MAKETESTFN 46629 . 47018) (MAKETESTFNBLOCK 47022 . 49850) (COMBINE.TESTS 49854 . 50564) (FUNIFY 50568
. 51035) (MKNTHCAR 51039 . 51526) (MKNTHCDR 51530 . 52148) (OF.TESTFN 52152 . 52537) (TUPLE.TESTFN
52541 . 53125) (WHOSE.TESTFN 53129 . 54167)) (56037 56437 (TESTFORM 56049 . 56434)) (56678 58346 (
EVERYCHAR 56690 . 56965) (LARGEP 56969 . 57192) (DECLRECURSING 57196 . 58004) (SMASHCAR 58008 . 58343)
) (59086 100692 (ASSERT 59098 . 59603) (ASSERTFAULT 59607 . 60162) (ASSERTMAC 60166 . 60897) (*DECL
60901 . 62033) (*DECLMAC 62037 . 63728) (CHKINIT 63732 . 64411) (CHKINITMAC 64415 . 65479) (
DECLCONSTANTP 65483 . 66695) (DD 66699 . 67248) (DECLCLISPTRAN 67252 . 70715) (DECLMSG 70719 . 71948)
(DECLDWIMERROR 71952 . 72376) (DECLDWIMTESTFN 72380 . 73114) (DECLSET 73118 . 73677) (DECLSETQ 73681 .
74346) (DECLSETQQ 74350 . 74518) (DECLTRAN 74522 . 80275) (DECLVAR 80279 . 85768) (DLAMARGLIST 85772
. 86111) (DTYPE?TRAN 86115 . 87211) (EDITNEWSATLIST 87215 . 87767) (FORMUSESTB 87771 . 88480) (
IGNOREDECL 88484 . 89205) (MAKETESTFORM 89209 . 89937) (PPDECL 89941 . 93440) (PPVARLIST 93444 . 94622
) (SETQMAC 94626 . 96515) (THETRAN 96519 . 97760) (VALUEERROR 97764 . 98669) (VARASRT 98673 . 99040) (
VARASRT1 99044 . 99900) (VARSETFN 99904 . 100689)) (100893 108654 (DECLOF 100905 . 101549) (DECLOF1
101553 . 106927) (TBOF 106931 . 107311) (TYPEBLOCKOF 107315 . 107613) (VARDECL 107617 . 108651)) (
109331 113683 (STARTDECLS 109343 . 111611) (DODECLS 111615 . 113680)))))
STOP