(FILECREATED "15-Sep-87 10:22:48" {QV}<LFG>PARSER>DECL.;1 120851 

      changes to:  (FNS *DECLMAC)

      previous date: "12-Mar-85 09:15:44" {ERIS}<LISP>KOTO>LIBRARY>DECL.;1)


(* Copyright (c) 1983, 1984, 1985, 1987 by Xerox Corporation. All rights reserved.)

(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]
	[DECLARE: DOCOPY (DECLARE: EVAL@LOADWHEN (NEQ (SYSTEMTYPE)
						      (QUOTE D))
				   (P (OR (GETPROP (QUOTE LOADTIMECONSTANT)
						   (QUOTE FILEDATES))
					  (PROG ((X (FINDFILE (PACKFILENAME (QUOTE NAME)
									    (QUOTE LOADTIMECONSTANT)
									    (QUOTE EXTENSION)
									    COMPILE.EXT)
							      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))
	(INITVARS (DECLMESSAGES)
		  (COMPILEIGNOREDECL))
	[ADDVARS (DECLATOMS DLAMBDA DPROG DPROGN)
		 (LAMBDASPLST DLAMBDA)
		 (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

(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))
		  (QUOTE ((TYPEBLOCK 0 POINTER)
			  (TYPEBLOCK 2 POINTER)
			  (TYPEBLOCK 4 POINTER)
			  (TYPEBLOCK 6 POINTER)
			  (TYPEBLOCK 8 POINTER)
			  (TYPEBLOCK 10 POINTER)))
		  (QUOTE 12))


(ADDTOVAR PRETTYPRINTYPEMACROS (TYPEBLOCK . PPDTYPE))
)
(/DECLAREDATATYPE (QUOTE TYPEBLOCK)
		  (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER))
		  (QUOTE ((TYPEBLOCK 0 POINTER)
			  (TYPEBLOCK 2 POINTER)
			  (TYPEBLOCK 4 POINTER)
			  (TYPEBLOCK 6 POINTER)
			  (TYPEBLOCK 8 POINTER)
			  (TYPEBLOCK 10 POINTER)))
		  (QUOTE 12))
(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)
    (COND
      ((LISTP TE)                                            (* TE must be in CLISPARRAY to detect edits of the type 
							     expression)
	(AND (GETHASH TE CLISPARRAY)
	     (GETHASH TE DECLTYPESARRAY)))
      (T (OR (GETHASH TE DECLTYPESARRAY)
	     (RECDTYPE TE])

(FINDPROP
  [LAMBDA (L P)                                              (* rmk: "12-Mar-85 08:56")
    (for TAIL on L by (CDR (LISTP (CDR TAIL))) thereis (EQ P (CAR TAIL])

(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)                                               (* rmk: "18-Feb-85 18:07")
                                                             (* returns the type of a type expression)
    (if (LITATOM TE)
	then (QUOTE PRIMITIVE)
      elseif (LISTP TE)
	then (SELECTQ (CAR 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: " 9-NOV-83 09:24")
                                                            (* 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)                                          (* rmk: "18-Feb-85 18:14")
                                                             (* 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))
			 (AND [LISTP (CDR (LISTP (CDR 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) when (LISTP (CDR (LISTP I)))
			       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 

(QUOTE (LARGEP -- no MACRO definition))
)
)
(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                                             (* rmk: "11-NOV-83 08: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: "11-NOV-83 07:59")
                                                            (* 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: "15-Sep-87 10:16")
    (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)

          (* Should maintain list of free variables for the benefit of clisp words arising in macros, but FREEVARS in 
	  compiling context has different meaning from FREEVARS in dwimify context. Interlisp-D byte compiler gets confused.)


	    (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 [PROG1 NIL 
                                                             (* (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: " 9-NOV-83 09:20")
                                                            (* 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: " 2-Nov-84 15:30")
    [PROG [DECL DFORM DPROGFLAG RETURNS (DECLARETAGS (QUOTE (LOCALVARS SPECVARS ADDTOVAR DEFLIST 
								       PUTPROPS CONSTANTS SETQQ 
								       USEDFREE TYPE]
          (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)                                         (* rmk: "11-NOV-83 08:00")

          (* 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                                                (* rmk: "11-NOV-83 08:00")

          (* 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: " 2-Nov-84 15:24")
                                                             (* 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 DECLARE 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 CARDINAL))
				   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: " 2-Nov-84 15:33")
    (DECLARE (USEDFREE FAULTFN DECLARE RETURNS SAT INITVARS PROGDCLS LOCALVARS SPECVARS VARBINDFORMS 
		       VARS)
	     (GLOBALVARS GLOBALVARS))
    (PROG (TYPEBLOCK DECL TEMP TESTFORM NAME INITV TAIL 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 TAIL (CDR VARD))
		   (if DPROGFLAG
		       then (RESETVARS ((NOSPELLFLG T)
					(DWIMESSGAG T))
				       (DWIMIFY0? TAIL VARD TAIL 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 TAIL)))
	    else (SETQ NAME VARD))
          (if (NOT (AND NAME (LITATOM NAME)))
	      then (DECLVARERROR "Illegal variable name"))
          (for V in TAIL
	     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 TYPEBLOCK
	      then (if (SETQ TEMP (GETTBPROP TYPEBLOCK (QUOTE DECLARESPEC)))
		       then (push DECLARE (SUBST NAME (QUOTE VAR)
						 TEMP)))
		   (if (EQ (SETQ TEMP (fetch BINDFN of TYPEBLOCK))
			   (CONSTANT DefaultBindFn))
		     elseif 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: " 9-NOV-83 09:24")

          (* 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: " 9-NOV-83 09:17")
    (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)                                          (* rmk: " 2-Nov-84 15:05")

          (* 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 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: " 9-NOV-83 09:24")
                                                            (* 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 (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: "12-Mar-85 09:15")

          (* 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))
	       (BOUNDP (QUOTE SYSLINKEDFNS))
	       (BOUNDP (QUOTE LINKEDFNS))
	       (FMEMB I SYSLINKEDFNS)
	       (push LINKEDFNS (fetch REALFN of I]
    (FOR P IN MACROPROPS DO (MOVEPROP P (QUOTE SETQ)
				      (QUOTE REALSETQ)))
    (FOR P IN MACROPROPS DO (MOVEPROP P (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: "12-Mar-85 09:07")

          (* 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)

(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))
)
(DECLARE: DOCOPY 
(DECLARE: EVAL@LOADWHEN (NEQ (SYSTEMTYPE)
			     (QUOTE D)) 
[OR (GETPROP (QUOTE LOADTIMECONSTANT)
	     (QUOTE FILEDATES))
    (PROG ((X (FINDFILE (PACKFILENAME (QUOTE NAME)
				      (QUOTE LOADTIMECONSTANT)
				      (QUOTE EXTENSION)
				      COMPILE.EXT)
			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)

(RPAQ? DECLMESSAGES )

(RPAQ? COMPILEIGNOREDECL )

(ADDTOVAR DECLATOMS DLAMBDA DPROG DPROGN)

(ADDTOVAR LAMBDASPLST DLAMBDA)

(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)))

[PROGN [PUTPROPS .CBIND. BYTEMACRO (APPLY (LAMBDA (PV BODY)
						  (APPLY* (QUOTE PROG)
							    PV
							    (QUOTE (RETURN (COMP.EXP1 BODY]
	 (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))))

[PROGN [PUTPROPS DECLMSGMAC DMACRO ((X . Y)
		      (CONSTANT (DECLMSG X . Y]
	 (PUTPROPS DECLMSGMAC MACRO ((X . Y)
		      (LOADTIMECONSTANT (DECLMSG X . Y]

(PUTPROPS REALSETQ  MACRO
   (ARGS (SETQMAC ARGS)))
)
(DECLARE: EVAL@COMPILE 

(QUOTE (REALSET -- no MACRO definition))
)
(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)
)
(PUTPROPS DECL COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1987))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (7156 9779 (DECLTYPE 7166 . 7327) (DECLTYPES 7329 . 7623) (DUMPDECLTYPES 7625 . 8915) (
GETDECLDEF 8917 . 9777)) (10453 12565 (COVERS 10463 . 10642) (GETDECLTYPEPROP 10644 . 10812) (
SETDECLTYPEPROP 10814 . 11221) (SUBTYPES 11223 . 11825) (SUPERTYPES 11827 . 12563)) (15693 47172 (
CHECKTYPEXP 15703 . 16001) (COLLECTTYPES 16003 . 17279) (COVERSCTYPE 17281 . 18099) (COVERSTB 18101 . 
18527) (COVERSTE 18529 . 19231) (CREATEFNPROP 19233 . 19651) (CREATEFNVAL 19653 . 20192) (DECLERROR 
20194 . 20416) (DELETETB 20418 . 21213) (FINDDECLTYPE 21215 . 21759) (FINDPROP 21761 . 21975) (
FINDTYPEXP 21977 . 22710) (GETCTYPE 22712 . 23133) (GETDECLTYPE 23135 . 23635) (GETDECLTYPE.NOERROR 
23637 . 24323) (GETTBPROP 24325 . 24736) (INHERITPROP 24738 . 25969) (INITDECLTYPES 25971 . 28326) (
LCCTYPE 28328 . 28704) (LCC2 28706 . 29196) (MAKECTYPE 29198 . 30534) (MAKEDECLTYPE 30536 . 31362) (
MAKEBINDFN 31364 . 31639) (MAKESETFN 31641 . 31912) (MAPTYPEUSERS 31914 . 32152) (NOTICETB 32154 . 
32597) (PPDTYPE 32599 . 34397) (RECDTYPE 34399 . 36080) (DECLCHANGERECORD 36082 . 36986) (RECDEFTYPE 
36988 . 38110) (REPROPTB 38112 . 39258) (SETTBPROP 39260 . 40180) (TBDEFPRINT 40182 . 40530) (TETYPE 
40532 . 41178) (TYPEMSANAL 41180 . 42562) (TYPEMSANAL1 42564 . 43595) (UNCOMPLETE 43597 . 44412) (
UNSAVETYPE 44414 . 44903) (USERDECLTYPE 44905 . 46103) (USESTYPE 46105 . 47170)) (47331 54743 (
MAKETESTFN 47341 . 47722) (MAKETESTFNBLOCK 47724 . 50478) (COMBINE.TESTS 50480 . 51176) (FUNIFY 51178
 . 51637) (MKNTHCAR 51639 . 52140) (MKNTHCDR 52142 . 52767) (OF.TESTFN 52769 . 53155) (TUPLE.TESTFN 
53157 . 53728) (WHOSE.TESTFN 53730 . 54741)) (56641 57032 (TESTFORM 56651 . 57030)) (57258 58917 (
EVERYCHAR 57268 . 57550) (LARGEP 57552 . 57781) (DECLRECURSING 57783 . 58575) (SMASHCAR 58577 . 58915)
) (59663 102861 (ASSERT 59673 . 60179) (ASSERTFAULT 60181 . 60732) (ASSERTMAC 60734 . 61458) (\*DECL 
61460 . 62641) (*DECLMAC 62643 . 64651) (\CHKINIT 64653 . 65331) (CHKINITMAC 65333 . 66406) (
DECLCONSTANTP 66408 . 67641) (DD 67643 . 68209) (DECLCLISPTRAN 68211 . 72075) (DECLMSG 72077 . 73321) 
(DECLDWIMERROR 73323 . 73740) (DECLDWIMTESTFN 73742 . 74461) (DECLSET 74463 . 75017) (DECLSETQ 75019
 . 75679) (DECLSETQQ 75681 . 75850) (DECLTRAN 75852 . 82187) (DECLVAR 82189 . 88163) (DLAMARGLIST 
88165 . 88501) (DTYPE?TRAN 88503 . 89608) (EDITNEWSATLIST 89610 . 90174) (FORMUSESTB 90176 . 90868) (
IGNOREDECL 90870 . 91599) (MAKETESTFORM 91601 . 92321) (PPDECL 92323 . 95728) (PPVARLIST 95730 . 96882
) (SETQMAC 96884 . 98729) (THETRAN 98731 . 99919) (VALUEERROR 99921 . 100819) (\VARASRT 100821 . 
101194) (VARASRT1 101196 . 102042) (VARSETFN 102044 . 102859)) (103053 110535 (DECLOF 103063 . 103705)
 (DECLOF1 103707 . 108775) (TBOF 108777 . 109184) (TYPEBLOCKOF 109186 . 109490) (VARDECL 109492 . 
110533)) (111206 115898 (STARTDECLS 111216 . 113744) (DODECLS 113746 . 115896)))))
STOP