(FILECREATED "25-Nov-85 17:49:39" {ERIS}<LISPUSERS>MESATOLISP.;7 234092 

      changes to:  (RECORDS MINTERVAL SCOPE)
		   (FNS PARSE.MESA PARSE.CEDAR PARSE.FILE PARSE.GET.STATE PARSE.SET.STATE PARSE.BIN 
			PARSE.VARID PARSE.SMURF PARSE.THISIS.MESA PARSE.THISIS.CEDAR PARSE.MODULE 
			PARSE.INCLUDEITEM PARSE.SEADIRT PARSE.PROGHEAD PARSE.RESIDENT PARSE.SAFE 
			PARSE.DEFHEAD PARSE.TILDE PARSE.DEFINITIONS PARSE.DEFBODY PARSE.LOCKS 
			PARSE.LAMBDA PARSE.MODULEITEM PARSE.DECLARATION PARSE.PUBLIC PARSE.ENTRY 
			PARSE.IDLIST PARSE.IDENTLIST PARSE.POSITION PARSE.OPTBITS PARSE.INTERVAL 
			PARSE.TYPEEXP.HERE PARSE.TYPEEXP PARSE.RANGE PARSE.TYPEAPPL 
			PARSE.TYPEAPPL.CONT PARSE.TYPEID PARSE.TYPEID.CONT PARSE.TYPECONS 
			PARSE.TYPECONS1 PARSE.TYPECONS.CONT PARSE.TYPECONS.RANGE 
			PARSE.TYPECONS.RELATIVE PARSE.TYPECONS.PAINTED PARSE.TYPECONS2 
			PARSE.TYPECONS.INTERVAL PARSE.TYPECONS.DEPENDENT PARSE.TYPECONS.ENUMERATED 
			PARSE.TYPECONS.RECORD PARSE.TYPECONS.ORDERED PARSE.TYPECONS.VAR 
			PARSE.TYPECONS.PACKED PARSE.TYPECONS.DESCRIPTOR PARSE.TYPECONS.SAFE 
			PARSE.TYPECONS.HEAP PARSE.TYPECONS.LONG PARSE.TYPECONS.FRAME 
			PARSE.TYPECONS.REF PARSE.TYPECONS.LIST PARSE.IDENT PARSE.ELEMENT 
			PARSE.MONITORED PARSE.DEPENDENT PARSE.RECLIST PARSE.VARIANTPAIR 
			PARSE.PAIRITEM PARSE.DEFAULTOPT PARSE.VARIANTPART PARSE.VCASEHEAD 
			PARSE.TAGTYPE PARSE.VARIANTITEM PARSE.TYPELIST PARSE.TYPEITEM 
			PARSE.POINTERTYPE PARSE.TRANSFERMODE PARSE.INITIALIZATION PARSE.INITVALUE 
			PARSE.CHECKED PARSE.CODELIST PARSE.STATEMENT PARSE.STATEMENT1 
			PARSE.STATEMENT2 PARSE.STATEMENT.CASEHEAD PARSE.STATEMENT.FORCLAUSE 
			PARSE.STATEMENT.RETURN PARSE.STATEMENT.TRANSFER PARSE.STATEMENT.LBRACKET 
			PARSE.STATEMENT.IF PARSE.BLOCK PARSE.SCOPE PARSE.BINDITEM PARSE.EXITS 
			PARSE.CASESTMTITEM PARSE.CASEEXPITEM PARSE.EXITITEM PARSE.CASETEST 
			PARSE.CONTROLID PARSE.FORCLAUSE PARSE.DIRECTION PARSE.DOTEST PARSE.DOEXIT 
			PARSE.ENABLES PARSE.CATCHLIST PARSE.CATCHCASE PARSE.OPTARGS PARSE.TRANSFER 
			PARSE.KEYITEM PARSE.OPTEXP PARSE.EXP PARSE.EXP1 PARSE.EXP2 
			PARSE.EXP.TRANSFEROP PARSE.EXP.IF PARSE.EXP.CASEHEAD PARSE.EXP.LHS 
			PARSE.EXP.LBRACKET PARSE.EXP.ERROR PARSE.EXP.DISJUNCT PARSE.DISJUNCT 
			PARSE.CONJUNCT PARSE.NEGATION PARSE.RELATION PARSE.SUM PARSE.PRODUCT 
			PARSE.OPTRELATION PARSE.RELATIONTAIL PARSE.RELOP PARSE.ADDOP PARSE.MULTOP 
			PARSE.FACTOR PARSE.PRIMARY PARSE.ATOM PARSE.PRIMARY.NIL 
			PARSE.PRIMARY.LBRACKET PARSE.PRIMARY.PREFIXOP PARSE.PRIMARY.VAL 
			PARSE.PRIMARY.ALL PARSE.PRIMARY.NEW PARSE.PRIMARY.TYPEOP PARSE.PRIMARY.SIZE 
			PARSE.PRIMARY.ISTYPE PARSE.PRIMARY.AT PARSE.PRIMARY.DESCRIPTOR 
			PARSE.PRIMARY.CONS PARSE.PRIMARY.LIST PARSE.PRIMARY.LHS PARSE.PRIMARY.LHS.NEW 
			PARSE.PRIMARY.LHS.CONS PARSE.PRIMARY.LHS.LIST PARSE.QUALIFIER PARSE.LHS 
			PARSE.QUALIFIER.HERE PARSE.OPTCATCH PARSE.TRANSFEROP PARSE.PREFIXOP 
			PARSE.TYPEOP PARSE.DESCLIST PARSE.DIRECTORY PARSE.IMPORTS PARSE.POINTERPREFIX 
			PARSE.EXPORTS PARSE.FIELDLIST PARSE.USING PARSE.CATCHHEAD PARSE.DECLIST 
			PARSE.PAIRLIST PARSE.VARIANTLIST PARSE.ORDERLIST PARSE.LHSLIST 
			PARSE.INCLUDELIST PARSE.MODULELIST PARSE.ELEMENTLIST PARSE.BINDLIST 
			PARSE.STATEMENTLIST PARSE.CASESTMTLIST PARSE.CASELABEL PARSE.EXITLIST 
			PARSE.KEYLIST PARSE.CASEEXPLIST PARSE.EXPLIST PARSE.OPEN PARSE.CLASS 
			PARSE.CASEHEAD PARSE.READONLY PARSE.ORDERED PARSE.BASE PARSE.PACKED 
			PARSE.HEAP PARSE.INLINE PARSE.ARGUMENTS PARSE.INTERFACE PARSE.SHARES 
			PARSE.DEFAULT PARSE.OPTSIZE PARSE.BOUNDS PARSE.LENGTH PARSE.INDEXTYPE 
			PARSE.ELSEPART PARSE.OTHERPART PARSE.FREE PARSE.CATCHANY PARSE.NOT PARSE.NEW 
			PARSE.OPTTYPE PARSE.ARGLIST PARSE.RETURNLIST BUILD.INIT BUILD.PUSH.SCOPE 
			BUILD.POP.SCOPE BUILD.GC.SCOPE BUILD.STORE.EXPORTS BUILD.STORE.IDENTLIST 
			BUILD.STORE.INTERFACES BUILD.STORE.INTERFACE BUILD.STORE.OPEN 
			BUILD.STORE.USING BUILD.INITIALIZATION BUILD.INITIALIZE.VARS 
			BUILD.INITIALIZE.VAR BUILD.INITIALIZE.FN BUILD.INITIALIZE.RECORD BUILD.RECORD 
			BUILD.TYPE BUILD.STORE.ARGLIST BUILD.STORE.RETURNLIST BUILD.STORE.PAIRLIST 
			BUILD.STORE.PAIRITEM BUILD.STORE.VARLIST BUILD.ID BUILD.FIELDID BUILD.PROCID 
			BUILD.RECORDID BUILD.TYPEID BUILD.VARID BUILD.LOCALVARID BUILD.GLOBALVARID 
			BUILD.LOOKUP.TYPE BUILD.LOOKUP BUILD.TYPEATOM BUILD.QUALIFY 
			BUILD.QUALIFY.PREFIXOP BUILD.QUALIFY.TYPEOP BUILD.QUALIFY.EXPLIST 
			BUILD.QUALIFY.ID BUILD.ARITH.EXP1 BUILD.ARITH.EXP2 BUILD.ARITH.EXP* 
			BUILD.ARITH.ADD1SUB1 BUILD.COERCE.ARITHOP BUILD.STRONGEST.TYPE.AMONG 
			BUILD.STRONGEST.TYPE BUILD.COERCE BUILD.COERCE.MLIST BUILD.COERCE.EXPLIST 
			BUILD.ALIGN BUILD.ALIGN.VALUE BUILD.ADD.TO.FILECOMS BUILD.ADD1 BUILD.CALL 
			BUILD.CHARCODE BUILD.COND BUILD.COPY.OF BUILD.FETCH BUILD.FORCLAUSE.IN 
			BUILD.FORCLAUSE.THROUGH BUILD.IN BUILD.ISTYPE BUILD.LAMBDA BUILD.NEW BUILD.OR 
			BUILD.PROG BUILD.PROGN BUILD.REPLACE BUILD.RETURN BUILD.SELECTQ 
			BUILD.SELECTQ.FN BUILD.SELECTQ.CCLAUSE BUILD.SELECTQ.TEST 
			BUILD.SELECTQ.SCLAUSE BUILD.SELECTQ.KEY BUILD.SELECTTRUEFROM 
			BUILD.SELECTTRUEFROM.CLAUSE BUILD.SETQ BUILD.SETQ.ARRAY BUILD.SETQ.ORDERLIST 
			BUILD.SUB1 BUILD.TAIL SCAN.INIT SCAN.STRING SCAN.TEST SCAN.TESTFILE 
			SCAN.OPENSTREAM SCAN.TOKEN SCAN.NUMBER SCAN.ACCEPT SCAN.APPENDDECIMAL 
			SCAN.APPENDOCTAL SCAN.APPENDHEX SCAN.APPENDTOSCALE SCAN.VALIDFRACTION 
			SCAN.DECIMAL SCAN.OCTAL SCAN.OCTALCHAR SCAN.HEX SCAN.FLOATING SCAN.ESCAPE)
		   (VARS MESATOLISPCOMS)

      previous date: " 3-Aug-85 22:42:32" {ERIS}<LISPUSERS>MESATOLISP.;6)


(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT MESATOLISPCOMS)

(RPAQQ MESATOLISPCOMS ((* MESATOLISP -- By Kelly Roach. *)
	(COMS (* SCAN *)
	      (INITVARS (SCAN.BUFFER (NCREATE (QUOTE VMEMPAGEP)))
			(SCAN.BUFFERPTR -1)
			(SCAN.STRING (CREATE STRINGP BASE ← SCAN.BUFFER))
			(SCAN.CHAR NIL)
			(SCAN.QDOT NIL)
			(SCAN.BOTH.RESERVED (QUOTE (! # %( %) * + , - %. .. / : ; < <= = => > >= @ 
						      ABS ALL AND ANY APPLY ARRAY BASE BEGIN 
						      BROADCAST CODE COMPUTED CONTINUE DECREASING 
						      DEFINITIONS DEPENDENT DESCRIPTOR DIRECTORY DO 
						      ELSE ENABLE END ENDCASE ENDLOOP ENTRY ERROR 
						      EXIT EXITS EXPORTS FINISHED FIRST FOR FORK 
						      FRAME FREE FROM GO GOTO IF IMPORTS IN INLINE 
						      INTERNAL ISTYPE JOIN LAST LENGTH LOCKS LONG 
						      LOOP LOOPHOLE MACHINE MAX MIN MOD MONITOR 
						      MONITORED NARROW NEW NILL NOT NOTIFY NULL OF 
						      OPEN OR ORD ORDERED OVERLAID PACKED POINTER 
						      PORT PRED PRIVATE PROC PROCEDURE PROCESS 
						      PROGRAM PUBLIC READONLY RECORD REJECT RELATIVE 
						      REPEAT RESTART RESUME RETRY RETURN RETURNS 
						      SELECT SEQUENCE SHARES SIGNAL SIZE START STATE 
						      STOP SUCC THEN THROUGH TO TRANSFER TRASH TYPE 
						      UNCOUNTED UNTIL USING VAL VAR WAIT WHILE WITH 
						      ZONE %[ %] ↑ ← { %| } ~)))
			(SCAN.CEDAR.RESERVED (QUOTE (CEDAR CHECKED CONS LIST PAINTED REF SAFE TRUSTED 
							   UNCHECKED UNSAFE)))
			(SCAN.MESA.RESERVED (QUOTE (RESIDENT))))
	      (FNS SCAN.INIT SCAN.STRING SCAN.TEST SCAN.TESTFILE SCAN.OPENSTREAM SCAN.TOKEN 
		   SCAN.NUMBER SCAN.ACCEPT SCAN.APPENDDECIMAL SCAN.APPENDOCTAL SCAN.APPENDHEX 
		   SCAN.APPENDTOSCALE SCAN.VALIDFRACTION SCAN.DECIMAL SCAN.OCTAL SCAN.OCTALCHAR 
		   SCAN.HEX SCAN.FLOATING SCAN.ESCAPE)
	      (P (SCAN.INIT)))
	(COMS (* PARSE *)
	      (INITVARS (PARSE.FILELST NIL)
			(PARSE.STREAM NIL)
			(PARSE.FILECOMS NIL)
			(PARSE.LANGUAGE NIL)
			(PARSE.DIRLST NIL)
			(PARSE.CLASS NIL)
			(PARSE.ATOM NIL)
			(PARSE.CLASS2 NIL)
			(PARSE.ATOM2 NIL)
			(PARSE.CASEHEAD.FIRST (QUOTE (WITH SELECT)))
			(PARSE.DEFHEAD.FIRST (QUOTE (DEFINITIONS)))
			(PARSE.DEPENDENT.FIRST (QUOTE (MACHINE)))
			(PARSE.DOTEST.FIRST (QUOTE (UNTIL WHILE)))
			(PARSE.FORCLAUSE.FIRST (QUOTE (FOR THROUGH)))
			(PARSE.HEAP.FIRST (QUOTE (UNCOUNTED)))
			(PARSE.INTERVAL.FIRST (QUOTE (%( %[)))
			(PARSE.OPTRELATION.FIRST (QUOTE (# < <= = > >= IN NOT ~)))
			(PARSE.ORDERED.FIRST (QUOTE (ORDERED)))
			(PARSE.ORDERLIST.FOLLOW (QUOTE (! ; END %] })))
			(PARSE.PACKED.FIRST (QUOTE (PACKED)))
			(PARSE.PREFIXOP.FIRST (QUOTE (ABS BASE LENGTH LONG MAX MIN ORD PRED SUCC)))
			(PARSE.PROGHEAD.FIRST (QUOTE (MONITOR PROGRAM RESIDENT)))
			(PARSE.QUALIFIER.FIRST (QUOTE (%. %[ ↑)))
			(PARSE.RANGE.FOLLOW (QUOTE (! %) , .. : ; => AND DO ELSE END ENDCASE ENDLOOP 
						      EXITS FINISHED FROM NULL OR REPEAT SELECT THEN 
						      TRASH UNTIL WHILE %] })))
			(PARSE.TRANSFER.FIRST (QUOTE (BROADCAST ERROR JOIN NOTIFY RESTART RETURN 
								SIGNAL START TRANSFER)))
			(PARSE.TRANSFERMODE.FIRST (QUOTE (ERROR PORT PROCESS PROGRAM SIGNAL)))
			(PARSE.TRANSFEROP.FIRST (QUOTE (ERROR FORK JOIN NEW SIGNAL START)))
			(PARSE.TYPECONS.FIRST (QUOTE (%( ARRAY BASE DESCRIPTOR ERROR FRAME LONG 
							 MACHINE MONITORED ORDERED PACKED POINTER 
							 PORT PROC PORCEDURE PROCESS PROGRAM RECORD 
							 SIGNAL UNCOUNTED VAR %[ {)))
			(PARSE.TYPEOP.FIRST (QUOTE (FIRST LAST NILL)))
			(PARSE.VARIANTPART.FIRST (QUOTE (PACKED SELECT SEQUENCE)))
			(PARSE.CATCHLIST.FOLLOW (QUOTE (END %] })))
			(PARSE.CONTROLID.FOLLOW (QUOTE (DECREASING IN ←)))
			(PARSE.DECLIST.FOLLOW (QUOTE (; END })))
			(PARSE.DEFAULTOPT.FOLLOW (QUOTE (, ; END %] })))
			(PARSE.EXITLIST.FOLLOW (QUOTE (END ENDLOOP FINISHED })))
			(PARSE.MODULELIST.FOLLOW (QUOTE (IEQP EXPORTS SHARES)))
			(PARSE.OPTARGS.FOLLOW (QUOTE (; ELSE END ENDCASE ENDLOOP EXITS FINISHED 
							REPEAT %] })))
			(PARSE.OPTEXP.FOLLOW (QUOTE (! , ; END FROM %] })))
			(PARSE.SCOPE.FOLLOW (QUOTE (END EXITS })))
			(PARSE.STATEMENTLIST.FOLLOW (QUOTE (END ENDLOOP EXITS REPEAT })))
			(PARSE.TYPEEXP.FOLLOW (QUOTE (! , ; = => DECREASING END EXPORTS FROM IMPORTS 
							IN OF SHARES %] ← })))
			(PARSE.PREDEFINED.TYPES (QUOTE (ATOM BOOL BOOLEAN CARDINAL CHAR CHARACTER 
							     CONDITION INT INTEGER MDSZone 
							     MONITORLOCK NAT REAL STRING StringBody 
							     UNSPECIFIED WORD)))
			(PARSE.RELOPS (LIST (QUOTE =)
					    (QUOTE #)
					    (QUOTE <)
					    (QUOTE <=)
					    (QUOTE >)
					    (QUOTE >=)))
			(PARSE.ADDOPS (LIST (QUOTE +)
					    (QUOTE -)))
			(PARSE.MULTOPS (LIST (QUOTE *)
					     (QUOTE /)
					     (QUOTE MOD)))
			(PARSE.TRANSFEROPS (QUOTE (SIGNAL ERROR START JOIN NEW FORK)))
			(PARSE.PREFIXOPS (QUOTE (LONG ABS PRED SUCC ORD MIN MAX BASE LENGTH)))
			(PARSE.TYPEOPS (QUOTE (FIRST LAST NILL)))
			(PARSE.NOTS (QUOTE (~ NOT))))
	      (RECORDS PARSERSTATE MINTERVAL MRANGE MRELATIVE MPAINTED MENUMERATED MRECORD MVAR 
		       MARRAY MDESCRIPTOR MFRAME MREF MLIST PAIRITEM DEFAULT TYPELIST TYPEITEM 
		       MPOINTER CASEHEAD BINDITEM KEYITEM FIELDLIST PAIRLIST ORDERLIST KEYLIST 
		       EXPLIST)
	      (FNS PARSE.MESA PARSE.CEDAR PARSE.FILE PARSE.GET.STATE PARSE.SET.STATE PARSE.BIN 
		   PARSE.VARID PARSE.SMURF PARSE.THISIS.MESA PARSE.THISIS.CEDAR PARSE.MODULE 
		   PARSE.INCLUDEITEM PARSE.INCLUDECHECK PARSE.SEADIRT PARSE.PROGHEAD PARSE.RESIDENT 
		   PARSE.SAFE PARSE.DEFHEAD PARSE.TILDE PARSE.DEFINITIONS PARSE.DEFBODY PARSE.LOCKS 
		   PARSE.LAMBDA PARSE.MODULEITEM PARSE.DECLARATION PARSE.PUBLIC PARSE.ENTRY 
		   PARSE.IDLIST PARSE.IDENTLIST PARSE.POSITION PARSE.OPTBITS PARSE.INTERVAL 
		   PARSE.TYPEEXP.HERE PARSE.TYPEEXP PARSE.RANGE PARSE.TYPEAPPL PARSE.TYPEAPPL.CONT 
		   PARSE.TYPEID PARSE.TYPEID.CONT PARSE.TYPECONS PARSE.TYPECONS1 PARSE.TYPECONS.CONT 
		   PARSE.TYPECONS.RANGE PARSE.TYPECONS.RELATIVE PARSE.TYPECONS.PAINTED 
		   PARSE.TYPECONS2 PARSE.TYPECONS.INTERVAL PARSE.TYPECONS.DEPENDENT 
		   PARSE.TYPECONS.ENUMERATED PARSE.TYPECONS.RECORD PARSE.TYPECONS.ORDERED 
		   PARSE.TYPECONS.VAR PARSE.TYPECONS.PACKED PARSE.TYPECONS.DESCRIPTOR 
		   PARSE.TYPECONS.SAFE PARSE.TYPECONS.HEAP PARSE.TYPECONS.LONG PARSE.TYPECONS.FRAME 
		   PARSE.TYPECONS.REF PARSE.TYPECONS.LIST PARSE.IDENT PARSE.ELEMENT PARSE.MONITORED 
		   PARSE.DEPENDENT PARSE.RECLIST PARSE.VARIANTPAIR PARSE.PAIRITEM PARSE.DEFAULTOPT 
		   PARSE.VARIANTPART PARSE.VCASEHEAD PARSE.TAGTYPE PARSE.VARIANTITEM PARSE.TYPELIST 
		   PARSE.TYPEITEM PARSE.POINTERTYPE PARSE.TRANSFERMODE PARSE.INITIALIZATION 
		   PARSE.INITVALUE PARSE.CHECKED PARSE.CODELIST PARSE.STATEMENT PARSE.STATEMENT1 
		   PARSE.STATEMENT2 PARSE.STATEMENT.CASEHEAD PARSE.STATEMENT.FORCLAUSE 
		   PARSE.STATEMENT.RETURN PARSE.STATEMENT.TRANSFER PARSE.STATEMENT.LBRACKET 
		   PARSE.STATEMENT.IF PARSE.BLOCK PARSE.SCOPE PARSE.BINDITEM PARSE.EXITS 
		   PARSE.CASESTMTITEM PARSE.CASEEXPITEM PARSE.EXITITEM PARSE.CASETEST PARSE.CONTROLID 
		   PARSE.FORCLAUSE PARSE.DIRECTION PARSE.DOTEST PARSE.DOEXIT PARSE.ENABLES 
		   PARSE.CATCHLIST PARSE.CATCHCASE PARSE.OPTARGS PARSE.TRANSFER PARSE.KEYITEM 
		   PARSE.OPTEXP PARSE.EXP PARSE.EXP1 PARSE.EXP2 PARSE.EXP.TRANSFEROP PARSE.EXP.IF 
		   PARSE.EXP.CASEHEAD PARSE.EXP.LHS PARSE.EXP.LBRACKET PARSE.EXP.ERROR 
		   PARSE.EXP.DISJUNCT PARSE.DISJUNCT PARSE.CONJUNCT PARSE.NEGATION PARSE.RELATION 
		   PARSE.SUM PARSE.PRODUCT PARSE.OPTRELATION PARSE.RELATIONTAIL PARSE.RELOP 
		   PARSE.ADDOP PARSE.MULTOP PARSE.FACTOR PARSE.PRIMARY PARSE.ATOM PARSE.PRIMARY.NIL 
		   PARSE.PRIMARY.LBRACKET PARSE.PRIMARY.PREFIXOP PARSE.PRIMARY.VAL PARSE.PRIMARY.ALL 
		   PARSE.PRIMARY.NEW PARSE.PRIMARY.TYPEOP PARSE.PRIMARY.SIZE PARSE.PRIMARY.ISTYPE 
		   PARSE.PRIMARY.AT PARSE.PRIMARY.DESCRIPTOR PARSE.PRIMARY.CONS PARSE.PRIMARY.LIST 
		   PARSE.PRIMARY.LHS PARSE.PRIMARY.LHS.NEW PARSE.PRIMARY.LHS.CONS 
		   PARSE.PRIMARY.LHS.LIST PARSE.QUALIFIER PARSE.LHS PARSE.QUALIFIER.HERE 
		   PARSE.OPTCATCH PARSE.TRANSFEROP PARSE.PREFIXOP PARSE.TYPEOP PARSE.DESCLIST 
		   PARSE.DIRECTORY PARSE.IMPORTS PARSE.POINTERPREFIX PARSE.EXPORTS PARSE.FIELDLIST 
		   PARSE.USING PARSE.CATCHHEAD PARSE.DECLIST PARSE.PAIRLIST PARSE.VARIANTLIST 
		   PARSE.ORDERLIST PARSE.LHSLIST PARSE.INCLUDELIST PARSE.MODULELIST PARSE.ELEMENTLIST 
		   PARSE.BINDLIST PARSE.STATEMENTLIST PARSE.CASESTMTLIST PARSE.CASELABEL 
		   PARSE.EXITLIST PARSE.KEYLIST PARSE.CASEEXPLIST PARSE.EXPLIST PARSE.OPEN 
		   PARSE.CLASS PARSE.CASEHEAD PARSE.READONLY PARSE.ORDERED PARSE.BASE PARSE.PACKED 
		   PARSE.HEAP PARSE.INLINE PARSE.ARGUMENTS PARSE.INTERFACE PARSE.SHARES PARSE.DEFAULT 
		   PARSE.OPTSIZE PARSE.BOUNDS PARSE.LENGTH PARSE.INDEXTYPE PARSE.ELSEPART 
		   PARSE.OTHERPART PARSE.FREE PARSE.CATCHANY PARSE.NOT PARSE.NEW PARSE.OPTTYPE 
		   PARSE.ARGLIST PARSE.RETURNLIST))
	(COMS (* BUILD *)
	      (INITVARS (BUILD.NEXT.SCOPE NIL)
			(BUILD.CURRENT.SCOPE NIL)
			(BUILD.SCOPE.STACK NIL)
			(BUILD.PREFIX NIL)
			(BUILD.FILECOMS NIL)
			(BUILD.BOOLEAN.FNS (QUOTE (AND OR NOT type? IGREATERP ILESSP IGEQ ILEQ IEQP 
						       ZEROP MINUSP EVENP ODDP FGREATERP FLESSP FEQP 
						       GREATERP LESSP GEQ LEQ)))
			(BUILD.CARDINAL.FNS (QUOTE (ADD1 CHARCODE FIX GCD IDIFFERENCE IMAX IMIN 
							 IMINUS IMOD IPLUS IQUOTIENT IREMAINDER 
							 ITIMES LOGAND LOGNOT LOGOR LOGXOR 
							 NTHCHARCODE SUB1)))
			(BUILD.MIXED.FNS (QUOTE (ABS DIFFERENCE EXPT MAX MIN MINUS MOD PLUS QUOTIENT 
						     REMAINDER TIMES)))
			(BUILD.REAL.FNS (QUOTE (ANTILOG ARCCOS ARCSIN ARCTAN ARCTAN2 COS FDIFFERENCE 
							FLOAT FMAX FMIN FMINUS FMOD FPLUS FQUOTIENT 
							FREMAINDER FTIMES LOG SIN SQRT TAN)))
			(BUILD.QUALIFY.WORDS (QUOTE (FREE NEW SIZE)))
			(BUILD.CARDINAL.ARITHOP.ALIST (LIST (CONS (QUOTE =)
								  (QUOTE IEQP))
							    (CONS (QUOTE #)
								  (QUOTE IEQP))
							    (CONS (QUOTE <)
								  (QUOTE ILESSP))
							    (CONS (QUOTE <=)
								  (QUOTE ILEQ))
							    (CONS (QUOTE >)
								  (QUOTE IGREATERP))
							    (CONS (QUOTE >=)
								  (QUOTE IGEQ))
							    (CONS (QUOTE +)
								  (QUOTE IPLUS))
							    (CONS (QUOTE -)
								  (QUOTE IDIFFERENCE))
							    (CONS (QUOTE *)
								  (QUOTE ITIMES))
							    (CONS (QUOTE /)
								  (QUOTE IQUOTIENT))
							    (CONS (QUOTE 0-)
								  (QUOTE IMINUS))
							    (CONS (QUOTE MAX)
								  (QUOTE IMAX))
							    (CONS (QUOTE MIN)
								  (QUOTE IMIN))
							    (CONS (QUOTE MOD)
								  (QUOTE IMOD))))
			(BUILD.MIXED.ARITHOP.ALIST (LIST (CONS (QUOTE =)
							       (QUOTE EQP))
							 (CONS (QUOTE #)
							       (QUOTE EQP))
							 (CONS (QUOTE <)
							       (QUOTE LESSP))
							 (CONS (QUOTE <=)
							       (QUOTE GREATERP))
							 (CONS (QUOTE >)
							       (QUOTE GREATERP))
							 (CONS (QUOTE >=)
							       (QUOTE LESSP))
							 (CONS (QUOTE +)
							       (QUOTE PLUS))
							 (CONS (QUOTE -)
							       (QUOTE DIFFERENCE))
							 (CONS (QUOTE *)
							       (QUOTE TIMES))
							 (CONS (QUOTE /)
							       (QUOTE QUOTIENT))
							 (CONS (QUOTE 0-)
							       (QUOTE MINUS))
							 (CONS (QUOTE MAX)
							       (QUOTE MAX))
							 (CONS (QUOTE MIN)
							       (QUOTE MIN))
							 (CONS (QUOTE MOD)
							       (QUOTE IMOD))))
			(BUILD.REAL.ARITHOP.ALIST (LIST (CONS (QUOTE =)
							      (QUOTE FEQP))
							(CONS (QUOTE #)
							      (QUOTE FEQP))
							(CONS (QUOTE <)
							      (QUOTE FLESSP))
							(CONS (QUOTE <=)
							      (QUOTE FGREATERP))
							(CONS (QUOTE >)
							      (QUOTE FGREATERP))
							(CONS (QUOTE >=)
							      (QUOTE FLESSP))
							(CONS (QUOTE +)
							      (QUOTE FPLUS))
							(CONS (QUOTE -)
							      (QUOTE FDIFFERENCE))
							(CONS (QUOTE *)
							      (QUOTE FTIMES))
							(CONS (QUOTE /)
							      (QUOTE FQUOTIENT))
							(CONS (QUOTE 0-)
							      (QUOTE FMINUS))
							(CONS (QUOTE MAX)
							      (QUOTE FMAX))
							(CONS (QUOTE MIN)
							      (QUOTE FMIN))
							(CONS (QUOTE MOD)
							      (QUOTE IMOD))))
			(BUILD.CARDINAL.TYPES (QUOTE (CARDINAL CHAR CHARACTER INT INTEGER NAT WORD))))
	      (RECORDS SCOPE)
	      (FNS BUILD.INIT BUILD.PUSH.SCOPE BUILD.POP.SCOPE BUILD.GC.SCOPE BUILD.STORE.EXPORTS 
		   BUILD.STORE.IDENTLIST BUILD.STORE.INTERFACES BUILD.STORE.INTERFACE 
		   BUILD.STORE.OPEN BUILD.STORE.USING BUILD.INITIALIZATION BUILD.INITIALIZE.VARS 
		   BUILD.INITIALIZE.VAR BUILD.INITIALIZE.FN BUILD.INITIALIZE.RECORD BUILD.RECORD 
		   BUILD.TYPE BUILD.STORE.ARGLIST BUILD.STORE.RETURNLIST BUILD.STORE.PAIRLIST 
		   BUILD.STORE.PAIRITEM BUILD.STORE.VARLIST BUILD.ID BUILD.FIELDID BUILD.PROCID 
		   BUILD.RECORDID BUILD.TYPEID BUILD.VARID BUILD.LOCALVARID BUILD.GLOBALVARID 
		   BUILD.ULTIMATE.TYPE BUILD.REFINE.TYPE BUILD.IMMEDIATE.TYPE BUILD.LOOKUP.TYPE 
		   BUILD.LOOKUP BUILD.TYPEATOM BUILD.QUALIFY BUILD.QUALIFY.PREFIXOP 
		   BUILD.QUALIFY.TYPEOP BUILD.QUALIFY.EXPLIST BUILD.QUALIFY.ID BUILD.ARITH.EXP1 
		   BUILD.ARITH.EXP2 BUILD.ARITH.EXP* BUILD.ARITH.ADD1SUB1 BUILD.COERCE.ARITHOP 
		   BUILD.STRONGEST.TYPE.AMONG BUILD.STRONGEST.TYPE BUILD.COERCE BUILD.COERCE.MARRAY 
		   BUILD.COERCE.MLIST BUILD.COERCE.EXPLIST BUILD.ALIGN BUILD.ALIGN.VALUE 
		   BUILD.ADD.TO.FILECOMS BUILD.ADD1 BUILD.CALL BUILD.CHARCODE BUILD.COND 
		   BUILD.COPY.OF BUILD.FETCH BUILD.FORCLAUSE.BY BUILD.FORCLAUSE.IN 
		   BUILD.FORCLAUSE.THROUGH BUILD.IN BUILD.ISTYPE BUILD.LAMBDA BUILD.NEW BUILD.OR 
		   BUILD.PROG BUILD.PROGN BUILD.REPLACE BUILD.RETURN BUILD.SELECTQ BUILD.SELECTQ.FN 
		   BUILD.SELECTQ.CCLAUSE BUILD.SELECTQ.TEST BUILD.SELECTQ.SCLAUSE BUILD.SELECTQ.KEY 
		   BUILD.SELECTTRUEFROM BUILD.SELECTTRUEFROM.CLAUSE BUILD.SETQ BUILD.SETQ.ARRAY 
		   BUILD.SETQ.ORDERLIST BUILD.SUB1 BUILD.TAIL)
	      (P (BUILD.INIT)))))



(* MESATOLISP -- By Kelly Roach. *)




(* SCAN *)


(RPAQ? SCAN.BUFFER (NCREATE (QUOTE VMEMPAGEP)))

(RPAQ? SCAN.BUFFERPTR -1)

(RPAQ? SCAN.STRING (CREATE STRINGP BASE ← SCAN.BUFFER))

(RPAQ? SCAN.CHAR NIL)

(RPAQ? SCAN.QDOT NIL)

(RPAQ? SCAN.BOTH.RESERVED (QUOTE (! # %( %) * + , - %. .. / : ; < <= = => > >= @ ABS ALL AND ANY 
				      APPLY ARRAY BASE BEGIN BROADCAST CODE COMPUTED CONTINUE 
				      DECREASING DEFINITIONS DEPENDENT DESCRIPTOR DIRECTORY DO ELSE 
				      ENABLE END ENDCASE ENDLOOP ENTRY ERROR EXIT EXITS EXPORTS 
				      FINISHED FIRST FOR FORK FRAME FREE FROM GO GOTO IF IMPORTS IN 
				      INLINE INTERNAL ISTYPE JOIN LAST LENGTH LOCKS LONG LOOP 
				      LOOPHOLE MACHINE MAX MIN MOD MONITOR MONITORED NARROW NEW NILL 
				      NOT NOTIFY NULL OF OPEN OR ORD ORDERED OVERLAID PACKED POINTER 
				      PORT PRED PRIVATE PROC PROCEDURE PROCESS PROGRAM PUBLIC 
				      READONLY RECORD REJECT RELATIVE REPEAT RESTART RESUME RETRY 
				      RETURN RETURNS SELECT SEQUENCE SHARES SIGNAL SIZE START STATE 
				      STOP SUCC THEN THROUGH TO TRANSFER TRASH TYPE UNCOUNTED UNTIL 
				      USING VAL VAR WAIT WHILE WITH ZONE %[ %] ↑ ← { %| } ~)))

(RPAQ? SCAN.CEDAR.RESERVED (QUOTE (CEDAR CHECKED CONS LIST PAINTED REF SAFE TRUSTED UNCHECKED 
					   UNSAFE)))

(RPAQ? SCAN.MESA.RESERVED (QUOTE (RESIDENT)))
(DEFINEQ

(SCAN.INIT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:05")
    (PROG NIL
	    (for ATOM in SCAN.BOTH.RESERVED do (PUTPROP ATOM (QUOTE SCAN.RESERVED)
								(QUOTE BOTH)))
	    (for ATOM in SCAN.CEDAR.RESERVED do (PUTPROP ATOM (QUOTE SCAN.RESERVED)
								 (QUOTE CEDAR)))
	    (for ATOM in SCAN.MESA.RESERVED do (PUTPROP ATOM (QUOTE SCAN.RESERVED)
								(QUOTE MESA))))))

(SCAN.STRING
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:05")
                                                             (* Debugging tool to see what was read into 
							     SCAN.BUFFER. *)
    (PROG NIL
	    (FOR I FROM 0 TO 255 WHEN (ZEROP (\GETBASEBYTE SCAN.BUFFER I))
	       DO (replace (STRINGP LENGTH) of SCAN.STRING with I)
		    (RETURN)
	       FINALLY (replace (STRINGP LENGTH) of SCAN.STRING with 256))
	    (RETURN SCAN.STRING))))

(SCAN.TEST
  (LAMBDA (STRING)                                           (* kbr: "25-Nov-85 12:05")
                                                             (* How would scanner parse a file containing this 
							     STRING? *)
    (PROG (STREAM TOKEN)
	    (SETQ STREAM (OPENSTRINGSTREAM STRING))
	    (SETQ SCAN.CHAR (\BIN STREAM))
	    (SETQ SCAN.QDOT NIL)
	    (SETQ TOKEN (SCAN.TOKEN STREAM))
	    (CLOSEF STREAM)
	    (RETURN TOKEN))))

(SCAN.TESTFILE
  (LAMBDA (FILE)                                             (* kbr: "25-Nov-85 12:05")
                                                             (* How would scanner parse a file containing this 
							     STRING? *)
    (PROG (STREAM)
	    (SETQ STREAM (SCAN.OPENSTREAM FILE))
	    (DO (SETQ TOKEN (SCAN.TOKEN STREAM))
		  (PRINT TOKEN T)
		  (COND
		    ((EQ (CAR TOKEN)
			   (QUOTE EOF))
		      (RETURN))))
	    (CLOSEF STREAM))))

(SCAN.OPENSTREAM
  (LAMBDA (FILE)                                             (* kbr: "25-Nov-85 12:05")
                                                             (* Open FILE, return STREAM.
							     *)
    (PROG (STREAM TOKEN)
	    (SETQ STREAM (OPENSTREAM FILE (QUOTE INPUT)))
	    (SETFILEPTR STREAM 0)
	    (SETQ SCAN.CHAR (\BIN STREAM))
	    (SETQ SCAN.QDOT NIL)
	    (RETURN STREAM))))

(SCAN.TOKEN
  (LAMBDA (STREAM)                                           (* kbr: "25-Nov-85 17:38")
                                                             (* Return (CLASS VALUE) *)
    (PROG (SCAN CLASS VALUE VALID C ADVANCE PCHAR COMMENT DASHCRLF STATE NEST)
	    (SETQ STREAM (\DTEST STREAM (QUOTE STREAM)))
	    (SETQ SCAN.BUFFERPTR -1)
	    (do (while (AND (IGEQ SCAN.CHAR (CHARCODE NULL))
				  (ILEQ SCAN.CHAR (CHARCODE SPACE)))
		     do (COND
			    ((EOFP STREAM)
			      (GO ENDFILE)))
			  (SETQ SCAN.CHAR (\BIN STREAM)))
		  (SELCHARQ SCAN.CHAR
			    ((a b c d e f g h i j k l m n o p q r s t u v w x y z)
			      (\PUTBASEBYTE SCAN.BUFFER 0 SCAN.CHAR)
			      (SETQ SCAN.BUFFERPTR 0)
			      (do (SCAN.ACCEPT STREAM)
				    (COND
				      ((NOT (OR (AND (IGEQ SCAN.CHAR (CHARCODE a))
							   (ILEQ SCAN.CHAR (CHARCODE z)))
						    (AND (IGEQ SCAN.CHAR (CHARCODE A))
							   (ILEQ SCAN.CHAR (CHARCODE Z)))
						    (AND (IGEQ SCAN.CHAR (CHARCODE 0))
							   (ILEQ SCAN.CHAR (CHARCODE 9)))))
					(RETURN))))
			      (SETQ CLASS (QUOTE ID))
			      (SETQ VALUE (\MKATOM SCAN.BUFFER 0 SCAN.BUFFERPTR))
			      (SETQ VALID T)
			      (GO GOTNEXT))
			    ((A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)
                                                             (* TBW stuff concerning HTIndex.
							     *)
			      (\PUTBASEBYTE SCAN.BUFFER 0 SCAN.CHAR)
			      (SETQ SCAN.BUFFERPTR 0)
			      (do (SCAN.ACCEPT STREAM)
				    (COND
				      ((NOT (OR (AND (IGEQ SCAN.CHAR (CHARCODE a))
							   (ILEQ SCAN.CHAR (CHARCODE z)))
						    (AND (IGEQ SCAN.CHAR (CHARCODE A))
							   (ILEQ SCAN.CHAR (CHARCODE Z)))
						    (AND (IGEQ SCAN.CHAR (CHARCODE 0))
							   (ILEQ SCAN.CHAR (CHARCODE 9)))))
					(RETURN))))
			      (SETQ CLASS (QUOTE ID))
			      (SETQ VALUE (\MKATOM SCAN.BUFFER 0 SCAN.BUFFERPTR))
			      (SETQ VALID T)
			      (GO GOTNEXT))
			    ((0 1 2 3 4 5 6 7 8 9)
			      (\PUTBASEBYTE SCAN.BUFFER 0 SCAN.CHAR)
			      (SETQ SCAN.BUFFERPTR 0)
			      (SETQ SCAN (SCAN.NUMBER STREAM NIL))
			      (SETQ CLASS (CAR SCAN))
			      (SETQ VALUE (CADR SCAN))
			      (SETQ VALID (CADDR SCAN))
			      (COND
				((NOT VALID)
				  (SCAN.ERROR)))
			      (GO GOTNEXT))
			    (("," ";" ":" "←" "#" "+" "*" "/" "↑" "@" "!" "(" ")" "[" "]" "{" "}")
			      (SETQ CLASS (MKATOM (CHARACTER SCAN.CHAR)))
			      (SETQ VALUE CLASS)
			      (GO GETNEXT))
			    ("'" (SETQ SCAN.CHAR (\BIN STREAM))
				 (SETQ SCAN (SCAN.ESCAPE STREAM))
				 (SETQ VALUE (CAR SCAN))
				 (SETQ VALID (CADR SCAN))
				 (SETQ ADVANCE (CADDR SCAN))
				 (COND
				   ((NOT VALID)
				     (SCAN.ERROR)))
				 (SETQ CLASS (QUOTE CHAR))
				 (COND
				   (ADVANCE (GO GETNEXT))
				   (T (GO GOTNEXT))))
			    (%" (SETQ SCAN.BUFFERPTR 0)
				(SETQ ADVANCE T)
				(do (COND
					(ADVANCE (SETQ SCAN.CHAR (\BIN STREAM))))
				      (SELCHARQ SCAN.CHAR
						(%" (SETQ SCAN.CHAR (\BIN STREAM))
						    (COND
						      ((NOT (IEQP SCAN.CHAR (CHARCODE %")))
							(RETURN))))
						NIL)
				      (SETQ SCAN (SCAN.ESCAPE STREAM))
				      (\PUTBASEBYTE SCAN.BUFFER SCAN.BUFFERPTR (CAR SCAN))
				      (SETQ SCAN.BUFFERPTR (ADD1 SCAN.BUFFERPTR))
				      (SETQ VALID (CADR SCAN))
				      (SETQ ADVANCE (CADDR SCAN))
				      (COND
					((NOT VALID)
					  (SCAN.ERROR))))
				(SETQ VALUE (\SMASHSTRING (ALLOCSTRING SCAN.BUFFERPTR)
							      0 SCAN.STRING SCAN.BUFFERPTR))
				(COND
				  ((OR (IEQP SCAN.CHAR (CHARCODE l))
					 (IEQP SCAN.CHAR (CHARCODE L)))
				    (SETQ CLASS (QUOTE STRING))
				    (GO GETNEXT))
				  (T (SETQ CLASS (QUOTE STRING))
				     (COND
				       ((OR (IEQP SCAN.CHAR (CHARCODE g))
					      (IEQP SCAN.CHAR (CHARCODE G)))
					 (GO GETNEXT))
				       (T (GO GOTNEXT))))))
			    ("-" (SETQ SCAN.CHAR (\BIN STREAM))
				 (COND
				   ((NOT (IEQP SCAN.CHAR (CHARCODE -)))
				     (SETQ CLASS (QUOTE -))
				     (SETQ VALUE (QUOTE -))
				     (GO GOTNEXT)))
				 (SETQ SCAN.CHAR (CHARCODE NULL))
				 (do (SETQ PCHAR SCAN.CHAR)
				       (SETQ SCAN.CHAR (\BIN STREAM))
				       (SELCHARQ SCAN.CHAR
						 ("-" (COND
							((IEQP PCHAR (CHARCODE -))
							  (SETQ COMMENT (QUOTE DASH))
							  (RETURN))))
						 (CR (SETQ COMMENT (QUOTE CRLF))
						     (RETURN))
						 NIL))
				 (SETQ SCAN.CHAR (\BIN STREAM))
				 (COND
				   ((AND (EQ COMMENT (QUOTE DASH))
					   (IEQP SCAN.CHAR (CHARCODE CR)))
				     (SETQ DASHCRLF T)))   (* TBW stuff about formatting *)
				 )
			    ("." (COND
				   (SCAN.QDOT (SETQ SCAN.QDOT NIL)
					      (SETQ CLASS (QUOTE ..))
					      (SETQ VALUE (QUOTE ..))
					      (GO GETNEXT)))
				 (COND
				   ((EOFP STREAM)
				     (SETQ CLASS (QUOTE %.))
				     (SETQ VALUE (QUOTE %.))
				     (GO GOTNEXT)))
				 (SETQ SCAN.CHAR (\BIN STREAM))
				 (SELCHARQ SCAN.CHAR
					   ("." (SETQ CLASS (QUOTE ..))
						(SETQ VALUE (QUOTE ..))
						(GO GETNEXT))
					   ((0 1 2 3 4 5 6 7 8 9)
					     (\PUTBASEBYTE SCAN.BUFFER 0 (CHARCODE "."))
					     (SETQ SCAN.BUFFERPTR 1)
					     (SETQ SCAN (SCAN.NUMBER STREAM T))
					     (SETQ CLASS (CAR SCAN))
					     (SETQ VALUE (CADR SCAN))
					     (SETQ VALID (CADDR SCAN))
					     (COND
					       ((NOT VALID)
						 (SCAN.ERROR)))
					     (GO GOTNEXT))
					   (PROGN (SETQ CLASS (QUOTE %.))
						    (SETQ VALUE (QUOTE %.))
						    (GO GOTNEXT))))
			    ("=" (SETQ SCAN.CHAR (\BIN STREAM))
				 (COND
				   ((IEQP SCAN.CHAR (CHARCODE >))
				     (SETQ CLASS (QUOTE =>))
				     (SETQ VALUE (QUOTE =>))
				     (GO GETNEXT))
				   (T (SETQ CLASS (QUOTE =))
				      (SETQ VALUE (QUOTE =))
				      (GO GOTNEXT))))
			    ("<" (SETQ SCAN.CHAR (\BIN STREAM))
			      (SELCHARQ SCAN.CHAR
					("=" (SETQ CLASS (QUOTE <=))
					     (SETQ VALUE (QUOTE <=))
					     (GO GETNEXT))
					("<" (SETQ STATE (QUOTE PLAIN))
					  (SETQ NEST 1)
					  (do (SETQ SCAN.CHAR (\BIN STREAM))
						(SELCHARQ SCAN.CHAR
							  (">" (SELECTQ STATE
									  ((PLAIN LEFTBROCKET)
									    (SETQ STATE
									      (QUOTE RIGHTBROCKET)))
									  (RIGHTBROCKET
									    (SETQ STATE
									      (QUOTE PLAIN))
									    (SETQ NEST
									      (SUB1 NEST))
									    (COND
									      ((ZEROP NEST)
										(RETURN))))
									  NIL))
							  ("<" (SELECTQ STATE
									  ((PLAIN RIGHTBROCKET)
									    (SETQ STATE
									      (QUOTE LEFTBROCKET)))
									  (RIGHTBROCKET
									    (SETQ STATE
									      (QUOTE PLAIN))
									    (SETQ NEST
									      (ADD1 NEST))
									    (COND
									      ((ZEROP NEST)
										(RETURN))))
									  NIL))
							  (SETQ STATE (QUOTE PLAIN))))
					  (SETQ SCAN.CHAR (\BIN STREAM))
                                                             (* TBW formatting stuff *)
					  )
					(PROGN (SETQ CLASS (QUOTE <))
						 (SETQ VALUE (QUOTE <))
						 (GO GOTNEXT))))
			    (">" (SETQ SCAN.CHAR (\BIN STREAM))
				 (COND
				   ((IEQP SCAN.CHAR (CHARCODE =))
				     (SETQ CLASS (QUOTE >=))
				     (SETQ VALUE (QUOTE >=))
				     (GO GETNEXT))
				   (T (SETQ CLASS (QUOTE >))
				      (SETQ VALUE (QUOTE >))
				      (GO GOTNEXT))))
			    (PROGN (SETQ CLASS (MKATOM (CHARACTER SCAN.CHAR)))
				     (SETQ VALUE CLASS)
				     (GO GETNEXT))))
	GETNEXT
	    (SETQ SCAN.CHAR (\BIN STREAM))
	GOTNEXT
	    (COND
	      ((EQ VALUE (CONSTANT (CHARACTER 172)))   (* Mesa's replacement for ← I guess.
							     *)
		(SETQ VALUE (QUOTE ←))
		(SETQ CLASS (QUOTE ←)))
	      ((EQ VALUE (CONSTANT (CHARACTER 173)))   (* Mesa's replacement for ← I guess.
							     *)
		(SETQ VALUE (QUOTE ↑))
		(SETQ CLASS (QUOTE ↑))))
	    (COND
	      ((EQ CLASS (QUOTE ID))
		(COND
		  ((EQ VALUE NIL)                          (* Hack NIL to NILL because I can't put properties on 
							     NIL. *)
		    (SETQ VALUE (QUOTE NILL))))
		(COND
		  ((GETPROP VALUE (QUOTE SCAN.RESERVED))
		    (SETQ CLASS VALUE)))))
	    (RETURN (LIST CLASS VALUE))
	ENDFILE
	    (SETQ CLASS (QUOTE EOF))
	    (SETQ VALUE (QUOTE EOF))
	    (RETURN (LIST CLASS VALUE)))))

(SCAN.NUMBER
  (LAMBDA (STREAM FLOAT)                                     (* kbr: "25-Nov-85 12:06")
                                                             (* Return (CLASS VALUE VALID) *)
    (PROG (CLASS VALUE VALID HEXCOUNT HEXSIG V START SCAN)
	    (SETQ HEXCOUNT 0)
	    (SETQ HEXSIG 0)
	    (SETQ CLASS (QUOTE LNUM))
	    (DO (SELCHARQ SCAN.CHAR
			    (("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
			      (SCAN.ACCEPT STREAM))
			    ((e E)
			      (SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE (CHARCODE
											e)
										      (CHARCODE
											a)))))
			      (SETQ HEXCOUNT (ADD1 HEXCOUNT))
			      (SCAN.ACCEPT STREAM)
			      (COND
				((AND (IEQP HEXCOUNT 1)
					(OR (IEQP SCAN.CHAR (CHARCODE +))
					      (IEQP SCAN.CHAR (CHARCODE -))))
				  (SETQ FLOAT T)
				  (SCAN.ACCEPT STREAM))))
			    ((a b c d e f)
			      (SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE SCAN.CHAR
										      (CHARCODE
											a)))))
			      (SETQ HEXCOUNT (ADD1 HEXCOUNT))
			      (SCAN.ACCEPT STREAM))
			    ((A B C D E F)
			      (SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE SCAN.CHAR
										      (CHARCODE
											A)))))
			      (SETQ HEXCOUNT (ADD1 HEXCOUNT))
			      (SCAN.ACCEPT STREAM))
			    ((h H)
			      (SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE (CHARCODE
											h)
										      (CHARCODE
											a)))))
			      (SETQ HEXCOUNT (ADD1 HEXCOUNT))
			      (SCAN.ACCEPT STREAM))
			    ("." (COND
				   ((OR (NOT (IEQP HEXCOUNT 0))
					  FLOAT)
				     (RETURN)))
				 (SETQ SCAN.CHAR (\BIN STREAM))
				 (COND
				   ((IEQP SCAN.CHAR (CHARCODE "."))
				     (SETQ SCAN.QDOT T)
				     (RETURN)))
				 (SETQ FLOAT T)
				 (\PUTBASEBYTE SCAN.BUFFER SCAN.BUFFERPTR (CHARCODE "."))
				 (SETQ SCAN.BUFFERPTR (ADD1 SCAN.BUFFERPTR)))
			    (RETURN)))
	    (\PUTBASEBYTE SCAN.BUFFER SCAN.BUFFERPTR 0)
	    (COND
	      (FLOAT (SETQ CLASS (QUOTE FLNUM))
		       (SETQ SCAN (SCAN.FLOATING SCAN.BUFFER))
		       (SETQ V (CAR SCAN))
		       (SETQ VALID (CADR SCAN)))
	      ((NOT (ZEROP (LOGAND HEXSIG (LLSH 1 (IDIFFERENCE (CHARCODE h)
									 (CHARCODE a))))))
		(SETQ SCAN (SCAN.HEX SCAN.BUFFER))
		(SETQ V (CAR SCAN))
		(SETQ VALID (CADR SCAN)))
	      ((IEQP HEXCOUNT 0)
		(SETQ SCAN (SCAN.DECIMAL SCAN.BUFFER))
		(SETQ V (CAR SCAN))
		(SETQ VALID (CADR SCAN)))
	      ((IEQP HEXCOUNT 1)
		(SELECTC HEXSIG
			   ((LLSH 1 (IDIFFERENCE (CHARCODE b)
						     (CHARCODE a)))
			     (SETQ SCAN (SCAN.OCTAL SCAN.BUFFER)))
			   ((LLSH 1 (IDIFFERENCE (CHARCODE c)
						     (CHARCODE a)))
			     (SETQ CLASS (QUOTE CHAR))
			     (SETQ SCAN (SCAN.OCTALCHAR SCAN.BUFFER)))
			   ((LLSH 1 (IDIFFERENCE (CHARCODE d)
						     (CHARCODE a)))
			     (SETQ SCAN (SCAN.DECIMAL SCAN.BUFFER)))
			   ((LLSH 1 (IDIFFERENCE (CHARCODE e)
						     (CHARCODE a)))
			     (SETQ CLASS (QUOTE FLNUM))
			     (SETQ SCAN (SCAN.FLOATING SCAN.BUFFER)))
			   (SETQ SCAN (SCAN.HEX SCAN.BUFFER)))
		(SETQ V (CAR SCAN))
		(SETQ VALID (CADR SCAN)))
	      (T (SETQ SCAN (SCAN.HEX SCAN.BUFFER))
		 (SETQ V (CAR SCAN))
		 (SETQ VALID (CADR SCAN))))              (* TBW stuff *)
	    (RETURN (LIST CLASS V VALID)))))

(SCAN.ACCEPT
  (LAMBDA (STREAM)                                           (* kbr: "25-Nov-85 12:06")
    (PROG NIL
	    (COND
	      ((IGEQ SCAN.BUFFERPTR 255)                   (* TBW We're not ready to handle overflowing buffer.
							     Error if half full. *)
		(SCAN.ERROR)))
	    (\PUTBASEBYTE SCAN.BUFFER SCAN.BUFFERPTR SCAN.CHAR)
	    (SETQ SCAN.BUFFERPTR (ADD1 SCAN.BUFFERPTR))
	    (SETQ SCAN.CHAR (\BIN STREAM)))))

(SCAN.APPENDDECIMAL
  (LAMBDA (V DIGIT)                                          (* kbr: "25-Nov-85 12:06")
                                                             (* DIGIT is a character code.
							     Return (NEWV VALID) *)
    (PROG (MAXV MAXD D VALID NEWV)
	    (SETQ MAXV 429496729)
	    (SETQ MAXD 5)
	    (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0)))
	    (SETQ VALID (OR (ILESSP V MAXV)
				(AND (IEQP V MAXV)
				       (ILEQ D MAXD))))
	    (SETQ NEWV (IPLUS (ITIMES 10 V)
				  D))
	    (RETURN (LIST NEWV VALID)))))

(SCAN.APPENDOCTAL
  (LAMBDA (V DIGIT)                                          (* kbr: "25-Nov-85 12:06")
                                                             (* DIGIT is a character code.
							     Return (NEWV VALID) *)
    (PROG (MAXV D VALID NEWV)
	    (SETQ MAXV 536870911)
	    (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0)))
	    (SETQ VALID (ILEQ V MAXV))
	    (SETQ NEWV (IPLUS (ITIMES 8 V)
				  D))
	    (RETURN (LIST NEWV VALID)))))

(SCAN.APPENDHEX
  (LAMBDA (V DIGIT)                                          (* kbr: "25-Nov-85 12:06")
                                                             (* DIGIT is a character code.
							     Return (NEWV VALID) *)
    (PROG (MAXV D VALID NEWV)
	    (SETQ MAXV 268435455)
	    (COND
	      ((AND (IGEQ DIGIT (CHARCODE 0))
		      (ILEQ DIGIT (CHARCODE 9)))
		(SETQ D (IDIFFERENCE DIGIT (CHARCODE 0))))
	      (T (SETQ D (IPLUS DIGIT (IMINUS (CHARCODE A))
				    10))))
	    (SETQ VALID (ILEQ V MAXV))
	    (SETQ NEWV (IPLUS (ITIMES 16 V)
				  D))
	    (RETURN (LIST NEWV VALID)))))

(SCAN.APPENDTOSCALE
  (LAMBDA (V DIGIT)                                          (* kbr: "25-Nov-85 12:06")
                                                             (* DIGIT is a character code.
							     Return (NEWV VALID) *)
    (PROG (MAXV MAXD D VALID NEWV)
	    (SETQ MAXV 6553)
	    (SETQ MAXD 5)
	    (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0)))
	    (SETQ VALID (OR (ILESSP V MAXV)
				(AND (IEQP V MAXV)
				       (ILEQ D MAXD))))
	    (SETQ NEWV (IPLUS (ITIMES 10 V)
				  D))
	    (RETURN (LIST NEWV VALID)))))

(SCAN.VALIDFRACTION
  (LAMBDA (V DIGIT)                                          (* kbr: "25-Nov-85 12:06")
                                                             (* DIGIT is a character code.
							     Return VALID. *)
    (PROG (MAXV MAXD D VALID)
	    (SETQ MAXV 214748364)
	    (SETQ MAXD 7)
	    (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0)))
	    (SETQ VALID (OR (ILESSP V MAXV)
				(AND (IEQP V MAXV)
				       (ILEQ D MAXD))))
	    (RETURN VALID))))

(SCAN.DECIMAL
  (LAMBDA (BUFFER)                                           (* kbr: "25-Nov-85 12:06")
                                                             (* Return (VALUE VALID) *)
    (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE)
	    (SETQ VALID T)
	    (SETQ BUFFERPTR 0)
	    (SETQ V 0)
	    (WHILE (AND (IGEQ (SETQ C (\GETBASEBYTE BUFFER BUFFERPTR))
				    (CHARCODE 0))
			    (ILEQ C (CHARCODE 9)))
	       DO (COND
		      (VALID (SETQ SCAN (SCAN.APPENDDECIMAL V C))
			     (SETQ V (CAR SCAN))
			     (SETQ VALID (CADR SCAN))))
		    (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
	    (COND
	      ((OR (IEQP C (CHARCODE d))
		     (IEQP C (CHARCODE D)))
		(SETQ SCALE 0)
		(SETQ BUFFERPTR (ADD1 BUFFERPTR))
		(WHILE (AND (IGEQ (SETQ C (\GETBASEBYTE BUFFER BUFFERPTR))
					(CHARCODE 0))
				(ILEQ C (CHARCODE 9)))
		   DO (COND
			  (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C))
				 (SETQ SCALE (CAR SCAN))
				 (SETQ VALID (CADR SCAN))))
			(SETQ BUFFERPTR (ADD1 BUFFERPTR)))
		(FOR I FROM 1 TO SCALE
		   DO (SETQ SCAN (SCAN.APPENDDECIMAL V (CHARCODE 0)))
			(SETQ V (CAR SCAN))
			(SETQ VALID (CADR SCAN)))))
	    (COND
	      ((NOT (ZEROP (\GETBASEBYTE BUFFER BUFFERPTR)))
		(SETQ VALID NIL)))
	    (SETQ VALUE V)
	    (RETURN (LIST VALUE VALID)))))

(SCAN.OCTAL
  (LAMBDA (BUFFER)                                           (* kbr: "25-Nov-85 12:06")
                                                             (* Return (VALUE VALID) *)
    (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE)
	    (SETQ BUFFERPTR 0)
	    (SETQ VALID T)
	    (SETQ V 0)
	    (WHILE (AND (IGEQ (SETQ C (\GETBASEBYTE BUFFER BUFFERPTR))
				    (CHARCODE 0))
			    (ILEQ C (CHARCODE 7)))
	       DO (COND
		      (VALID (SETQ SCAN (SCAN.APPENDOCTAL V C))
			     (SETQ V (CAR SCAN))
			     (SETQ VALID (CADR SCAN))))
		    (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
	    (COND
	      ((OR (IEQP C (CHARCODE b))
		     (IEQP C (CHARCODE B)))
		(SETQ SCALE 0)
		(SETQ BUFFERPTR (ADD1 BUFFERPTR))
		(WHILE (AND (IGEQ (SETQ C (\GETBASEBYTE BUFFER BUFFERPTR))
					(CHARCODE 0))
				(ILEQ C (CHARCODE 7)))
		   DO (COND
			  (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C))
				 (SETQ SCALE (CAR SCAN))
				 (SETQ VALID (CADR SCAN))))
			(SETQ BUFFERPTR (ADD1 BUFFERPTR)))
		(FOR I FROM 1 TO SCALE
		   DO (SETQ SCAN (SCAN.APPENDOCTAL V (CHARCODE 0)))
			(SETQ V (CAR SCAN))
			(SETQ VALID (CADR SCAN)))))
	    (COND
	      ((NOT (ZEROP (\GETBASEBYTE BUFFER BUFFERPTR)))
		(SETQ VALID NIL)))
	    (SETQ VALUE V)
	    (RETURN (LIST VALUE VALID)))))

(SCAN.OCTALCHAR
  (LAMBDA (BUFFER)                                           (* kbr: "25-Nov-85 12:06")
                                                             (* Return (VALUE VALID) *)
    (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE)
	    (SETQ BUFFERPTR 0)
	    (SETQ VALID T)
	    (SETQ V 0)
	    (WHILE (AND (IGEQ (SETQ C (\GETBASEBYTE BUFFER BUFFERPTR))
				    (CHARCODE 0))
			    (ILEQ C (CHARCODE 7)))
	       DO (COND
		      (VALID (SETQ SCAN (SCAN.APPENDOCTAL V C))
			     (SETQ V (CAR SCAN))
			     (SETQ VALID (CADR SCAN))))
		    (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
	    (COND
	      ((OR (IEQP C (CHARCODE c))
		     (IEQP C (CHARCODE C)))
		(SETQ BUFFERPTR (ADD1 BUFFERPTR))))
	    (COND
	      ((NOT (ZEROP (\GETBASEBYTE BUFFER BUFFERPTR)))
		(SETQ VALID NIL)))
	    (COND
	      ((NOT (OR (IGEQ V 0)
			    (ILEQ V 255)))
		(SETQ VALID NIL)))
	    (SETQ VALUE V)
	    (RETURN (LIST VALUE VALID)))))

(SCAN.HEX
  (LAMBDA (BUFFER)                                           (* kbr: "25-Nov-85 12:06")
                                                             (* Return (VALUE VALID) *)
    (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE)
	    (SETQ BUFFERPTR 0)
	    (SETQ VALID T)
	    (SETQ V 0)
	    (WHILE (NOT (ZEROP (\GETBASEBYTE BUFFER BUFFERPTR)))
	       DO (SETQ C (\GETBASEBYTE BUFFER BUFFERPTR))
		    (COND
		      ((OR (AND (IGEQ C (CHARCODE 0))
				    (ILEQ C (CHARCODE 9)))
			     (AND (IGEQ C (CHARCODE A))
				    (ILEQ C (CHARCODE F))))
			(COND
			  (VALID (SETQ SCAN (SCAN.APPENDHEX V C))
				 (SETQ V (CAR SCAN))
				 (SETQ VALID (CADR SCAN)))))
		      ((AND (IGEQ C (CHARCODE a))
			      (ILEQ C (CHARCODE f)))
			(COND
			  (VALID (SETQ SCAN (SCAN.APPENDHEX V (IDIFFERENCE C
										 (IDIFFERENCE
										   (CHARCODE a)
										   (CHARCODE A)))))
				 (SETQ V (CAR SCAN))
				 (SETQ VALID (CADR SCAN)))))
		      (T (RETURN)))
		    (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
	    (COND
	      ((OR (IEQP C (CHARCODE h))
		     (IEQP C (CHARCODE H)))
		(SETQ SCALE 0)
		(SETQ BUFFERPTR (ADD1 BUFFERPTR))
		(WHILE (AND (IGEQ (SETQ C (\GETBASEBYTE BUFFER BUFFERPTR))
					(CHARCODE 0))
				(ILEQ C (CHARCODE 9)))
		   DO (COND
			  (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C))
				 (SETQ SCALE (CAR SCAN))
				 (SETQ VALID (CADR SCAN))))
			(SETQ BUFFERPTR (ADD1 BUFFERPTR)))
		(FOR I FROM 1 TO SCALE
		   DO (SETQ SCAN (SCAN.APPENDHEX V (CHARCODE 0)))
			(SETQ V (CAR SCAN))
			(SETQ VALID (CADR SCAN)))))
	    (COND
	      ((NOT (ZEROP (\GETBASEBYTE BUFFER BUFFERPTR)))
		(SETQ VALID NIL)))
	    (SETQ VALUE V)
	    (RETURN (LIST VALUE VALID)))))

(SCAN.FLOATING
  (LAMBDA (BUFFER)                                           (* kbr: "25-Nov-85 12:06")
                                                             (* Return (VALUE VALID) *)
    (PROG (VALUE VALID BUFFERPTR C V EXP SCAN SCALE OP)
	    (SETQ BUFFERPTR 0)
	    (SETQ VALID T)
	    (SETQ V 0)
	    (SETQ EXP 0)
	    (WHILE (AND (IGEQ (SETQ C (\GETBASEBYTE BUFFER BUFFERPTR))
				    (CHARCODE 0))
			    (ILEQ C (CHARCODE 9)))
	       DO (SETQ VALID (AND VALID (SCAN.VALIDFRACTION V C)))
		    (COND
		      (VALID (SETQ SCAN (SCAN.APPENDDECIMAL V C))
			     (SETQ V (CAR SCAN)))
		      (T (SETQ EXP (ADD1 EXP))))
		    (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
	    (COND
	      ((IEQP C (CHARCODE %.))
		(SETQ BUFFERPTR (ADD1 BUFFERPTR))
		(SETQ C (\GETBASEBYTE BUFFER BUFFERPTR))
		(COND
		  ((NOT (AND (IGEQ C (CHARCODE 0))
				 (ILEQ C (CHARCODE 9))))
		    (SETQ VALID NIL)))
		(WHILE (AND (IGEQ (SETQ C (\GETBASEBYTE BUFFER BUFFERPTR))
					(CHARCODE 0))
				(ILEQ C (CHARCODE 9)))
		   DO (SETQ VALID (AND VALID (SCAN.VALIDFRACTION V C)))
			(COND
			  (VALID (SETQ SCAN (SCAN.APPENDDECIMAL V C))
				 (SETQ V (CAR SCAN))
				 (SETQ VALID (CADR SCAN))
				 (SETQ EXP (SUB1 EXP))))
			(SETQ BUFFERPTR (ADD1 BUFFERPTR)))))
	    (SETQ VALID T)
	    (COND
	      ((OR (IEQP C (CHARCODE e))
		     (IEQP C (CHARCODE E)))
		(SETQ SCALE 0)
		(SETQ OP (QUOTE PLUS))
		(SETQ BUFFERPTR (ADD1 BUFFERPTR))
		(SELCHARQ (\GETBASEBYTE BUFFER BUFFERPTR)
			  ("+" (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
			  ("-" (SETQ OP (QUOTE MINUS))
			       (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
			  NIL)
		(COND
		  ((NOT (AND (IGEQ (\GETBASEBYTE BUFFER BUFFERPTR)
					 (CHARCODE 0))
				 (ILEQ (\GETBASEBYTE BUFFER BUFFERPTR)
					 (CHARCODE 9))))
		    (SETQ VALID NIL)))
		(WHILE (AND (IGEQ (SETQ C (\GETBASEBYTE BUFFER BUFFERPTR))
					(CHARCODE 0))
				(ILEQ C (CHARCODE 9)))
		   DO (COND
			  (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C))
				 (SETQ SCALE (CAR SCAN))
				 (SETQ VALID (CADR SCAN))))
			(SETQ BUFFERPTR (ADD1 BUFFERPTR)))
		(SETQ EXP (COND
		    ((EQ OP (QUOTE PLUS))
		      (IPLUS EXP SCALE))
		    (T (IDIFFERENCE EXP SCALE))))))
	    (COND
	      ((NOT (ZEROP (\GETBASEBYTE BUFFER BUFFERPTR)))
		(SETQ VALID NIL)))                         (* TBW NOTE: Look at MKNUMATOM & \FLOATINGSCALE to 
							     find right way to do this. *)
	    (SETQ VALUE (FTIMES V (EXPT 10.0 EXP)))
	    (RETURN (LIST VALUE VALID)))))

(SCAN.ESCAPE
  (LAMBDA (STREAM)                                           (* kbr: "25-Nov-85 12:06")
    (PROG (C VALID ADVANCE V NC)
	    (SETQ VALID T)
	    (SETQ ADVANCE T)
	    (SETQ C SCAN.CHAR)
	    (COND
	      ((IEQP C (CHARCODE \))
		(SETQ SCAN.CHAR (\BIN STREAM))
		(SETQ C (SELCHARQ SCAN.CHAR
				    ((n N r R)
				      (CHARCODE CR))
				    ((l L)
				      (CHARCODE LF))
				    ((t T)
				      (CHARCODE TAB))
				    ((b B)
				      (CHARCODE BS))
				    ((f F)
				      (CHARCODE FF))
				    (("'" %" \)
				      SCAN.CHAR)
				    ((0 1 2 3 4 5 6 7)
				      (SETQ V 0)
				      (SETQ NC 0)
				      (DO (COND
					      ((NOT (AND (IGEQ SCAN.CHAR (CHARCODE 0))
							     (ILEQ SCAN.CHAR (CHARCODE 7))))
						(SETQ VALID NIL)
						(SETQ ADVANCE NIL)
						(RETURN)))
					    (SETQ V (IPLUS (ITIMES 8 V)
							       (IDIFFERENCE SCAN.CHAR (CHARCODE
										0))))
					    (COND
					      ((IEQP (SETQ NC (ADD1 NC))
						       3)
						(RETURN)))
					    (SETQ SCAN.CHAR (\BIN STREAM)))
				      (COND
					((IGREATERP V 255)
					  (SETQ VALID NIL)
					  (SETQ V 0)))
				      (SETQ C V))
				    (PROGN (SETQ VALID NIL)
					     (SETQ ADVANCE NIL))))))
	    (RETURN (LIST C VALID ADVANCE)))))
)
(SCAN.INIT)



(* PARSE *)


(RPAQ? PARSE.FILELST NIL)

(RPAQ? PARSE.STREAM NIL)

(RPAQ? PARSE.FILECOMS NIL)

(RPAQ? PARSE.LANGUAGE NIL)

(RPAQ? PARSE.DIRLST NIL)

(RPAQ? PARSE.CLASS NIL)

(RPAQ? PARSE.ATOM NIL)

(RPAQ? PARSE.CLASS2 NIL)

(RPAQ? PARSE.ATOM2 NIL)

(RPAQ? PARSE.CASEHEAD.FIRST (QUOTE (WITH SELECT)))

(RPAQ? PARSE.DEFHEAD.FIRST (QUOTE (DEFINITIONS)))

(RPAQ? PARSE.DEPENDENT.FIRST (QUOTE (MACHINE)))

(RPAQ? PARSE.DOTEST.FIRST (QUOTE (UNTIL WHILE)))

(RPAQ? PARSE.FORCLAUSE.FIRST (QUOTE (FOR THROUGH)))

(RPAQ? PARSE.HEAP.FIRST (QUOTE (UNCOUNTED)))

(RPAQ? PARSE.INTERVAL.FIRST (QUOTE (%( %[)))

(RPAQ? PARSE.OPTRELATION.FIRST (QUOTE (# < <= = > >= IN NOT ~)))

(RPAQ? PARSE.ORDERED.FIRST (QUOTE (ORDERED)))

(RPAQ? PARSE.ORDERLIST.FOLLOW (QUOTE (! ; END %] })))

(RPAQ? PARSE.PACKED.FIRST (QUOTE (PACKED)))

(RPAQ? PARSE.PREFIXOP.FIRST (QUOTE (ABS BASE LENGTH LONG MAX MIN ORD PRED SUCC)))

(RPAQ? PARSE.PROGHEAD.FIRST (QUOTE (MONITOR PROGRAM RESIDENT)))

(RPAQ? PARSE.QUALIFIER.FIRST (QUOTE (%. %[ ↑)))

(RPAQ? PARSE.RANGE.FOLLOW (QUOTE (! %) , .. : ; => AND DO ELSE END ENDCASE ENDLOOP EXITS FINISHED 
				      FROM NULL OR REPEAT SELECT THEN TRASH UNTIL WHILE %] })))

(RPAQ? PARSE.TRANSFER.FIRST (QUOTE (BROADCAST ERROR JOIN NOTIFY RESTART RETURN SIGNAL START 
						TRANSFER)))

(RPAQ? PARSE.TRANSFERMODE.FIRST (QUOTE (ERROR PORT PROCESS PROGRAM SIGNAL)))

(RPAQ? PARSE.TRANSFEROP.FIRST (QUOTE (ERROR FORK JOIN NEW SIGNAL START)))

(RPAQ? PARSE.TYPECONS.FIRST (QUOTE (%( ARRAY BASE DESCRIPTOR ERROR FRAME LONG MACHINE MONITORED 
					 ORDERED PACKED POINTER PORT PROC PORCEDURE PROCESS PROGRAM 
					 RECORD SIGNAL UNCOUNTED VAR %[ {)))

(RPAQ? PARSE.TYPEOP.FIRST (QUOTE (FIRST LAST NILL)))

(RPAQ? PARSE.VARIANTPART.FIRST (QUOTE (PACKED SELECT SEQUENCE)))

(RPAQ? PARSE.CATCHLIST.FOLLOW (QUOTE (END %] })))

(RPAQ? PARSE.CONTROLID.FOLLOW (QUOTE (DECREASING IN ←)))

(RPAQ? PARSE.DECLIST.FOLLOW (QUOTE (; END })))

(RPAQ? PARSE.DEFAULTOPT.FOLLOW (QUOTE (, ; END %] })))

(RPAQ? PARSE.EXITLIST.FOLLOW (QUOTE (END ENDLOOP FINISHED })))

(RPAQ? PARSE.MODULELIST.FOLLOW (QUOTE (IEQP EXPORTS SHARES)))

(RPAQ? PARSE.OPTARGS.FOLLOW (QUOTE (; ELSE END ENDCASE ENDLOOP EXITS FINISHED REPEAT %] })))

(RPAQ? PARSE.OPTEXP.FOLLOW (QUOTE (! , ; END FROM %] })))

(RPAQ? PARSE.SCOPE.FOLLOW (QUOTE (END EXITS })))

(RPAQ? PARSE.STATEMENTLIST.FOLLOW (QUOTE (END ENDLOOP EXITS REPEAT })))

(RPAQ? PARSE.TYPEEXP.FOLLOW (QUOTE (! , ; = => DECREASING END EXPORTS FROM IMPORTS IN OF SHARES %] 
					← })))

(RPAQ? PARSE.PREDEFINED.TYPES (QUOTE (ATOM BOOL BOOLEAN CARDINAL CHAR CHARACTER CONDITION INT 
					     INTEGER MDSZone MONITORLOCK NAT REAL STRING StringBody 
					     UNSPECIFIED WORD)))

(RPAQ? PARSE.RELOPS (LIST (QUOTE =)
			    (QUOTE #)
			    (QUOTE <)
			    (QUOTE <=)
			    (QUOTE >)
			    (QUOTE >=)))

(RPAQ? PARSE.ADDOPS (LIST (QUOTE +)
			    (QUOTE -)))

(RPAQ? PARSE.MULTOPS (LIST (QUOTE *)
			     (QUOTE /)
			     (QUOTE MOD)))

(RPAQ? PARSE.TRANSFEROPS (QUOTE (SIGNAL ERROR START JOIN NEW FORK)))

(RPAQ? PARSE.PREFIXOPS (QUOTE (LONG ABS PRED SUCC ORD MIN MAX BASE LENGTH)))

(RPAQ? PARSE.TYPEOPS (QUOTE (FIRST LAST NILL)))

(RPAQ? PARSE.NOTS (QUOTE (~ NOT)))
[DECLARE: EVAL@COMPILE 

(TYPERECORD PARSERSTATE (STREAM FILEPTR CHAR QDOT CLASS ATOM CLASS2 ATOM2 PREFIX NEXTSCOPE 
				  CURRENTSCOPE SCOPESTACK FILECOMS))

(TYPERECORD MINTERVAL (KIND . BOUNDS)
			(ACCESSFNS ((LBOUND (CAR (fetch (MINTERVAL BOUNDS) of DATUM)))
				      (UBOUND (CADR (fetch (MINTERVAL BOUNDS) of DATUM))))))

(TYPERECORD MRANGE (TYPE INTERVAL))

(TYPERECORD MRELATIVE (TYPEID TYPE))

(TYPERECORD MPAINTED (TYPEID TYPE))

(TYPERECORD MENUMERATED ITEMS)

(TYPERECORD MRECORD (RECORDID . FIELDLIST))

(TYPERECORD MVAR TYPE)

(TYPERECORD MARRAY (INDEXTYPE TYPE))

(TYPERECORD MDESCRIPTOR TYPE)

(TYPERECORD MFRAME ID)

(TYPERECORD MREF TYPE)

(TYPERECORD MLIST TYPE)

(RECORD PAIRITEM (ID TYPEEXP DEFAULT))

(RECORD DEFAULT (EXP TRASH))

(TYPERECORD TYPELIST ITEMS)

(RECORD TYPEITEM (TYPEEXP DEFAULT))

(TYPERECORD MPOINTER TYPE)

(TYPERECORD CASEHEAD (ID EXP OPTEXP))

(TYPERECORD BINDITEM (ID EXP))

(RECORD KEYITEM (ID OPTEXP))

(RECORD FIELDLIST (TYPE . ITEMS)
		    (TYPE? (AND (LISTP DATUM)
				    (FMEMB (CAR DATUM)
					     (QUOTE (PAIRLIST TYPELIST))))))

(TYPERECORD PAIRLIST ITEMS)

(TYPERECORD ORDERLIST ITEMS)

(TYPERECORD KEYLIST ITEMS)

(RECORD EXPLIST (TYPE . ITEMS)
		  (TYPE? (AND (LISTP DATUM)
				  (FMEMB (CAR DATUM)
					   (QUOTE (KEYLIST ORDERLIST))))))
]
(DEFINEQ

(PARSE.MESA
  (LAMBDA (FILE DIRLST)                                      (* kbr: "25-Nov-85 12:46")
    (PARSE.FILE FILE (QUOTE MESA)
		  DIRLST)))

(PARSE.CEDAR
  (LAMBDA (FILE DIRLST)                                      (* kbr: "25-Nov-85 12:46")
    (PARSE.FILE FILE (QUOTE CEDAR)
		  DIRLST)))

(PARSE.FILE
  (LAMBDA (FILE LANGUAGE DIRLST)                             (* kbr: "25-Nov-85 12:46")
    (PROG NIL
	    (SETQ PARSE.DIRLST DIRLST)
	    (SETQ PARSE.LANGUAGE LANGUAGE)
	    (SETQ PARSE.STREAM (SCAN.OPENSTREAM FILE))
	    (SETQ PARSE.ATOM NIL)
	    (SETQ PARSE.ATOM2 NIL)
	    (PARSE.BIN)
	    (PARSE.BIN)
	    (PARSE.MODULE)
	    (SETQ PARSE.FILECOMS (DREVERSE PARSE.FILECOMS))
	    (CLOSEF PARSE.STREAM))))

(PARSE.GET.STATE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:46")
                                                             (* Get parser state to save before interruption.
							     *)
    (CREATE PARSERSTATE
	      STREAM ← PARSE.STREAM
	      FILEPTR ← (GETFILEPTR PARSE.STREAM)
	      CHAR ← SCAN.CHAR
	      QDOT ← SCAN.QDOT
	      CLASS ← PARSE.CLASS
	      ATOM ← PARSE.ATOM
	      CLASS2 ← PARSE.CLASS2
	      ATOM2 ← PARSE.ATOM2
	      PREFIX ← BUILD.PREFIX
	      NEXTSCOPE ← BUILD.NEXT.SCOPE
	      CURRENTSCOPE ← BUILD.CURRENT.SCOPE
	      SCOPESTACK ← BUILD.SCOPE.STACK
	      FILECOMS ← BUILD.FILECOMS)))

(PARSE.SET.STATE
  (LAMBDA (STATE)                                            (* kbr: "25-Nov-85 12:46")
                                                             (* Restore state after interruption.
							     *)
    (PROG NIL
	    (SETQ PARSE.STREAM (fetch (PARSERSTATE STREAM) of STATE))
	    (SETFILEPTR PARSE.STREAM (fetch (PARSERSTATE FILEPTR) of STATE))
	    (SETQ SCAN.CHAR (fetch (PARSERSTATE CHAR) of STATE))
	    (SETQ SCAN.QDOT (fetch (PARSERSTATE QDOT) of STATE))
	    (SETQ PARSE.CLASS (fetch (PARSERSTATE CLASS) of STATE))
	    (SETQ PARSE.ATOM (fetch (PARSERSTATE ATOM) of STATE))
	    (SETQ PARSE.CLASS2 (fetch (PARSERSTATE CLASS2) of STATE))
	    (SETQ PARSE.ATOM2 (fetch (PARSERSTATE ATOM2) of STATE))
	    (SETQ BUILD.PREFIX (fetch (PARSERSTATE PREFIX) of STATE))
	    (SETQ BUILD.NEXT.SCOPE (fetch (PARSERSTATE NEXTSCOPE) of STATE))
	    (SETQ BUILD.CURRENT.SCOPE (fetch (PARSERSTATE CURRENTSCOPE) of STATE))
	    (SETQ BUILD.SCOPE.STACK (fetch (PARSERSTATE SCOPESTACK) of STATE))
	    (SETQ BUILD.FILECOMS (fetch (PARSERSTATE FILECOMS) of STATE)))))

(PARSE.BIN
  (LAMBDA (EXPECTCLASS)                                      (* kbr: "25-Nov-85 12:46")
    (PROG (OLDATOM TOKEN)
	    (COND
	      ((AND EXPECTCLASS (OR (AND (LITATOM EXPECTCLASS)
					       (NOT (EQ EXPECTCLASS PARSE.CLASS)))
					(AND (LISTP EXPECTCLASS)
					       (NOT (FMEMB PARSE.CLASS EXPECTCLASS)))))
		(SHOULDNT "PARSE.BIN")))
	    (SETQ OLDATOM PARSE.ATOM)
	    (SETQ TOKEN (SCAN.TOKEN PARSE.STREAM))
	    (SETQ PARSE.CLASS PARSE.CLASS2)
	    (SETQ PARSE.ATOM PARSE.ATOM2)
	    (SETQ PARSE.CLASS2 (CAR TOKEN))
	    (SETQ PARSE.ATOM2 (CADR TOKEN))
	    (RETURN OLDATOM))))

(PARSE.VARID
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:46")
    (BUILD.VARID NIL (PARSE.BIN (QUOTE ID)))))

(PARSE.SMURF
  (LAMBDA (N)                                                (* kbr: "25-Nov-85 12:46")
                                                             (* Indicate where error occurred while reading file *)
    (COND
      ((NULL N)
	(SETQ N 100)))
    (RESETLST (PROG (POSITION START FINISH)            (* Broken file = previous input file *)
		        (SETQ POSITION (GETFILEPTR PARSE.STREAM))
		        (RESETSAVE NIL (LIST (QUOTE SETFILEPTR)
						 PARSE.STREAM POSITION))
		        (SETQ START (IMAX 0 (IDIFFERENCE (SUB1 POSITION)
							       N)))
		        (SETQ FINISH (IMIN (GETEOFPTR PARSE.STREAM)
					       (IPLUS (SUB1 POSITION)
							N)))
		        (COPYBYTES PARSE.STREAM T START (SUB1 POSITION))
		        (PRIN1 "[PARSE]" T)
		        (COPYBYTES PARSE.STREAM T (SUB1 POSITION)
				     FINISH)
		        (TERPRI T)))))

(PARSE.THISIS.MESA
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:46")
                                                             (* Assert this is MESA *)
    (COND
      ((NOT (EQ PARSE.LANGUAGE (QUOTE MESA)))
	(SHOULDNT)))))

(PARSE.THISIS.CEDAR
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:46")
                                                             (* Assert this is CEDAR *)
    (COND
      ((NOT (EQ PARSE.LANGUAGE (QUOTE CEDAR)))
	(SHOULDNT)))))

(PARSE.MODULE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:46")
    (PROG (IDENTLIST)                                      (* (module directory identlist cedar proghead trusted 
							     checked block) (module directory identlist cedar 
							     defhead defbody) *)
	    (PARSE.DIRECTORY)
	    (SETQ IDENTLIST (PARSE.IDENTLIST))
	    (BUILD.INIT (CAR IDENTLIST))
	    (BUILD.STORE.INTERFACES IDENTLIST)
	    (PARSE.SEADIRT)
	    (COND
	      ((NOT (EQ PARSE.ATOM (QUOTE DEFINITIONS)))
		(PARSE.PROGHEAD)
		(PARSE.CHECKED)
		(PARSE.BLOCK))
	      (T (PARSE.DEFHEAD)
		 (PARSE.DEFBODY)))
	    (PUTPROP BUILD.PREFIX (QUOTE MESA.PARSED)
		       T)
	    (PUSHNEW PARSE.FILELST BUILD.PREFIX))))

(PARSE.INCLUDEITEM
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:46")
    (PROG (ID USING)

          (* (includeitem id : FROM string using) (includeitem id : TYPE using) (includeitem id using) 
	  (includeitem id : TYPE id using) *)


	    (SETQ ID (PARSE.BIN (QUOTE ID)))
	    (BUILD.STORE.INTERFACE ID)
	    (PARSE.INCLUDECHECK ID)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE :))
		(PARSE.BIN)
		(COND
		  ((EQ PARSE.ATOM (QUOTE FROM))
		    (PARSE.BIN)
		    (PARSE.BIN (QUOTE STRING))
		    (SETQ USING (PARSE.USING)))
		  (T (PARSE.BIN (QUOTE TYPE))
		     (COND
		       ((EQ PARSE.ATOM (QUOTE ID))
			 (PARSE.BIN (QUOTE ID))
			 (SETQ USING (PARSE.USING)))
		       ((EQ PARSE.ATOM (QUOTE USING))
			 (SETQ USING (PARSE.USING)))))))
	      (T (SETQ USING (PARSE.USING))))
	    (BUILD.STORE.USING ID USING))))

(PARSE.INCLUDECHECK
  (LAMBDA (ID)                                               (* kbr: "25-Nov-85 12:46")
    (PROG (STATE FILE)
	    (COND
	      ((GETPROP ID (QUOTE MESA.PARSED))          (* Interface already loaded.
							     *)
		(RETURN)))
	    (SELECTQ (ASKUSER NIL NIL (CONCAT "Should I parse " ID ".MESA?"))
		       (Y (SETQ FILE (OR (FINDFILE (PACK* ID (QUOTE .MESA))
							 NIL PARSE.DIRLST)
					     (MKATOM (PROMPTFORWORD (CONCAT 
								       "Enter full filename for "
										  ID ".MESA:")))))
			  (COND
			    (FILE (SETQ STATE (PARSE.GET.STATE))
				  (PARSE.FILE FILE PARSE.LANGUAGE PARSE.DIRLST)
				  (PARSE.SET.STATE STATE))))
		       (N NIL)
		       (SHOULDNT)))))

(PARSE.SEADIRT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:46")
                                                             (* BOTH (cedar) *)
                                                             (* CEDAR (cedar CEDAR) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE CEDAR))
	(PARSE.THISIS.CEDAR)
	(PARSE.BIN)))))

(PARSE.PROGHEAD
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:46")
    (PROG NIL                                              (* (proghead resident safe class arguments locks 
							     interface tilde public) *)
                                                             (* In MESA, tilde must be =.
							     This is handled by PARSE.TILDE.
							     *)
	    (PARSE.RESIDENT)
	    (PARSE.SAFE)
	    (PARSE.CLASS)
	    (PARSE.ARGUMENTS)
	    (PARSE.LOCKS)
	    (PARSE.INTERFACE)
	    (PARSE.TILDE)
	    (PARSE.PUBLIC))))

(PARSE.RESIDENT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* BOTH (resident) *)
                                                             (* MESA (resident RESIDENT) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE RESIDENT))
	(PARSE.THISIS.MESA)
	(PARSE.BIN)))))

(PARSE.SAFE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* BOTH (safe) *)
                                                             (* CEDAR (safe UNSAFE) (safe SAFE) *)
    (COND
      ((FMEMB PARSE.ATOM (QUOTE (SAFE UNSAFE)))
	(PARSE.THISIS.CEDAR)
	(PARSE.BIN)))))

(PARSE.DEFHEAD
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG NIL                                              (* (defhead definitions locks imports shares tilde 
							     public) *)
	    (PARSE.DEFINITIONS)
	    (PARSE.LOCKS)
	    (PARSE.IMPORTS)
	    (PARSE.SHARES)
	    (PARSE.TILDE)
	    (PARSE.PUBLIC))))

(PARSE.TILDE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* BOTH (tilde =) *)
                                                             (* CEDAR (tilde ~) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE =))
	(PARSE.BIN))
      ((EQ PARSE.ATOM (QUOTE ~))
	(PARSE.THISIS.CEDAR)
	(PARSE.BIN))
      (T (SHOULDNT)))))

(PARSE.DEFINITIONS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (definitions DEFINITIONS) *)
    (PARSE.BIN)))

(PARSE.DEFBODY
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG NIL

          (* (defbody BEGIN open declist END) (defbody BEGIN open declist ; END) (defbody { open declist }) 
	  (defbody { open declist ; }) *)


	    (PARSE.BIN (QUOTE (BEGIN {)))
	    (BUILD.PUSH.SCOPE)
	    (BUILD.STORE.OPEN (PARSE.OPEN))
	    (PARSE.DECLIST)
	    (BUILD.POP.SCOPE)
	    (BUILD.GC.SCOPE)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE ;))
		(PARSE.BIN)))
	    (PARSE.BIN (QUOTE (END }))))))

(PARSE.LOCKS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG NIL                                              (* (locks LOCKS primary lambda) 
							     (locks) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE LOCKS))
		(PARSE.BIN)
		(PARSE.PRIMARY)
		(PARSE.LAMBDA))))))

(PARSE.LAMBDA
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (IDENT TYPEEXP)                                  (* (lambda USING ident typeexp) 
							     (lambda) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE USING))
		(PARSE.BIN)
		(SETQ IDENT (PARSE.IDENT))
		(SETQ TYPEEXP (PARSE.TYPEEXP))
		(BUILD.INITIALIZE.VAR IDENT TYPEEXP NIL BUILD.CURRENT.SCOPE))))))

(PARSE.MODULEITEM
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ID1 ID2)                                        (* (moduleitem id) (moduleitem id : id) *)
	    (SETQ ID1 (PARSE.BIN (QUOTE ID)))
	    (COND
	      ((EQ PARSE.ATOM (QUOTE :))
		(PARSE.BIN)
		(SETQ ID2 (PARSE.BIN (QUOTE ID)))
		(PUTPROP ID1 (QUOTE MESA.ABBREVIATES)
			   (QUOTE ID2))))
	    (RETURN ID1))))

(PARSE.DECLARATION
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (IDENTLIST TYPEEXP INITIALIZATION DEFAULT OPTSIZE ANSWER)

          (* (declaration identlist public entry readonly typeexp initialization) (declaration identlist public TYPE tilde 
	  public typeexp default) (declaration identlist public TYPE optsize) *)

                                                             (* In MESA, tilde must be =.
							     This is handled by PARSE.TILDE.
							     *)
	    (SETQ IDENTLIST (PARSE.IDENTLIST))
	    (BUILD.STORE.IDENTLIST IDENTLIST)
	    (PARSE.PUBLIC)
	    (COND
	      ((NOT (EQ PARSE.ATOM (QUOTE TYPE)))
		(PARSE.ENTRY)
		(PARSE.READONLY)
		(SETQ TYPEEXP (PARSE.TYPEEXP))
		(SETQ INITIALIZATION (PARSE.INITIALIZATION))
		(SETQ ANSWER (BUILD.INITIALIZATION IDENTLIST TYPEEXP INITIALIZATION)))
	      (T (PARSE.BIN (QUOTE TYPE))
		 (COND
		   ((OR (EQ PARSE.ATOM (QUOTE =))
			  (AND (EQ PARSE.LANGUAGE (QUOTE CEDAR))
				 (EQ PARSE.ATOM (QUOTE ~))))
		     (PARSE.TILDE)
		     (PARSE.PUBLIC)
		     (SETQ TYPEEXP (PARSE.TYPEEXP))
		     (SETQ DEFAULT (PARSE.DEFAULT))
		     (BUILD.TYPE IDENTLIST TYPEEXP DEFAULT))
		   (T (SETQ OPTSIZE (PARSE.OPTSIZE))

          (* I think this means MESA/CEDAR is to treat declared id as a type, but no declaration of id is given in this file.
	  *)


		      ))))
	    (BUILD.STORE.IDENTLIST NIL)
	    (RETURN ANSWER))))

(PARSE.PUBLIC
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (public PUBLIC) (public PRIVATE) 
							     (public) *)
    (COND
      ((MEMB PARSE.ATOM (QUOTE (PUBLIC PRIVATE)))
	(PARSE.BIN)))))

(PARSE.ENTRY
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (entry ENTRY) (entry INTERNAL) 
							     (entry) *)
    (COND
      ((MEMB PARSE.ATOM (QUOTE (ENTRY INTERNAL)))
	(PARSE.BIN)))))

(PARSE.IDLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (idlist' id) (idlist' id , idlist') *)
    (PROG (IDS ANSWER)
	    (PUSH IDS (PARSE.BIN (QUOTE ID)))
	    (WHILE (EQ PARSE.ATOM (QUOTE ,))
	       DO (PARSE.BIN)
		    (PUSH IDS (PARSE.BIN (QUOTE ID))))
	    (SETQ ANSWER (DREVERSE IDS))
	    (RETURN ANSWER))))

(PARSE.IDENTLIST
  (LAMBDA (KIND)                                             (* kbr: "25-Nov-85 12:47")
                                                             (* (identlist' id :) (identlist' id position :) 
							     (identlist' id , identlist') 
							     (identlist' id position , identlist') *)
    (PROG (IDS TYPEITEMS ANSWER)
	LOOP(COND
	      ((AND (EQ KIND (QUOTE FIELDLIST))
		      (PARSE.TYPEEXP.HERE))                (* Thought we we're parsing a pairlist, but now we 
							     learn we are in a typelist.
							     *)
		(SETQ TYPEITEMS (fetch (TYPELIST ITEMS) of (PARSE.TYPELIST)))
		(GO TYPELIST)))
	    (PUSH IDS (PARSE.BIN (QUOTE ID)))
	    (COND
	      ((EQ PARSE.ATOM (QUOTE %())
		(PARSE.POSITION)))
	    (COND
	      ((EQ PARSE.ATOM (QUOTE ,))
		(PARSE.BIN)
		(GO LOOP))
	      (T (GO EXIT)))
	    (GO LOOP)
	EXIT(COND
	      ((NOT (EQ PARSE.ATOM (QUOTE :)))
		(GO TYPELIST)))
	    (PARSE.BIN (QUOTE :))
	    (SETQ ANSWER (DREVERSE IDS))
	    (RETURN ANSWER)
	TYPELIST
	    (SETQ ANSWER (CREATE TYPELIST
				     ITEMS ← (NCONC (DREVERSE IDS)
						      TYPEITEMS)))
	    (RETURN ANSWER))))

(PARSE.POSITION
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (EXP OPTBITS ANSWER)                             (* (position %( exp optbits %)) *)
	    (PARSE.BIN (QUOTE %())
	    (SETQ EXP (PARSE.EXP))
	    (SETQ OPTBITS (PARSE.OPTBITS))
	    (PARSE.BIN (QUOTE %)))
	    (SETQ ANSWER (LIST (QUOTE position)
				   EXP OPTBITS))
	    (RETURN ANSWER))))

(PARSE.OPTBITS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (optbits : bounds) (optbits) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE :))
	(PARSE.BIN (QUOTE :))
	(PARSE.BOUNDS)))))

(PARSE.INTERVAL
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (KIND BOUNDS ANSWER)                             (* (interval %[ bounds %]) 
							     (interval %[ bounds %)) (interval %( bounds %]) 
							     (interval %( bounds %)) *)
	    (SELECTQ PARSE.ATOM
		       (%[ (PARSE.BIN)
			   (SETQ BOUNDS (PARSE.BOUNDS))
			   (SELECTQ PARSE.ATOM
				      (%] (SETQ KIND (QUOTE CC)))
				      (%) (SETQ KIND (QUOTE CO)))
				      (SHOULDNT))
			   (PARSE.BIN))
		       (%( (PARSE.BIN)
			   (SETQ BOUNDS (PARSE.BOUNDS))
			   (SELECTQ PARSE.ATOM
				      (%] (SETQ KIND (QUOTE OC)))
				      (%) (SETQ KIND (QUOTE OO)))
				      (SHOULDNT))
			   (PARSE.BIN))
		       (SHOULDNT))
	    (SETQ ANSWER (CREATE MINTERVAL
				     KIND ← KIND
				     BOUNDS ← BOUNDS))
	    (RETURN ANSWER))))

(PARSE.TYPEEXP.HERE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    NIL))

(PARSE.TYPEEXP
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ANSWER)                                         (* (typeexp id) (typeexp typeid) 
							     (typeexp typecons) *)
	    (COND
	      ((EQ PARSE.CLASS (QUOTE ID))
		(SETQ ANSWER (PARSE.BIN))
		(COND
		  ((NOT (FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW))
		    (SETQ ANSWER (PARSE.TYPEID.CONT ANSWER)))
		  (T (SETQ ANSWER (BUILD.TYPEID NIL ANSWER))))
		(COND
		  ((NOT (FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW))
		    (SETQ ANSWER (PARSE.TYPECONS.CONT ANSWER)))))
	      (T (SETQ ANSWER (PARSE.TYPECONS))))
	    (RETURN ANSWER))))

(PARSE.RANGE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (TYPE INTERVAL ANSWER)                           (* (range id) (range id interval) 
							     (range typeid interval) (range interval) 
							     (range typeid) *)
	    (COND
	      ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST)
		(SETQ TYPE (QUOTE CARDINAL))
		(SETQ INTERVAL (PARSE.INTERVAL)))
	      ((FMEMB PARSE.ATOM2 PARSE.RANGE.FOLLOW)      (* This case occurs if TYPE itself is a range type.
							     *)
		(SETQ TYPE (BUILD.TYPEID NIL (PARSE.BIN (QUOTE ID))))
		(RETURN TYPE))
	      ((FMEMB PARSE.ATOM2 PARSE.INTERVAL.FIRST)
		(SETQ TYPE (BUILD.TYPEID NIL (PARSE.BIN (QUOTE ID))))
		(SETQ INTERVAL (PARSE.INTERVAL)))
	      (T (SETQ TYPE (PARSE.TYPEID))
		 (COND
		   ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST)
		     (SETQ INTERVAL (PARSE.INTERVAL))))))
	    (SETQ ANSWER (CREATE MRANGE
				     TYPE ← TYPE
				     INTERVAL ← INTERVAL))
	    (RETURN ANSWER))))

(PARSE.TYPEAPPL
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG NIL                                              (* (typeappl typeappl %. id) 
							     (typeappl id length) (typeappl typeid length) 
							     (typeappl typeappl length) *)
	    (BREAK1 NIL T))))

(PARSE.TYPEAPPL.CONT
  (LAMBDA (TYPEAPPL)                                         (* kbr: "25-Nov-85 12:47")
    (PROG (ID LENGTH ANSWER)
	    (SETQ ANSWER TYPEAPPL)
	    (WHILE (FMEMB PARSE.ATOM (QUOTE (%. %[))) DO (COND
								     ((EQ PARSE.ATOM (QUOTE
									      %.))
								       (PARSE.BIN)
								       (SETQ ID
									 (PARSE.BIN (QUOTE ID)))
								       (SETQ ANSWER
									 (LIST ANSWER ID)))
								     (T (SETQ LENGTH (PARSE.LENGTH
									    ))
									(SETQ ANSWER
									  (LIST ANSWER LENGTH)))))
	    (RETURN ANSWER))))

(PARSE.TYPEID
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PARSE.TYPEID.CONT (PARSE.BIN (QUOTE ID)))))

(PARSE.TYPEID.CONT
  (LAMBDA (ID)                                               (* kbr: "25-Nov-85 12:47")
    (PROG (INTERFACE ANSWER)                               (* (typeid' id %. id) (typeid' typeid' %.
							     id) (typeid id id) (typeid id typeid) 
							     (typeid typeid') *)
                                                             (* Should be ID+{.ID}* *)
	    (WHILE (EQ PARSE.CLASS (QUOTE ID))
	       DO (BREAK1 NIL T)
		    (SETQ ID (PARSE.BIN)))
	    (COND
	      ((EQ PARSE.ATOM (QUOTE %.))
		(SETQ INTERFACE ID)
		(PARSE.BIN)
		(SETQ ID (PARSE.BIN (QUOTE ID)))))
	    (SETQ ANSWER (BUILD.TYPEID INTERFACE ID))
	    (RETURN ANSWER))))

(PARSE.TYPECONS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (COND
      ((EQ PARSE.CLASS (QUOTE ID))
	(PARSE.TYPECONS1))
      (T (PARSE.TYPECONS2)))))

(PARSE.TYPECONS1
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* TYPECONS begining with ID token.
							     *)
    (PROG (TYPEID ANSWER)                                  (* BOTH (typecons id interval) 
							     (typecons typeid interval) 
							     (typecons id RELATIVE typeexp) 
							     (typecons typeid RELATIVE typeexp) 
							     (typecons typeappl) *)
                                                             (* CEDAR (typecons id PAINTED typeexp) 
							     (typecons typeid PAINTED typeexp) *)
                                                             (* Get id or typeid. *)
	    (SETQ TYPEID (PARSE.BIN (QUOTE ID)))
	    (COND
	      ((NOT (FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW))
		(SETQ TYPEID (PARSE.TYPEID.CONT TYPEID)))
	      (T (SETQ TYPEID (BUILD.TYPEID NIL TYPEID))))
                                                             (* Finish typecons. *)
	    (SETQ ANSWER (PARSE.TYPECONS.CONT TYPEID))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.CONT
  (LAMBDA (TYPEID)                                           (* kbr: "25-Nov-85 12:47")
                                                             (* TYPEID is an id or typeid.
							     Finish typecons. *)
    (PROG (INTERVAL TYPEEXP EXP1 EXP2 KIND ANSWER)         (* BOTH (typecons id interval) 
							     (typecons typeid interval) 
							     (typecons id RELATIVE typeexp) 
							     (typecons typeid RELATIVE typeexp) 
							     (typecons typeappl) *)
                                                             (* CEDAR (typecons id PAINTED typeexp) 
							     (typecons typeid PAINTED typeexp) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE RELATIVE))
		(SETQ ANSWER (PARSE.TYPECONS.RELATIVE)))
	      ((EQ PARSE.ATOM (QUOTE PAINTED))
		(SETQ ANSWER (PARSE.TYPECONS.PAINTED)))
	      ((EQ PARSE.ATOM (QUOTE %())
		(PARSE.TYPECONS.RANGE TYPEID))
	      ((EQ PARSE.ATOM (QUOTE %[))                (* This can be the start of a length or of an 
							     interval. Can't tell with bounded look ahead.
							     *)
		(PARSE.BIN (QUOTE %[))
		(SETQ EXP1 (PARSE.EXP))
		(COND
		  ((EQ PARSE.ATOM (QUOTE ..))            (* Interval. *)
		    (PARSE.BIN (QUOTE ..))
		    (SETQ EXP2 (PARSE.EXP))
		    (COND
		      ((EQ PARSE.ATOM (QUOTE %)))
			(PARSE.BIN (QUOTE %)))
			(SETQ KIND (QUOTE CO)))
		      (T (PARSE.BIN (QUOTE %]))
			 (SETQ KIND (QUOTE CC))))
		    (SETQ INTERVAL (CREATE MINTERVAL
					       KIND ← KIND
					       BOUNDS ← (LIST EXP1 EXP2)))
		    (SETQ ANSWER (CREATE MRANGE
					     TYPE ← TYPEID
					     INTERVAL ← INTERVAL)))
		  (T                                         (* Length. *)
		     (PARSE.BIN (QUOTE %]))
		     (SETQ ANSWER (LIST TYPEID EXP1))
		     (SETQ ANSWER (PARSE.TYPEAPPL.CONT ANSWER)))))
	      (T (SHOULDNT)))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.RANGE
  (LAMBDA (TYPEID)                                           (* kbr: "25-Nov-85 12:47")
    (PROG (INTERVAL ANSWER)
	    (SETQ INTERVAL (PARSE.INTERVAL))
	    (SETQ ANSWER (CREATE MRANGE
				     TYPE ← TYPEID
				     INTERVAL ← INTERVAL))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.RELATIVE
  (LAMBDA (TYPEID)                                           (* kbr: "25-Nov-85 12:47")
    (PROG (TYPE ANSWER)
	    (PARSE.BIN (QUOTE RELATIVE))
	    (SETQ TYPE (PARSE.TYPEEXP))
	    (SETQ ANSWER (CREATE MRELATIVE
				     TYPEID ← TYPEID
				     TYPE ← TYPE))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.PAINTED
  (LAMBDA (TYPEID)                                           (* kbr: "25-Nov-85 12:47")
    (PROG (TYPE ANSWER)
	    (PARSE.THISIS.CEDAR)
	    (PARSE.BIN (QUOTE RELATIVE))
	    (SETQ TYPE (PARSE.TYPEEXP))
	    (SETQ ANSWER (CREATE MPAINTED
				     TYPEID ← TYPEID
				     TYPE ← TYPE))
	    (RETURN ANSWER))))

(PARSE.TYPECONS2
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* TYPECONS begining with reserved word.
							     *)
    (PROG (ANSWER)

          (* BOTH (typecons interval) (typecons dependent { elementlist }) (typecons dependent monitored RECORD reclist) 
	  (typecons ordered base pointertype) (typecons VAR typeexp) (typecons packed ARRAY indextype OF typeexp) 
	  (typecons DESCRIPTOR FOR readonly typeexp) (typecons safe transfermode arguments) (typecons heap ZONE) 
	  (typecons LONG typeexp) (typecons FRAME %[ id %]) *)

                                                             (* CEDAR (typecons REF readonly typeexp) 
							     (typecons REF readonly ANY) 
							     (typecons REF) (typecons LIST OF readonly typeexp) *)
	    (SETQ ANSWER (COND
		((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST)
		  (PARSE.TYPECONS.INTERVAL))
		(T (SELECTQ PARSE.ATOM
			      ((MACHINE MONITORED RECORD {)
				(PARSE.TYPECONS.DEPENDENT))
			      ((ORDERED BASE POINTER)
				(PARSE.TYPECONS.ORDERED))
			      (VAR (PARSE.TYPECONS.VAR))
			      ((PACKED ARRAY)
				(PARSE.TYPECONS.PACKED))
			      (DESCRIPTOR (PARSE.TYPECONS.DESCRIPTOR))
			      ((SAFE ERROR PORT PROC PROCEDURE PROCESS PROGRAM SIGNAL)
				(PARSE.TYPECONS.SAFE))
			      (UNCOUNTED (PARSE.TYPECONS.HEAP))
			      (LONG (PARSE.TYPECONS.LONG))
			      (FRAME (PARSE.TYPECONS.FRAME))
			      (REF (PARSE.TYPECONS.REF))
			      (LIST (PARSE.TYPECONS.LIST))
			      (SHOULDNT)))))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.INTERVAL
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ANSWER)                                         (* (typecons interval) *)
	    (SETQ ANSWER (CREATE MRANGE
				     TYPE ← (QUOTE CARDINAL)
				     INTERVAL ← (PARSE.INTERVAL)))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.DEPENDENT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ELEMENTLIST RECLIST ANSWER)                     (* (typecons dependent { elementlist }) 
							     (typecons dependent monitored RECORD reclist) *)
	    (PARSE.DEPENDENT)
	    (SETQ ANSWER (COND
		((EQ PARSE.ATOM (QUOTE {))
		  (PARSE.TYPECONS.ENUMERATED))
		(T (PARSE.TYPECONS.RECORD))))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.ENUMERATED
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ITEMS ANSWER)
	    (PARSE.BIN)
	    (SETQ ITEMS (PARSE.ELEMENTLIST))
	    (PARSE.BIN (QUOTE }))
	    (SETQ ANSWER (CREATE MENUMERATED
				     ITEMS ← ITEMS))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.RECORD
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (FIELDLIST ANSWER)
	    (PARSE.MONITORED)
	    (PARSE.BIN (QUOTE RECORD))
	    (SETQ FIELDLIST (PARSE.RECLIST))
	    (SETQ ANSWER (CREATE MRECORD
				     FIELDLIST ← FIELDLIST))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.ORDERED
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ANSWER)                                         (* (typecons ordered base pointertype) *)
	    (PARSE.ORDERED)
	    (PARSE.BASE)
	    (SETQ ANSWER (PARSE.POINTERTYPE))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.VAR
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (TYPE ANSWER)                                    (* (typecons VAR typeexp) *)
	    (PARSE.BIN (QUOTE VAR))
	    (SETQ TYPE (PARSE.TYPEEXP))
	    (SETQ ANSWER (CREATE MVAR
				     TYPE ← TYPE))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.PACKED
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (PACKED INDEXTYPE TYPE ANSWER)                   (* (typecons packed ARRAY indextype OF typeexp) *)
	    (SETQ PACKED (PARSE.PACKED))
	    (PARSE.BIN (QUOTE ARRAY))
	    (SETQ INDEXTYPE (PARSE.INDEXTYPE))
	    (PARSE.BIN (QUOTE OF))
	    (SETQ TYPE (PARSE.TYPEEXP))
	    (SETQ ANSWER (CREATE MARRAY
				     INDEXTYPE ← INDEXTYPE
				     TYPE ← TYPE))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.DESCRIPTOR
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (TYPE ANSWER)                                    (* (typecons DESCRIPTOR FOR readonly typeexp) *)
	    (PARSE.BIN (QUOTE DESCRIPTOR))
	    (PARSE.BIN (QUOTE FOR))
	    (PARSE.READONLY)
	    (SETQ TYPE (PARSE.TYPEEXP))
	    (SETQ ANSWER (CREATE MDESCRIPTOR
				     TYPE ← TYPE))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.SAFE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (TRANSFERMODE)                                   (* (typecons safe transfermode arguments) *)
	    (PARSE.SAFE)
	    (SETQ TRANSFERMODE (PARSE.TRANSFERMODE))
	    (PARSE.ARGUMENTS)
	    (RETURN TRANSFERMODE))))

(PARSE.TYPECONS.HEAP
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG NIL                                              (* (typecons heap ZONE) *)
	    (PARSE.HEAP)
	    (PARSE.BIN (QUOTE ZONE))
	    (RETURN (QUOTE ZONE)))))

(PARSE.TYPECONS.LONG
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ANSWER)                                         (* (typecons LONG typeexp) *)
	    (PARSE.BIN (QUOTE LONG))
	    (SETQ ANSWER (PARSE.TYPEEXP))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.FRAME
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ID ANSWER)                                      (* (typecons FRAME %[ id %]) *)
	    (PARSE.BIN (QUOTE FRAME))
	    (PARSE.BIN (QUOTE %[))
	    (SETQ ID (BUILD.ID NIL (PARSE.BIN (QUOTE ID))))
	    (PARSE.BIN (QUOTE %]))
	    (SETQ ANSWER (CREATE MFRAME
				     ID ← ID))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.REF
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (TYPE ANSWER)                                    (* CEDAR (typecons REF readonly typeexp) 
							     (typecons REF readonly ANY) 
							     (typecons REF) *)
	    (PARSE.THISIS.CEDAR)
	    (PARSE.BIN (QUOTE REF))
	    (COND
	      ((FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW)
		(SETQ TYPE (QUOTE ANY)))
	      (T (PARSE.READONLY)
		 (COND
		   ((EQ PARSE.ATOM (QUOTE ANY))
		     (PARSE.BIN)
		     (SETQ TYPE (QUOTE ANY)))
		   (T (SETQ TYPE (PARSE.TYPEEXP))))))
	    (SETQ ANSWER (CREATE MREF
				     TYPE ← TYPE))
	    (RETURN ANSWER))))

(PARSE.TYPECONS.LIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (TYPE ANSWER)                                    (* CEDAR (typecons LIST OF readonly typeexp) *)
	    (PARSE.THISIS.CEDAR)
	    (PARSE.BIN (QUOTE LIST))
	    (PARSE.BIN (QUOTE OF))
	    (PARSE.READONLY)
	    (SETQ TYPE (PARSE.TYPEEXP))
	    (SETQ ANSWER (CREATE MLIST
				     TYPE ← TYPE))
	    (RETURN ANSWER))))

(PARSE.IDENT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ID)                                             (* (ident id position :) (ident id :) *)
	    (SETQ ID (PARSE.BIN (QUOTE ID)))
	    (COND
	      ((EQ PARSE.ATOM (QUOTE :))
		(PARSE.BIN))
	      (T (PARSE.POSITION)
		 (PARSE.BIN (QUOTE :))))
	    (RETURN ID))))

(PARSE.ELEMENT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ID EXP ANSWER)                                  (* (element id %( exp %)) (element %( exp %)) 
							     (element id) *)
	    (COND
	      ((NOT (EQ PARSE.ATOM (QUOTE %()))
		(SETQ ID (PARSE.BIN (QUOTE ID)))))
	    (COND
	      ((EQ PARSE.ATOM (QUOTE %())
		(PARSE.BIN)
		(SETQ EXP (PARSE.EXP))
		(SETQ ANSWER ID)
		(PARSE.BIN (QUOTE %))))
	      (T (SETQ ANSWER ID)))
	    (RETURN ANSWER))))

(PARSE.MONITORED
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (monitored MONITORED) (monitored) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE MONITORED))
	(PARSE.BIN)))))

(PARSE.DEPENDENT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (dependent MACHINE DEPENDENT) 
							     (dependent) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE MACHINE))
	(PARSE.BIN)
	(PARSE.BIN (QUOTE DEPENDENT))
	(QUOTE MACHINE.DEPENDENT)))))

(PARSE.RECLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (PAIRLIST TYPELIST VARIANTPAIR VARIANTPART DEFAULT ANSWER)

          (* (reclist %[ %]) (reclist NULL) (reclist %[ pairlist %]) (reclist %[ typelist %]) (reclist %[ pairlist , 
	  variantpair %]) (reclist %[ variantpart default %]) (reclist %[ variantpair %]) *)


	    (COND
	      ((EQ PARSE.ATOM (QUOTE NULL))
		(PARSE.BIN)
		(RETURN NIL)))
	    (PARSE.BIN (QUOTE %[))
	    (COND
	      ((EQ PARSE.ATOM (QUOTE %]))
		(PARSE.BIN)
		(RETURN NIL)))
	    (COND
	      ((FMEMB PARSE.ATOM PARSE.VARIANTPART.FIRST)
		(SETQ VARIANTPART (PARSE.VARIANTPART))
		(SETQ DEFAULT (PARSE.DEFAULT))
		(SETQ ANSWER (LIST (CREATE PAIRITEM
						 TYPEEXP ← VARIANTPART
						 DEFAULT ← DEFAULT))))
	      ((AND (EQ PARSE.CLASS (QUOTE ID))
		      (NOT (FMEMB PARSE.ATOM PARSE.PREDEFINED.TYPES))
		      (FMEMB PARSE.ATOM2 (QUOTE (%( , :))))
		(SETQ PAIRLIST (PARSE.PAIRLIST (QUOTE RECLIST)))
		(FOR PAIRITEM IN (fetch (PAIRLIST ITEMS) of PAIRLIST)
		   DO (replace (PAIRITEM ID) of PAIRITEM with (BUILD.FIELDID
									NIL
									(fetch (PAIRITEM ID)
									   of PAIRITEM))))
		(SETQ ANSWER PAIRLIST))
	      (T (SETQ TYPELIST (PARSE.TYPELIST))
		 (SETQ ANSWER TYPELIST)))
	    (PARSE.BIN (QUOTE %]))
	    (RETURN ANSWER))))

(PARSE.VARIANTPAIR
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (IDENTLIST PUBLIC VARIANTPART DEFAULT ANSWER)    (* (variantpair identlist public variantpart default) 
							     *)
	    (SETQ IDENTLIST (PARSE.IDENTLIST))
	    (PARSE.PUBLIC)
	    (SETQ VARIANTPART (PARSE.VARIANTPART))
	    (SETQ DEFAULT (PARSE.DEFAULT))
	    (SETQ ANSWER (FOR ID IN IDENTLIST
			      COLLECT (CREATE PAIRITEM
						  ID ← ID
						  TYPEEXP ← VARIANTPART
						  DEFAULT ← DEFAULT)))
	    (RETURN ANSWER))))

(PARSE.PAIRITEM
  (LAMBDA (KIND)                                             (* kbr: "25-Nov-85 12:47")
    (PROG (IDENTLIST VARIANTPART TYPEEXP DEFAULT ANSWER)   (* (pairitem identlist public typeexp default) 
							     (variantpair identlist public variantpart default) *)
	    (SETQ IDENTLIST (PARSE.IDENTLIST KIND))
	    (COND
	      ((TYPE? TYPELIST IDENTLIST)                  (* Thought we we're parsing a pairlist but found a 
							     typelist. *)
		(RETURN IDENTLIST)))
	    (PARSE.PUBLIC)
	    (COND
	      ((AND (FMEMB PARSE.ATOM PARSE.VARIANTPART.FIRST)
		      (OR (NOT (EQ PARSE.ATOM (QUOTE PACKED)))
			    (NOT (EQ PARSE.ATOM2 (QUOTE ARRAY)))))
                                                             (* Variantpair. *)
		(COND
		  ((NOT (EQ KIND (QUOTE RECLIST)))
		    (SHOULDNT)))
		(SETQ TYPEEXP (PARSE.VARIANTPART)))
	      (T                                             (* Typeexp. *)
		 (SETQ TYPEEXP (PARSE.TYPEEXP))))
	    (SETQ DEFAULT (PARSE.DEFAULT))
	    (SETQ ANSWER (FOR ID IN IDENTLIST
			      COLLECT (CREATE PAIRITEM
						  ID ← ID
						  TYPEEXP ← TYPEEXP
						  DEFAULT ← DEFAULT)))
	    (RETURN ANSWER))))

(PARSE.DEFAULTOPT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (EXP TRASH ANSWER)                               (* (defaultopt TRASH) (defaultopt NULL) 
							     (defaultopt exp %| TRASH) (defaultopt exp %| NULL) 
							     (defaultopt) (defaultopt exp) *)
	    (COND
	      ((FMEMB PARSE.ATOM (QUOTE (TRASH NULL)))
		(PARSE.BIN)
		(SETQ TRASH T))
	      ((NOT (FMEMB PARSE.ATOM PARSE.DEFAULTOPT.FOLLOW))
		(SETQ EXP (PARSE.EXP))
		(COND
		  ((EQ PARSE.ATOM (QUOTE %|))
		    (PARSE.BIN (QUOTE %|))
		    (COND
		      ((FMEMB PARSE.ATOM (QUOTE (TRASH NULL)))
			(PARSE.BIN)
			(SETQ TRASH T)))))))
	    (SETQ ANSWER (CREATE DEFAULT
				     EXP ← EXP
				     TRASH ← TRASH))
	    (RETURN ANSWER))))

(PARSE.VARIANTPART
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (VCASEHEAD VARIANTLIST TYPEEXP ANSWER)           (* (variantpart SELECT vcasehead FROM variantlist 
							     ENDCASE) (variantpart SELECT vcasehead FROM 
							     variantlist , ENDCASE) (variantpart packed SEQUENCE 
							     vcasehead OF typeexp) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE SELECT))
		(PARSE.BIN)
		(SETQ VCASEHEAD (PARSE.VCASEHEAD))
		(PARSE.BIN (QUOTE FROM))
		(SETQ VARIANTLIST (PARSE.VARIANTLIST))
		(COND
		  ((EQ PARSE.ATOM (QUOTE ,))
		    (PARSE.BIN)))
		(PARSE.BIN (QUOTE ENDCASE))
		(SETQ ANSWER (LIST (QUOTE SELECT)
				       VCASEHEAD VARIANTLIST)))
	      (T (SETQ PACKED (PARSE.PACKED))
		 (PARSE.BIN (QUOTE SEQUENCE))
		 (SETQ VCASEHEAD (PARSE.VCASEHEAD))
		 (PARSE.BIN (QUOTE OF))
		 (SETQ TYPEEXP (PARSE.TYPEEXP))
		 (SETQ ANSWER (LIST (QUOTE SEQUENCE)
					VCASEHEAD TYPEEXP))))
	    (RETURN ANSWER))))

(PARSE.VCASEHEAD
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (IDENT PUBLIC TAGTYPE ANSWER)                    (* (vcasehead ident public tagtype) 
							     (vcasehead COMPUTED tagtype) 
							     (vcasehead OVERLAID tagtype) *)
	    (COND
	      ((NOT (FMEMB PARSE.ATOM (QUOTE (COMPUTED OVERLAID))))
		(SETQ IDENT (PARSE.IDENT))
		(SETQ PUBLIC (PARSE.PUBLIC))
		(SETQ TAGTYPE (PARSE.TAGTYPE))
		(SETQ ANSWER (LIST (QUOTE vcasehead)
				       IDENT PUBLIC TAGTYPE)))
	      (T (SETQ ANSWER (LIST (QUOTE vcasehead)
					(PARSE.BIN)
					(PARSE.TAGTYPE)))))
	    (RETURN ANSWER))))

(PARSE.TAGTYPE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (tagtype *) (tagtype typeexp) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE *))
	(PARSE.BIN))
      (T (PARSE.TYPEEXP)))))

(PARSE.VARIANTITEM
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (IDLIST RECLIST ANSWER)                          (* (variantitem idlist => reclist) *)
	    (SETQ IDLIST (PARSE.IDLIST))
	    (PARSE.BIN (QUOTE =>))
	    (SETQ RECLIST (PARSE.RECLIST))
	    (SETQ ANSWER (LIST (QUOTE variantitem)
				   IDLIST RECLIST))
	    (RETURN ANSWER))))

(PARSE.TYPELIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (TYPEITEMS ANSWER)

          (* (typelist typecons default) (typelist typeid default) (typelist id) (typelist id ← defaultopt) 
	  (typelist typecons default , typelist) (typelist typeid default , typelist) (typelist id , typelist) 
	  (typelist id ← defaultopt , typelist) *)


	    (PUSH TYPEITEMS (PARSE.TYPEITEM))
	    (WHILE (EQ PARSE.ATOM (QUOTE ,))
	       DO (PARSE.BIN)
		    (PUSH TYPEITEMS (PARSE.TYPEITEM)))
	    (SETQ ANSWER (CREATE TYPELIST
				     ITEMS ← (DREVERSE TYPEITEMS)))
	    (RETURN ANSWER))))

(PARSE.TYPEITEM
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (TYPEEXP DEFAULT ANSWER)
	    (SETQ TYPEEXP (PARSE.TYPEEXP))
	    (COND
	      ((NOT (LITATOM TYPEEXP))
		(SETQ DEFAULT (PARSE.DEFAULT)))
	      ((EQ PARSE.ATOM (QUOTE ←))
		(SETQ DEFAULT (PARSE.DEFAULTOPT))))
	    (SETQ ANSWER (CREATE TYPEITEM
				     TYPEEXP ← TYPEEXP
				     DEFAULT ← DEFAULT))
	    (RETURN ANSWER))))

(PARSE.POINTERTYPE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (TYPE ANSWER)                                    (* (pointertype pointerprefix) 
							     (pointertype pointerprefix TO readonly typeexp) *)
	    (PARSE.POINTERPREFIX)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE TO))
		(PARSE.BIN)
		(PARSE.READONLY)
		(SETQ TYPE (PARSE.TYPEEXP)))
	      (T (SETQ TYPE (QUOTE UNSPECIFIED))))
	    (SETQ ANSWER (CREATE MPOINTER
				     TYPE ← TYPE))
	    (RETURN ANSWER))))

(PARSE.TRANSFERMODE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (transfermode PROCEDURE) 
							     (transfermode PROC) (transfermode PORT) 
							     (transfermode SIGNAL) (transfermode ERROR) 
							     (transfermode PROCESS) (transfermode PROGRAM) *)
    (PROG NIL
	    (PARSE.BIN)
	    (RETURN (QUOTE PROC)))))

(PARSE.INITIALIZATION
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ANSWER)                                         (* (initialization) (initialization ← initvalue) 
							     (initialization tilde initvalue) *)
                                                             (* In MESA tilde must be =.
							     *)
	    (COND
	      ((OR (FMEMB PARSE.ATOM (QUOTE (← =)))
		     (AND (EQ PARSE.LANGUAGE (QUOTE CEDAR))
			    (EQ PARSE.ATOM (QUOTE ~))))
		(PARSE.BIN)
		(SETQ ANSWER (PARSE.INITVALUE))))
	    (RETURN ANSWER))))

(PARSE.INITVALUE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (INLINE BLOCK CODELIST EXP ANSWER)

          (* (initvalue procaccess trusted checked inline block) (initvalue CODE) (initvalue procaccess trusted checked 
	  MACHINE CODE BEGIN codelist END) (initvalue procaccess trusted checked MACHINE CODE { codelist }) 
	  (initvalue TRASH) (initvalue NULL) (initvalue exp) *)


	    (COND
	      ((FMEMB PARSE.ATOM (QUOTE (CODE TRASH NULL)))
		(PARSE.BIN)
		(SETQ ANSWER (QUOTE TRASH)))
	      (T (PARSE.CHECKED)
		 (COND
		   ((FMEMB PARSE.ATOM (QUOTE (INLINE BEGIN {)))
		     (SETQ INLINE (PARSE.INLINE))
		     (SETQ BLOCK (PARSE.BLOCK))
		     (SETQ ANSWER BLOCK))
		   ((EQ PARSE.ATOM (QUOTE MACHINE))
		     (PARSE.BIN)
		     (PARSE.BIN (QUOTE CODE))
		     (PARSE.BIN (QUOTE (BEGIN {)))
		     (SETQ CODELIST (PARSE.CODELIST))
		     (PARSE.BIN (QUOTE (END })))
		     (SETQ ANSWER CODELIST))
		   (T (SETQ EXP (PARSE.EXP))
		      (SETQ ANSWER EXP)))))
	    (RETURN ANSWER))))

(PARSE.CHECKED
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* BOTH (checked) *)
                                                             (* CEDAR (checked CHECKED) 
							     (checked TRUSTED) (checked UNCHECKED) *)
    (COND
      ((FMEMB PARSE.ATOM (QUOTE (CHECKED TRUSTED UNCHECKED)))
	(PARSE.THISIS.CEDAR)
	(PARSE.BIN)))))

(PARSE.CODELIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG NIL                                              (* (codelist orderlist) (codelist codelist ;
							     orderlist) *)
	    (BREAK1 NIL T))))

(PARSE.STATEMENT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (COND
      ((FMEMB PARSE.CLASS (QUOTE (ID %()))
	(PARSE.STATEMENT1))
      (T (PARSE.STATEMENT2)))))

(PARSE.STATEMENT1
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (LHS EXP OPTCATCH ANSWER)                        (* (statement lhs) (statement lhs ← exp) 
							     (statement free %[ exp optcatch %]) 
							     (statement lhs ← STATE) *)
	    (SETQ LHS (PARSE.LHS))
	    (COND
	      ((AND (EQ PARSE.ATOM (QUOTE %.))
		      (EQ PARSE.ATOM2 (QUOTE FREE)))
		(PARSE.BIN)
		(PARSE.BIN)
		(PARSE.BIN (QUOTE %[))
		(SETQ EXP (PARSE.EXP))
		(SETQ OPTCATCH (PARSE.OPTCATCH))
		(PARSE.BIN (QUOTE %]))
		(SETQ ANSWER (LIST LHS EXP OPTCATCH)))
	      ((AND (EQ PARSE.ATOM (QUOTE ←))
		      (EQ PARSE.ATOM2 (QUOTE STATE)))
		(PARSE.BIN)
		(PARSE.BIN)
		(SETQ ANSWER LHS))
	      ((EQ PARSE.ATOM (QUOTE ←))
		(PARSE.BIN)
		(SETQ EXP (PARSE.EXP))
		(SETQ ANSWER (BUILD.SETQ LHS EXP)))
	      (T (SETQ ANSWER LHS)))
	    (RETURN ANSWER))))

(PARSE.STATEMENT2
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ANSWER)

          (* (statement %[ explist %] ← exp) (statement trusted checked block) (statement IF exp THEN statement elsepart) 
	  (statement casehead casestmtlist ENDCASE otherpart) (statement forclause dotest DO scope doexit ENDLOOP) 
	  (statement EXIT) (statement LOOP) (statement GOTO id) (statement GO TO id) (statement RETURN optargs) 
	  (statement transfer lhs) (statement WAIT lhs) (statement ERROR) (statement STOP) (statement NULL) 
	  (statement RESUME optargs) (statement REJECT) (statement CONTINUE) (statement RETRY) *)


	    (SETQ ANSWER (COND
		((FMEMB PARSE.ATOM PARSE.CASEHEAD.FIRST)
		  (PARSE.STATEMENT.CASEHEAD))
		((OR (FMEMB PARSE.ATOM PARSE.FORCLAUSE.FIRST)
		       (FMEMB PARSE.ATOM PARSE.DOTEST.FIRST)
		       (EQ PARSE.ATOM (QUOTE DO)))
		  (PARSE.STATEMENT.FORCLAUSE))
		((AND (EQ PARSE.ATOM (QUOTE RETURN))
			(NOT (EQ PARSE.ATOM2 (QUOTE WITH))))
                                                             (* Don't confuse statement RETURN with the transfer 
							     RETURN WITH. *)
		  (PARSE.STATEMENT.RETURN))
		((FMEMB PARSE.ATOM PARSE.TRANSFER.FIRST)
		  (PARSE.STATEMENT.TRANSFER))
		(T (SELECTQ PARSE.ATOM
			      (%[ (PARSE.STATEMENT.LBRACKET))
			      (({ BEGIN CHECKED TRUSTED UNCHECKED)
				(PARSE.CHECKED)
				(PARSE.BLOCK))
			      (IF (PARSE.STATEMENT.IF))
			      (EXIT (PARSE.BIN)
				    (QUOTE (RETURN)))
			      (LOOP (PARSE.BIN)
				    (QUOTE (GO LOOP)))
			      (GOTO (PARSE.BIN)
				    (LIST (QUOTE GO)
					    (PARSE.BIN (QUOTE ID))))
			      (GO (PARSE.BIN)
				    (PARSE.BIN (QUOTE TO))
				    (LIST (QUOTE GO)
					    (PARSE.BIN (QUOTE ID))))
			      (WAIT (PARSE.BIN)
				    (PARSE.LHS))
			      (ERROR (PARSE.BIN)
				       (QUOTE (SHOULDNT)))
			      (STOP (PARSE.BIN)
				    (QUOTE (GO STOP)))
			      (NULL (PARSE.BIN)
				      NIL)
			      (RESUME (PARSE.BIN)
					(PARSE.OPTARGS))
			      (REJECT (PARSE.BIN)
				      (QUOTE (SHOULDNT)))
			      (CONTINUE (PARSE.BIN)
					(QUOTE (GO CONTINUE)))
			      (RETRY (PARSE.BIN)
				     (QUOTE (GO RETRY)))
			      (SHOULDNT)))))
	    (RETURN ANSWER))))

(PARSE.STATEMENT.CASEHEAD
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (CASEHEAD CASESTMTLIST OTHERPART ANSWER)         (* (statement casehead casestmtlist ENDCASE otherpart)
							     *)
	    (BUILD.PUSH.SCOPE)
	    (SETQ CASEHEAD (PARSE.CASEHEAD))
	    (SETQ CASESTMTLIST (PARSE.CASESTMTLIST CASEHEAD))
	    (PARSE.BIN (QUOTE ENDCASE))
	    (SETQ OTHERPART (PARSE.OTHERPART))
	    (SETQ ANSWER (BUILD.SELECTQ CASEHEAD CASESTMTLIST OTHERPART))
	    (COND
	      ((fetch (CASEHEAD ID) of CASEHEAD)
		(BUILD.INITIALIZE.VAR (fetch (CASEHEAD ID) of CASEHEAD)
					NIL
					(fetch (CASEHEAD EXP) of CASEHEAD)
					BUILD.CURRENT.SCOPE)))
	    (SETQ ANSWER (BUILD.PROG (LIST ANSWER)))
	    (BUILD.POP.SCOPE)
	    (RETURN ANSWER))))

(PARSE.STATEMENT.FORCLAUSE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (FORCLAUSE DOTEST SCOPE DOEXIT EXITLIST STATEMENT ANSWER)
                                                             (* (statement forclause dotest DO scope doexit 
							     ENDLOOP) *)
	    (BUILD.STORE.IDENTLIST (QUOTE (DO)))
	    (BUILD.PUSH.SCOPE)
	    (SETQ FORCLAUSE (PARSE.FORCLAUSE))
	    (SETQ DOTEST (PARSE.DOTEST))
	    (PARSE.BIN (QUOTE DO))
	    (SETQ SCOPE (PARSE.SCOPE))
	    (SETQ DOEXIT (PARSE.DOEXIT))
	    (SETQ EXITLIST (CAR DOEXIT))
	    (SETQ STATEMENT (CADR DOEXIT))
	    (PARSE.BIN (QUOTE ENDLOOP))
	    (BUILD.POP.SCOPE)
	    (SETQ ANSWER (BQUOTE ((\,@ FORCLAUSE)
				      (\,@ DOTEST)
				      do
				      (\,@ (BUILD.TAIL SCOPE)))))
	    (COND
	      (STATEMENT (SETQ ANSWER (BQUOTE ((\,@ ANSWER)
						   finally
						   (\,@ (BUILD.TAIL STATEMENT)))))))
	    (COND
	      (EXITLIST (SETQ ANSWER (BUILD.PROGN (CONS ANSWER EXITLIST)))))
	    (RETURN ANSWER))))

(PARSE.STATEMENT.RETURN
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (OPTARGS ANSWER)                                 (* (statement RETURN optargs) *)
	    (PARSE.BIN (QUOTE RETURN))
	    (SETQ OPTARGS (PARSE.OPTARGS))
	    (SETQ ANSWER (BUILD.RETURN OPTARGS))
	    (RETURN ANSWER))))

(PARSE.STATEMENT.TRANSFER
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (TRANSFER LHS ANSWER)                            (* (statement transfer lhs) *)
	    (SETQ TRANSFER (PARSE.TRANSFER))
	    (SETQ LHS (PARSE.LHS))
	    (SETQ ANSWER (BQUOTE (SHOULDNT (QUOTE (\, LHS)))))
	    (RETURN ANSWER))))

(PARSE.STATEMENT.LBRACKET
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (EXPLIST EXP ANSWER)                             (* (statement %[ explist %] ← exp) *)
	    (PARSE.BIN (QUOTE %[))
	    (SETQ EXPLIST (PARSE.EXPLIST))
	    (PARSE.BIN (QUOTE %]))
	    (PARSE.BIN (QUOTE ←))
	    (SETQ EXP (PARSE.EXP))
	    (SETQ ANSWER (BUILD.SETQ EXPLIST EXP))
	    (RETURN ANSWER))))

(PARSE.STATEMENT.IF
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (EXP STATEMENT ELSEPART HEAD TAIL ANSWER)        (* (statement IF exp THEN statement elsepart) *)
	    (PARSE.BIN (QUOTE IF))
	    (SETQ EXP (PARSE.EXP))
	    (PARSE.BIN (QUOTE THEN))
	    (SETQ STATEMENT (PARSE.STATEMENT))
	    (SETQ ELSEPART (PARSE.ELSEPART))
	    (SETQ ANSWER (BUILD.COND EXP STATEMENT ELSEPART))
	    (RETURN ANSWER))))

(PARSE.BLOCK
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (SCOPE EXITS ANSWER)                             (* (block BEGIN scope exits END) 
							     (block { scope exits }) *)
	    (BUILD.PUSH.SCOPE)
	    (PARSE.BIN (QUOTE (BEGIN {)))
	    (SETQ SCOPE (PARSE.SCOPE))
	    (SETQ EXITS (PARSE.EXITS))
	    (PARSE.BIN (QUOTE (END })))
	    (BUILD.POP.SCOPE)
	    (SETQ ANSWER (APPEND SCOPE EXITS))
	    (RETURN ANSWER))))

(PARSE.SCOPE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (STATEMENTLIST ANSWER)                           (* (scope open enables statementlist) 
							     (scope open enables declist ;
							     statementlist) *)
	    (BUILD.STORE.OPEN (PARSE.OPEN))
	    (PARSE.ENABLES)
	    (COND
	      ((AND (EQ PARSE.CLASS (QUOTE ID))
		      (FMEMB PARSE.ATOM2 (QUOTE (, :))))
		(PARSE.DECLIST)))
	    (SETQ STATEMENTLIST (PARSE.STATEMENTLIST))
	    (SETQ ANSWER (BUILD.PROG STATEMENTLIST))
	    (RETURN ANSWER))))

(PARSE.BINDITEM
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ID EXP ANSWER)                                  (* BOTH (binditem exp) (binditem id : exp) *)
                                                             (* CEDAR (binditem id ~ ~ exp) *)
	    (COND
	      ((AND (EQ PARSE.CLASS (QUOTE ID))
		      (EQ PARSE.ATOM2 (QUOTE :)))
		(SETQ ID (PARSE.BIN))
		(PARSE.BIN))
	      ((AND (EQ PARSE.LANGUAGE (QUOTE CEDAR))
		      (EQ PARSE.CLASS (QUOTE ID))
		      (EQ PARSE.ATOM2 (QUOTE ~)))
		(SETQ ID (PARSE.BIN))
		(PARSE.BIN)
		(PARSE.BIN (QUOTE ~))))
	    (SETQ EXP (PARSE.EXP))
	    (SETQ ANSWER (CREATE BINDITEM
				     ID ← ID
				     EXP ← EXP))
	    (RETURN ANSWER))))

(PARSE.EXITS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (exits EXITS exitlist) (exits) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE EXITS))
	(PARSE.BIN)
	(PARSE.EXITLIST)))))

(PARSE.CASESTMTITEM
  (LAMBDA (CASEHEAD)                                         (* kbr: "25-Nov-85 12:47")
    (PROG (CASELABEL STATEMENT ANSWER)                     (* (casestmtitem caselabel => statement) *)
	    (SETQ CASELABEL (PARSE.CASELABEL))
	    (PARSE.BIN (QUOTE =>))
	    (SETQ STATEMENT (PARSE.STATEMENT))
	    (SETQ ANSWER (CONS CASELABEL (BUILD.TAIL STATEMENT)))
	    (RETURN ANSWER))))

(PARSE.CASEEXPITEM
  (LAMBDA (CASEHEAD)                                         (* kbr: "25-Nov-85 12:47")
    (PROG (CASELABEL EXP ANSWER)                           (* (caseexpitem caselabel => exp) *)
	    (SETQ CASELABEL (PARSE.CASELABEL))
	    (PARSE.BIN (QUOTE =>))
	    (SETQ EXP (PARSE.EXP))
	    (SETQ ANSWER (CONS CASELABEL (BUILD.TAIL EXP)))
	    (RETURN ANSWER))))

(PARSE.EXITITEM
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (IDLIST STATEMENT ANSWER)                        (* (exititem idlist => statement) *)
	    (SETQ IDLIST (PARSE.IDLIST))
	    (PARSE.BIN (QUOTE =>))
	    (SETQ STATEMENT (PARSE.STATEMENT))
	    (SETQ ANSWER (BUILD.PROGN (NCONC IDLIST (BUILD.TAIL STATEMENT))))
	    (RETURN ANSWER))))

(PARSE.CASETEST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (OPTRELATION EXP ANSWER)                         (* (casetest optrelation) (casetest exp) *)
	    (COND
	      ((FMEMB PARSE.ATOM PARSE.OPTRELATION.FIRST)
		(SETQ OPTRELATION (PARSE.OPTRELATION))
		(SETQ ANSWER OPTRELATION))
	      (T (SETQ EXP (PARSE.EXP))
		 (SETQ ANSWER EXP)))
	    (RETURN ANSWER))))

(PARSE.CONTROLID
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ID TYPEEXP)                                     (* (controlid ident typeexp) 
							     (controlid id) *)
	    (COND
	      ((FMEMB PARSE.ATOM2 PARSE.CONTROLID.FOLLOW)
		(SETQ ID (PARSE.BIN (QUOTE ID)))
		(SETQ TYPEEXP (QUOTE INTEGER)))
	      (T (SETQ ID (PARSE.IDENT))
		 (SETQ TYPEEXP (PARSE.TYPEEXP))))
	    (BUILD.INITIALIZE.VAR ID TYPEEXP NIL BUILD.CURRENT.SCOPE)
	    (RETURN ID))))

(PARSE.FORCLAUSE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (CONTROLID EXP1 EXP2 DIRECTION RANGE ANSWER)     (* (forclause FOR controlid ← exp , exp) 
							     (forclause FOR controlid direction IN range) 
							     (forclause THROUGH range) (forclause) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE FOR))
		(PARSE.BIN)
		(SETQ CONTROLID (PARSE.CONTROLID))
		(COND
		  ((EQ PARSE.ATOM (QUOTE ←))
		    (PARSE.BIN)
		    (SETQ EXP1 (PARSE.EXP))
		    (PARSE.BIN (QUOTE ,))
		    (SETQ EXP2 (PARSE.EXP))
		    (SETQ ANSWER (BUILD.FORCLAUSE.BY CONTROLID EXP1 EXP2)))
		  (T (SETQ DIRECTION (PARSE.DIRECTION))
		     (PARSE.BIN (QUOTE IN))
		     (SETQ RANGE (PARSE.RANGE))
		     (SETQ ANSWER (BUILD.FORCLAUSE.IN CONTROLID DIRECTION RANGE)))))
	      ((EQ PARSE.ATOM (QUOTE THROUGH))
		(PARSE.BIN)
		(SETQ RANGE (PARSE.RANGE))
		(SETQ ANSWER (BUILD.FORCLAUSE.THROUGH RANGE))))
	    (RETURN ANSWER))))

(PARSE.DIRECTION
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (direction DECREASING) (direction) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE DECREASING))
	(PARSE.BIN)))))

(PARSE.DOTEST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (dotest UNTIL exp) (dotest WHILE exp) 
							     (dotest) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE UNTIL))
	(PARSE.BIN)
	(LIST (QUOTE until)
		(PARSE.EXP)))
      ((EQ PARSE.ATOM (QUOTE WHILE))
	(PARSE.BIN)
	(LIST (QUOTE while)
		(PARSE.EXP))))))

(PARSE.DOEXIT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (EXITLIST STATEMENT ANSWER)                      (* (doexit) (doexit REPEAT exitlist) 
							     (doexit REPEAT exitlist FINISHED => statement) 
							     (doexit REPEAT exitlist FINISHED => statement ;) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE REPEAT))
		(PARSE.BIN)
		(SETQ EXITLIST (PARSE.EXITLIST))
		(COND
		  ((EQ PARSE.ATOM (QUOTE FINISHED))
		    (PARSE.BIN)
		    (PARSE.BIN (QUOTE =>))
		    (SETQ STATEMENT (PARSE.STATEMENT))
		    (COND
		      ((EQ PARSE.ATOM (QUOTE ;))
			(PARSE.BIN)))))))
	    (SETQ ANSWER (LIST EXITLIST STATEMENT))
	    (RETURN ANSWER))))

(PARSE.ENABLES
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (CATCHCASE CATCHANY CATCHLIST ANSWER)

          (* (enables ENABLE catchcase ;) (enables ENABLE catchany ;) (enables ENABLE BEGIN catchlist END ;) 
	  (enables ENABLE { catchlist } ;) (enables) *)


	    (COND
	      ((EQ PARSE.ATOM (QUOTE ENABLE))
		(PARSE.BIN)
		(COND
		  ((EQ PARSE.ATOM (QUOTE ANY))
		    (SETQ CATCHANY (PARSE.CATCHANY))
		    (SETQ ANSWER (LIST CATCHANY)))
		  ((FMEMB PARSE.ATOM (QUOTE (BEGIN {)))
		    (PARSE.BIN)
		    (SETQ CATCHLIST (PARSE.CATCHLIST))
		    (PARSE.BIN (QUOTE (END })))
		    (SETQ ANSWER CATCHLIST))
		  (T (SETQ CATCHCASE (PARSE.CATCHCASE))
		     (SETQ ANSWER (LIST CATCHCASE))))
		(PARSE.BIN (QUOTE ;))))
	    (RETURN ANSWER))))

(PARSE.CATCHLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (CATCHHEAD CATCHANY CATCHCASE ANSWER)            (* (catchlist catchhead) (catchlist catchhead 
							     catchcase) (catchlist catchhead catchany) 
							     (catchlist catchhead catchany ;) *)
	    (SETQ CATCHHEAD (PARSE.CATCHHEAD))
	    (COND
	      ((FMEMB PARSE.ATOM PARSE.CATCHLIST.FOLLOW)
		(SETQ ANSWER CATCHHEAD))
	      ((EQ PARSE.ATOM (QUOTE ANY))
		(SETQ CATCHANY (PARSE.CATCHANY))
		(SETQ ANSWER (NCONC1 CATCHHEAD CATCHANY))
		(COND
		  ((EQ PARSE.ATOM (QUOTE ;))
		    (PARSE.BIN))))
	      (T (SETQ CATCHCASE (PARSE.CATCHCASE))
		 (SETQ ANSWER (NCONC1 CATCHHEAD CATCHCASE))))
	    (RETURN ANSWER))))

(PARSE.CATCHCASE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (LHSLIST STATEMENT ANSWER)                       (* (catchcase lhslist => statement) *)
	    (SETQ LHSLIST (PARSE.LHSLIST))
	    (PARSE.BIN (QUOTE =>))
	    (SETQ STATEMENT (PARSE.STATEMENT))
	    (SETQ ANSWER (LIST (QUOTE catchcase)
				   LHSLIST STATEMENT))
	    (RETURN ANSWER))))

(PARSE.OPTARGS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ANSWER)                                         (* (optargs %[ explist %]) 
							     (optargs) (optargs lhs) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE %[))
		(PARSE.BIN (QUOTE %[))
		(SETQ ANSWER (PARSE.EXPLIST))
		(PARSE.BIN (QUOTE %])))
	      ((NOT (FMEMB PARSE.ATOM PARSE.OPTARGS.FOLLOW))
		(SETQ ANSWER (LIST (PARSE.LHS)))))
	    (RETURN ANSWER))))

(PARSE.TRANSFER
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")

          (* (transfer SIGNAL) (transfer ERROR) (transfer RETURN WITH ERROR) (transfer START) (transfer RESTART) 
	  (transfer JOIN) (transfer NOTIFY) (transfer BROADCAST) (transfer TRANSFER WITH) (transfer RETURN WITH) *)


    (COND
      ((EQ PARSE.ATOM (QUOTE RETURN))
	(PARSE.BIN)
	(PARSE.BIN (QUOTE WITH))
	(COND
	  ((EQ PARSE.ATOM (QUOTE ERROR))
	    (QUOTE SHOULDNT))
	  (T (QUOTE RETURN))))
      ((EQ PARSE.ATOM (QUOTE TRANSFER))
	(PARSE.BIN)
	(PARSE.BIN (QUOTE WITH))
	(QUOTE RETURN))
      (T (PARSE.BIN)))))

(PARSE.KEYITEM
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ID OPTEXP ANSWER)                               (* BOTH (keyitem id : optexp) *)
                                                             (* CEDAR (keyitem id ~ optexp) *)
	    (SETQ ID (PARSE.BIN (QUOTE ID)))
	    (COND
	      ((EQ PARSE.ATOM (QUOTE :))
		(PARSE.BIN))
	      ((AND (EQ PARSE.LANGUAGE (QUOTE CEDAR))
		      (EQ PARSE.ATOM (QUOTE ~)))
		(PARSE.BIN))
	      (T (SHOULDNT)))
	    (SETQ OPTEXP (PARSE.OPTEXP))
	    (SETQ ANSWER (CREATE KEYITEM
				     ID ← ID
				     OPTEXP ← OPTEXP))
	    (RETURN ANSWER))))

(PARSE.OPTEXP
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (ANSWER)                                         (* (optexp TRASH) (optexp NULL) 
							     (optexp exp) (optexp) *)
	    (SETQ ANSWER (COND
		((FMEMB PARSE.ATOM (QUOTE (NULL TRASH)))
		  (PARSE.BIN)
		  (QUOTE TRASH))
		((FMEMB PARSE.ATOM PARSE.OPTEXP.FOLLOW)
		  (QUOTE TRASH))
		(T (PARSE.EXP))))
	    (RETURN ANSWER))))

(PARSE.EXP
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (COND
      ((EQ PARSE.CLASS (QUOTE ID))
	(PARSE.EXP1))
      (T (PARSE.EXP2)))))

(PARSE.EXP1
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* First token of EXP is ID.
							     *)
    (PROG (DISJUNCT EXP ANSWER)                            (* (exp lhs ← exp) (exp disjunct) *)
	    (SETQ DISJUNCT (PARSE.DISJUNCT))
	    (COND
	      ((EQ PARSE.ATOM (QUOTE ←))
		(PARSE.BIN)
		(SETQ EXP (PARSE.EXP))
		(SETQ ANSWER (BUILD.SETQ DISJUNCT EXP)))
	      (T (SETQ ANSWER DISJUNCT)))
	    (RETURN ANSWER))))

(PARSE.EXP2
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* First token of EXP is not ID.
							     *)
    (PROG (DISJUNCT ANSWER)

          (* (exp transferop lhs) (exp IF exp THEN exp ELSE exp) (exp casehead caseexplist ENDCASE => exp) 
	  (exp lhs ← exp) (exp %[ explist %] ← exp) (exp ERROR) (exp disjunct) *)


	    (SETQ ANSWER
	      (COND
		((AND (FMEMB PARSE.ATOM PARSE.TRANSFEROP.FIRST)
			(OR (NOT (EQ PARSE.ATOM (QUOTE NEW)))
			      (NOT (EQ PARSE.ATOM2 (QUOTE %[)))))
                                                             (* Don't confuse with (primary new %[ typeexp 
							     initialization optcatch %]) *)
		  (PARSE.EXP.TRANSFEROP))
		((EQ PARSE.ATOM (QUOTE IF))
		  (PARSE.EXP.IF))
		((FMEMB PARSE.ATOM PARSE.CASEHEAD.FIRST)
		  (PARSE.EXP.CASEHEAD))
		((EQ PARSE.ATOM)
		  (PARSE.EXP.LBRACKET (QUOTE %[)))
		((EQ PARSE.ATOM (QUOTE ERROR))
		  (PARSE.EXP.ERROR))
		((NUMBERP PARSE.ATOM)
		  (PARSE.EXP.DISJUNCT))
		((STRINGP PARSE.ATOM)
		  (PARSE.EXP.DISJUNCT))
		((FMEMB PARSE.ATOM
			  (QUOTE (ABS ALL BASE DESCRIPTOR FIRST ISTYPE LAST LENGTH LONG MAX MIN 
					  NILL NOT ORD PRED SIZE SUCC VAL + - @ %[)))
		  (PARSE.EXP.DISJUNCT))
		(T (PROGN (SETQ DISJUNCT (PARSE.EXP.DISJUNCT))
			    (COND
			      ((EQ PARSE.ATOM (QUOTE ←))
				(PARSE.BIN)
				(BUILD.SETQ DISJUNCT (PARSE.EXP)))
			      (T DISJUNCT))))))
	    (RETURN ANSWER))))

(PARSE.EXP.TRANSFEROP
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (TRANSFEROP LHS ANSWER)                          (* (exp transferop lhs) *)
	    (SETQ TRANSFEROP (PARSE.TRANSFEROP))
	    (SETQ LHS (PARSE.LHS))
	    (SETQ ANSWER (BQUOTE (SHOULDNT (QUOTE (\, LHS)))))
	    (RETURN ANSWER))))

(PARSE.EXP.IF
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (EXP1 EXP2 EXP3 ANSWER)                          (* (exp IF exp THEN exp ELSE exp) *)
	    (PARSE.BIN (QUOTE IF))
	    (SETQ EXP1 (PARSE.EXP))
	    (PARSE.BIN (QUOTE THEN))
	    (SETQ EXP2 (PARSE.EXP))
	    (PARSE.BIN (QUOTE ELSE))
	    (SETQ EXP3 (PARSE.EXP))
	    (SETQ ANSWER (BUILD.COND EXP1 EXP2 EXP3))
	    (RETURN ANSWER))))

(PARSE.EXP.CASEHEAD
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (CASEHEAD CASEEXPLIST EXP ANSWER)                (* (exp casehead caseexplist ENDCASE => exp) *)
	    (SETQ CASEHEAD (PARSE.CASEHEAD))
	    (SETQ CASEEXPLIST (PARSE.CASEEXPLIST))
	    (PARSE.BIN (QUOTE ENDCASE))
	    (PARSE.BIN (QUOTE =>))
	    (SETQ EXP (PARSE.EXP))
	    (SETQ ANSWER (BUILD.SELECTQ CASEHEAD CASEEXPLIST EXP))
	    (RETURN ANSWER))))

(PARSE.EXP.LHS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (LHS EXP ANSWER)                                 (* (exp lhs ← exp) *)
	    (SETQ LHS (PARSE.LHS))
	    (PARSE.BIN (QUOTE ←))
	    (SETQ EXP (PARSE.EXP))
	    (SETQ ANSWER (BQUOTE (SETQ (\, LHS)
				       (\, EXP))))
	    (RETURN ANSWER))))

(PARSE.EXP.LBRACKET
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (EXPLIST EXP ANSWER)                             (* (exp %[ explist %] ← exp) *)
	    (PARSE.BIN (QUOTE %[))
	    (SETQ EXPLIST (PARSE.EXPLIST))
	    (PARSE.BIN (QUOTE %]))
	    (PARSE.BIN (QUOTE ←))
	    (SETQ EXP (PARSE.EXP))
	    (SETQ ANSWER (BQUOTE (SETQ (\, EXPLIST)
				       (\, EXP))))
	    (RETURN ANSWER))))

(PARSE.EXP.ERROR
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (exp ERROR) *)
    (PARSE.BIN (QUOTE ERROR))
    (QUOTE (SHOULDNT))))

(PARSE.EXP.DISJUNCT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (exp disjunct) *)
    (PARSE.DISJUNCT)))

(PARSE.DISJUNCT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (CONJUNCTS ANSWER)                               (* (disjunct disjunct OR conjunct) 
							     (disjunct conjunct) *)
	    (PUSH CONJUNCTS (PARSE.CONJUNCT))
	    (WHILE (EQ PARSE.ATOM (QUOTE OR))
	       DO (PARSE.BIN)
		    (PUSH CONJUNCTS (PARSE.CONJUNCT)))
	    (SETQ ANSWER (COND
		((CDR CONJUNCTS)
		  (CONS (QUOTE OR)
			  (DREVERSE CONJUNCTS)))
		(T (CAR CONJUNCTS))))
	    (RETURN ANSWER))))

(PARSE.CONJUNCT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (NEGATIONS ANSWER)                               (* (conjunct conjunct AND negation) 
							     (conjunct negation) *)
	    (PUSH NEGATIONS (PARSE.NEGATION))
	    (WHILE (EQ PARSE.ATOM (QUOTE AND))
	       DO (PARSE.BIN)
		    (PUSH NEGATIONS (PARSE.NEGATION)))
	    (SETQ ANSWER (COND
		((CDR NEGATIONS)
		  (CONS (QUOTE AND)
			  (DREVERSE NEGATIONS)))
		(T (CAR NEGATIONS))))
	    (RETURN ANSWER))))

(PARSE.NEGATION
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (NOT ANSWER)                                   (* (negation not relation) 
							     (negation relation) *)
	    (COND
	      ((FMEMB PARSE.ATOM PARSE.NOTS)
		(SETQ NOT (PARSE.NOT))))
	    (SETQ ANSWER (PARSE.RELATION))
	    (COND
	      (NOT (SETQ ANSWER (BQUOTE (NOT (\, ANSWER))))))
	    (RETURN ANSWER))))

(PARSE.RELATION
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (SUM OPTRELATION NOT ANSWER)                   (* (relation sum optrelation) 
							     (relation sum) *)
	    (SETQ SUM (PARSE.SUM))
	    (COND
	      ((NOT (FMEMB PARSE.ATOM PARSE.OPTRELATION.FIRST))
		(RETURN SUM)))
	    (SETQ OPTRELATION (PARSE.OPTRELATION))
	    (COND
	      ((EQ (CAR OPTRELATION)
		     (QUOTE NOT))
		(SETQ NOT T)
		(SETQ OPTRELATION (CADR OPTRELATION))))
	    (SETQ ANSWER (COND
		((EQ (CAR OPTRELATION)
		       (QUOTE IN))
		  (BUILD.IN SUM (CADR OPTRELATION)))
		(T (BUILD.ARITH.EXP2 (CAR OPTRELATION)
				       SUM
				       (CADR OPTRELATION)))))
	    (COND
	      (NOT (SETQ ANSWER (LIST (QUOTE NOT)
					    ANSWER))))
	    (RETURN ANSWER))))

(PARSE.SUM
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (PRODUCTS PRODUCT ANSWER)                        (* (sum sum addop product) 
							     (sum product) *)
	    (SETQ PRODUCT (PARSE.PRODUCT))
	    (WHILE (FMEMB PARSE.ATOM PARSE.ADDOPS) DO (COND
							      ((EQ PARSE.ATOM (QUOTE +))
								(PARSE.BIN)
								(PUSH PRODUCTS PRODUCT)
								(SETQ PRODUCT (PARSE.PRODUCT)))
							      ((EQ PARSE.ATOM (QUOTE -))
								(PARSE.BIN)
								(SETQ PRODUCT (BUILD.ARITH.EXP2
								    (QUOTE -)
								    PRODUCT
								    (PARSE.PRODUCT))))
							      (T (SHOULDNT))))
	    (PUSH PRODUCTS PRODUCT)
	    (SETQ ANSWER (COND
		((CDR PRODUCTS)
		  (BUILD.ARITH.EXP* (QUOTE +)
				      (DREVERSE PRODUCTS)))
		(T (CAR PRODUCTS))))
	    (RETURN ANSWER))))

(PARSE.PRODUCT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (FACTORS FACTOR ANSWER)                          (* (product product multop factor) 
							     (product factor) *)
	    (SETQ FACTOR (PARSE.FACTOR))
	    (WHILE (FMEMB PARSE.ATOM PARSE.MULTOPS) DO (COND
							       ((EQ PARSE.ATOM (QUOTE *))
								 (PARSE.BIN)
								 (PUSH FACTORS FACTOR)
								 (SETQ FACTOR (PARSE.FACTOR)))
							       ((EQ PARSE.ATOM (QUOTE /))
								 (PARSE.BIN)
								 (SETQ FACTOR (BUILD.ARITH.EXP2
								     (QUOTE /)
								     FACTOR
								     (PARSE.FACTOR))))
							       ((EQ PARSE.ATOM (QUOTE MOD))
								 (PARSE.BIN)
								 (SETQ FACTOR (BUILD.ARITH.EXP2
								     (QUOTE MOD)
								     FACTOR
								     (PARSE.FACTOR))))
							       (T (SHOULDNT))))
	    (PUSH FACTORS FACTOR)
	    (SETQ ANSWER (COND
		((CDR FACTORS)
		  (BUILD.ARITH.EXP* (QUOTE *)
				      (DREVERSE FACTORS)))
		(T (CAR FACTORS))))
	    (RETURN ANSWER))))

(PARSE.OPTRELATION
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (NOT ANSWER)                                   (* (optrelation not relationtail) 
							     (optrelation relationtail) *)
                                                             (* In CEDAR, not must be NOT.
							     *)
	    (COND
	      ((OR (EQ PARSE.ATOM (QUOTE NOT))
		     (AND (EQ PARSE.LANGUAGE (QUOTE MESA))
			    (EQ PARSE.ATOM (QUOTE ~))))
		(SETQ NOT (PARSE.NOT))))
	    (SETQ ANSWER (PARSE.RELATIONTAIL))
	    (COND
	      (NOT (SETQ ANSWER (LIST (QUOTE NOT)
					    ANSWER))))
	    (RETURN ANSWER))))

(PARSE.RELATIONTAIL
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
    (PROG (RANGE RELOP SUM ANSWER)                         (* (relationtail IN range) 
							     (relationtail relop sum) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE IN))
		(PARSE.BIN)
		(SETQ RANGE (PARSE.RANGE))
		(SETQ ANSWER (LIST (QUOTE IN)
				       RANGE)))
	      (T (SETQ RELOP (PARSE.RELOP))
		 (SETQ SUM (PARSE.SUM))
		 (SETQ ANSWER (LIST RELOP SUM))))
	    (RETURN ANSWER))))

(PARSE.RELOP
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (relop =) (relop #) (relop <) 
							     (relop <=) (relop >) (relop >=) *)
    (PARSE.BIN)))

(PARSE.ADDOP
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:47")
                                                             (* (addop +) (addop -) *)
    (PARSE.BIN)))

(PARSE.MULTOP
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (multop *) (multop /) (multop MOD) *)
    (PARSE.BIN)))

(PARSE.FACTOR
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (ADDOP PRIMARY ANSWER)                           (* (factor addop primary) (factor primary) *)
	    (COND
	      ((FMEMB PARSE.ATOM PARSE.ADDOPS)
		(SETQ ADDOP (PARSE.BIN))))
	    (SETQ ANSWER (PARSE.PRIMARY))
	    (COND
	      ((EQ ADDOP (QUOTE -))
		(SETQ ANSWER (BUILD.ARITH.EXP1 (QUOTE -)
						   ANSWER))))
	    (RETURN ANSWER))))

(PARSE.PRIMARY
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (ANSWER LHS)

          (* BOTH (primary num) (primary lnum) (primary flnum) (primary string) (primary lstring) (primary atom) 
	  (primary NIL) (primary %[ explist %]) (primary prefixop %[ orderlist %]) (primary VAL %[ orderlist %]) 
	  (primary ALL %[ orderlist %]) (primary new %[ typeexp initialization optcatch %]) (primary typeop %[ typeexp %]) 
	  (primary SIZE %[ typeexp %]) (primary SIZE %[ typeexp , exp %]) (primary ISTYPE %[ exp , typeexp %]) 
	  (primary @ lhs) (primary DESCRIPTOR %[ desclist %]) (primary lhs) *)

                                                             (* CEDAR (primary cons %[ explist optcatch %]) 
							     (primary listcons %[ explist %]) *)
                                                             (* In CEDAR, new can be NEW.
							     *)
	    (SETQ ANSWER (COND
		((EQ PARSE.CLASS (QUOTE CHAR))
		  (BUILD.CHARCODE (PARSE.BIN)))
		((NUMBERP PARSE.ATOM)
		  (PARSE.BIN))
		((STRINGP PARSE.ATOM)
		  (PARSE.BIN))
		((FMEMB PARSE.ATOM PARSE.PREFIXOP.FIRST)
		  (PARSE.PRIMARY.PREFIXOP))
		((AND (OR (FMEMB PARSE.ATOM PARSE.TYPEOP.FIRST)
			      (AND (EQ PARSE.LANGUAGE (QUOTE CEDAR))
				     (EQ PARSE.ATOM (QUOTE CODE))))
			(EQ PARSE.ATOM2 (QUOTE %[)))
		  (PARSE.PRIMARY.TYPEOP))
		(T (SELECTQ PARSE.ATOM
			      ($ (PARSE.ATOM))
			      (NILL (PARSE.PRIMARY.NIL))
			      (%[ (PARSE.PRIMARY.LBRACKET))
			      (VAL (PARSE.PRIMARY.VAL))
			      (ALL (PARSE.PRIMARY.ALL))
			      (SIZE (PARSE.PRIMARY.SIZE))
			      (ISTYPE (PARSE.PRIMARY.ISTYPE))
			      (@ (PARSE.PRIMARY.AT))
			      (DESCRIPTOR (PARSE.PRIMARY.DESCRIPTOR))
			      (NEW (PARSE.PRIMARY.NEW))
			      (CONS (PARSE.PRIMARY.CONS))
			      (LIST (PARSE.PRIMARY.LIST))
			      (PARSE.PRIMARY.LHS)))))
	    (RETURN ANSWER))))

(PARSE.ATOM
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (atom $ id) *)
    (PARSE.BIN (QUOTE $))
    (BQUOTE (QUOTE (\, (PARSE.BIN (QUOTE ID)))))))

(PARSE.PRIMARY.NIL
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (primary NIL) *)
    (PARSE.BIN (QUOTE NILL))
    NIL))

(PARSE.PRIMARY.LBRACKET
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (ANSWER)                                         (* (primary %[ explist %]) *)
	    (PARSE.BIN (QUOTE %[))
	    (SETQ ANSWER (PARSE.EXPLIST))
	    (PARSE.BIN (QUOTE %]))
	    (RETURN ANSWER))))

(PARSE.PRIMARY.PREFIXOP
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (PREFIXOP ORDERLIST ANSWER)                      (* (primary prefixop %[ orderlist %]) *)
	    (SETQ PREFIXOP (PARSE.PREFIXOP))
	    (PARSE.BIN (QUOTE %[))
	    (SETQ ORDERLIST (PARSE.ORDERLIST))
	    (PARSE.BIN (QUOTE %]))
	    (SETQ ANSWER (CONS PREFIXOP (fetch (ORDERLIST ITEMS) of ORDERLIST)))
	    (RETURN ANSWER))))

(PARSE.PRIMARY.VAL
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (ORDERLIST ANSWER)                               (* (primary VAL %[ orderlist %]) *)
	    (PARSE.BIN (QUOTE VAL))
	    (PARSE.BIN (QUOTE %[))
	    (SETQ ORDERLIST (PARSE.ORDERLIST))
	    (PARSE.BIN (QUOTE %]))
	    (SETQ ANSWER (CONS (QUOTE VAL)
				   (fetch (ORDERLIST ITEMS) of ORDERLIST)))
	    (RETURN ANSWER))))

(PARSE.PRIMARY.ALL
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (ORDERLIST ANSWER)                               (* (primary ALL %[ orderlist %]) *)
	    (PARSE.BIN (QUOTE ALL))
	    (PARSE.BIN (QUOTE %[))
	    (SETQ ORDERLIST (PARSE.ORDERLIST))
	    (PARSE.BIN (QUOTE %]))
	    (SETQ ANSWER (CONS (QUOTE ALL)
				   (fetch (ORDERLIST ITEMS) of ORDERLIST)))
	    (RETURN ANSWER))))

(PARSE.PRIMARY.NEW
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (TYPEEXP INITIALIZATION ANSWER)                  (* (primary new %[ typeexp initialization optcatch %])
							     *)
	    (PARSE.NEW)
	    (PARSE.BIN (QUOTE %[))
	    (SETQ TYPEEXP (PARSE.TYPEEXP))
	    (SETQ INITIALIZATION (PARSE.INITIALIZATION))
	    (PARSE.OPTCATCH)
	    (PARSE.BIN (QUOTE %]))
	    (SETQ ANSWER (BUILD.NEW TYPEEXP INITIALIZATION))
	    (RETURN ANSWER))))

(PARSE.PRIMARY.TYPEOP
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (TYPEOP TYPEEXP ANSWER)                          (* (primary typeop %[ typeexp %]) *)
	    (SETQ TYPEOP (PARSE.TYPEOP))
	    (PARSE.BIN (QUOTE %[))
	    (SETQ TYPEEXP (PARSE.TYPEEXP))
	    (PARSE.BIN (QUOTE %]))
	    (SETQ ANSWER (LIST TYPEOP TYPEEXP))
	    (RETURN ANSWER))))

(PARSE.PRIMARY.SIZE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (TYPEEXP EXP ANSWER)                             (* (primary SIZE %[ typeexp %]) 
							     (primary SIZE %[ typeexp , exp %]) *)
	    (PARSE.BIN (QUOTE SIZE))
	    (PARSE.BIN (QUOTE %[))
	    (SETQ TYPEEXP (PARSE.TYPEEXP))
	    (COND
	      ((NOT (EQ PARSE.ATOM (QUOTE ,)))
		(PARSE.BIN (QUOTE %]))
		(SETQ ANSWER (LIST (QUOTE SIZE)
				       TYPEEXP)))
	      (T (PARSE.BIN)
		 (SETQ EXP (PARSE.EXP))
		 (PARSE.BIN (QUOTE %]))
		 (SETQ ANSWER (LIST (QUOTE SIZE)
					TYPEEXP EXP))))
	    (RETURN ANSWER))))

(PARSE.PRIMARY.ISTYPE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (primary ISTYPE %[ exp , typeexp %]) *)
    (PROG (EXP TYPEEXP ANSWER)
	    (PARSE.BIN (QUOTE ISTYPE))
	    (PARSE.BIN (QUOTE %[))
	    (SETQ EXP (PARSE.EXP))
	    (PARSE.BIN (QUOTE ,))
	    (SETQ TYPEEXP (PARSE.TYPEEXP))
	    (PARSE.BIN (QUOTE %]))
	    (SETQ ANSWER (BUILD.ISTYPE EXP TYPEEXP))
	    (RETURN ANSWER))))

(PARSE.PRIMARY.AT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (LHS ANSWER)                                     (* (primary @ lhs) *)
	    (PARSE.BIN (QUOTE @))
	    (SETQ LHS (PARSE.LHS))
	    (SETQ ANSWER LHS)
	    (RETURN ANSWER))))

(PARSE.PRIMARY.DESCRIPTOR
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (DESCLIST ANSWER)                                (* (primary DESCRIPTOR %[ desclist %]) *)
	    (PARSE.BIN (QUOTE DESCRIPTOR))
	    (PARSE.BIN (QUOTE %[))
	    (SETQ DESCLIST (PARSE.DESCLIST))
	    (PARSE.BIN (QUOTE %]))
	    (SETQ ANSWER (CONS (QUOTE DESCRIPTOR)
				   DESCLIST))
	    (RETURN ANSWER))))

(PARSE.PRIMARY.CONS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (EXPLIST ANSWER)                                 (* CEDAR (primary CONS %[ explist optcatch %]) *)
	    (PARSE.THISIS.CEDAR)
	    (PARSE.BIN (QUOTE CONS))
	    (PARSE.BIN (QUOTE %[))
	    (SETQ EXPLIST (PARSE.EXPLIST))
	    (PARSE.OPTCATCH)
	    (PARSE.BIN (QUOTE %]))
	    (SETQ ANSWER (CONS (QUOTE CONS)
				   (fetch (EXPLIST ITEMS) of EXPLIST)))
	    (RETURN ANSWER))))

(PARSE.PRIMARY.LIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (EXPLIST ANSWER)                                 (* CEDAR (primary LIST %[ explist %]) *)
	    (PARSE.THISIS.CEDAR)
	    (PARSE.BIN (QUOTE LIST))
	    (PARSE.BIN (QUOTE %[))
	    (SETQ EXPLIST (PARSE.EXPLIST))
	    (PARSE.BIN (QUOTE %]))
	    (SETQ ANSWER (CONS (QUOTE LIST)
				   (fetch (EXPLIST ITEMS) of EXPLIST)))
	    (RETURN ANSWER))))

(PARSE.PRIMARY.LHS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (LHS QUALIFIER ANSWER)                           (* BOTH (primary lhs) (primary new %[ typeexp 
							     initialization optcatch %]) *)
                                                             (* CEDAR (primary cons %[ explist optcatch %]) 
							     (primary listcons %[ explist %]) *)
	    (SETQ LHS (PARSE.LHS))
	    (COND
	      ((NOT (AND (EQ PARSE.ATOM (QUOTE %.))
			     (OR (EQ PARSE.ATOM2 (QUOTE NEW))
				   (AND (EQ PARSE.LANGUAGE (QUOTE CEDAR))
					  (FMEMB PARSE.ATOM2 (QUOTE (CONS LIST)))))))
		(RETURN LHS)))
	    (PARSE.BIN (QUOTE %.))
	    (SETQ ANSWER (SELECTQ PARSE.ATOM
				      (NEW (PARSE.PRIMARY.LHS.NEW LHS))
				      (CONS (PARSE.PRIMARY.LHS.CONS LHS))
				      (LIST (PARSE.PRIMARY.LHS.LIST LHS))
				      (SHOULDNT)))
	    (RETURN ANSWER))))

(PARSE.PRIMARY.LHS.NEW
  (LAMBDA (LHS)                                              (* kbr: "25-Nov-85 12:48")
    (PROG (TYPEEXP INITIALIZATION ANSWER)                  (* (primary new %[ typeexp initialization optcatch %])
							     *)
	    (PARSE.BIN (QUOTE NEW))
	    (PARSE.BIN (QUOTE %[))
	    (SETQ TYPEEXP (PARSE.TYPEEXP))
	    (SETQ INITIALIZATION (PARSE.INITIALIZATION))
	    (PARSE.OPTCATCH)
	    (PARSE.BIN (QUOTE %]))
	    (SETQ ANSWER (LIST (QUOTE create)
				   LHS TYPEEXP INITIALIZATION))
	    (RETURN ANSWER))))

(PARSE.PRIMARY.LHS.CONS
  (LAMBDA (LHS)                                              (* kbr: "25-Nov-85 12:48")
    (PROG (EXPLIST OPTCATCH ANSWER)                        (* CEDAR (primary cons %[ explist optcatch %]) *)
	    (PARSE.BIN (QUOTE CONS))
	    (PARSE.BIN (QUOTE %[))
	    (SETQ EXPLIST (PARSE.EXPLIST))
	    (PARSE.OPTCATCH)
	    (PARSE.BIN (QUOTE %]))
	    (SETQ ANSWER (BQUOTE (CONS (\, LHS)
					     (\,@ EXPLIST))))
	    (RETURN ANSWER))))

(PARSE.PRIMARY.LHS.LIST
  (LAMBDA (LHS)                                              (* kbr: "25-Nov-85 12:48")
    (PROG (EXPLIST OPTCATCH ANSWER)                        (* CEDAR (primary listcons %[ explist %]) *)
	    (PARSE.BIN (QUOTE LIST))
	    (PARSE.BIN (QUOTE %[))
	    (SETQ EXPLIST (PARSE.EXPLIST))
	    (PARSE.BIN (QUOTE %]))
	    (SETQ ANSWER (BQUOTE (LIST (\, LHS)
					     (\,@ EXPLIST))))
	    (RETURN ANSWER))))

(PARSE.QUALIFIER
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (ANSWER)

          (* (qualifier %. prefixop) (qualifier %. typeop) (qualifier %. SIZE) (qualifier %[ explist optcatch %]) 
	  (qualifier %. id) (qualifier ↑) *)


	    (COND
	      ((EQ PARSE.ATOM (QUOTE %.))
		(PARSE.BIN)
		(COND
		  ((FMEMB PARSE.ATOM PARSE.PREFIXOPS)
		    (SETQ ANSWER (PARSE.PREFIXOP)))
		  ((OR (FMEMB PARSE.ATOM PARSE.TYPEOPS)
			 (AND (EQ PARSE.LANGUAGE (QUOTE CEDAR))
				(EQ PARSE.ATOM (QUOTE CODE))))
		    (SETQ ANSWER (PARSE.TYPEOP)))
		  ((EQ PARSE.ATOM (QUOTE SIZE))
		    (SETQ ANSWER (PARSE.BIN)))
		  ((EQ PARSE.ATOM (QUOTE FREE))          (* (free lhs %. FREE) *)
		    (SETQ ANSWER (PARSE.BIN)))
		  ((EQ PARSE.ATOM (QUOTE NEW))           (* (new lhs %. NEW) *)
		    (SETQ ANSWER (PARSE.BIN)))
		  ((AND (EQ PARSE.LANGUAGE (QUOTE CEDAR))
			  (FMEMB PARSE.ATOM (QUOTE (LIST CONS))))
		    (SETQ ANSWER (PARSE.BIN)))
		  (T (SETQ ANSWER (PARSE.BIN (QUOTE ID))))))
	      ((EQ PARSE.ATOM (QUOTE %[))
		(PARSE.BIN)
		(SETQ ANSWER (PARSE.EXPLIST))
		(PARSE.OPTCATCH)
		(PARSE.BIN (QUOTE %])))
	      (T (SETQ ANSWER (PARSE.BIN (QUOTE ↑)))))
	    (RETURN ANSWER))))

(PARSE.LHS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (EXP1 EXP2 OPTTYPE ANSWER)

          (* (lhs id) (lhs char) (lhs NARROW %[ exp opttype optcatch %]) (lhs LOOPHOLE %[ exp opttype %]) 
	  (lhs APPLY %[ exp , exp optcatch %]) (lhs %( exp %)) (lhs lhs qualifier) *)


	    (COND
	      ((EQ PARSE.ATOM (QUOTE TRUE))
		(PARSE.BIN)
		(SETQ ANSWER T))
	      ((EQ PARSE.ATOM (QUOTE FALSE))
		(PARSE.BIN))
	      ((EQ PARSE.ATOM (QUOTE NARROW))
		(PARSE.BIN)
		(PARSE.BIN (QUOTE %[))
		(SETQ EXP1 (PARSE.EXP))
		(SETQ OPTTYPE (PARSE.OPTTYPE))
		(PARSE.OPTCATCH)
		(PARSE.BIN (QUOTE %]))
		(SETQ ANSWER (BUILD.COERCE EXP1 OPTTYPE)))
	      ((EQ PARSE.ATOM (QUOTE LOOPHOLE))
		(PARSE.BIN)
		(PARSE.BIN (QUOTE %[))
		(SETQ EXP1 (PARSE.EXP))
		(SETQ OPTTYPE (PARSE.OPTTYPE))
		(PARSE.BIN (QUOTE %]))
		(SETQ ANSWER (BUILD.COERCE EXP1 OPTTYPE)))
	      ((EQ PARSE.ATOM (QUOTE APPLY))
		(PARSE.BIN)
		(PARSE.BIN (QUOTE %[))
		(SETQ EXP1 (PARSE.EXP))
		(PARSE.BIN (QUOTE ,))
		(SETQ EXP2 (PARSE.EXP))
		(PARSE.OPTCATCH)
		(PARSE.BIN (QUOTE %]))
		(SETQ ANSWER (LIST (QUOTE APPLY)
				       EXP1 EXP2)))
	      ((EQ PARSE.ATOM (QUOTE %())
		(PARSE.BIN)
		(SETQ EXP1 (PARSE.EXP))
		(PARSE.BIN (QUOTE %)))
		(SETQ ANSWER EXP1))
	      ((EQ PARSE.CLASS (QUOTE ID))
		(SETQ ANSWER (PARSE.BIN)))
	      ((EQ PARSE.CLASS (QUOTE CHAR))
		(SETQ ANSWER (BUILD.CHARCODE (PARSE.BIN)))))
	    (WHILE (PARSE.QUALIFIER.HERE) DO (SETQ ANSWER (BUILD.QUALIFY ANSWER (
										  PARSE.QUALIFIER)))
		     )
	    (RETURN ANSWER))))

(PARSE.QUALIFIER.HERE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (AND (FMEMB PARSE.ATOM PARSE.QUALIFIER.FIRST)
	   (NOT (AND (EQ PARSE.ATOM (QUOTE %.))
			 (OR (FMEMB PARSE.ATOM2 (QUOTE (FREE NEW)))
			       (AND (EQ PARSE.LANGUAGE (QUOTE CEDAR))
				      (FMEMB PARSE.ATOM2 (QUOTE (CONS LIST))))))))))

(PARSE.OPTCATCH
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (CATCHLIST ANSWER)                               (* (optcatch ! catchlist) (optcatch) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE !))
		(PARSE.BIN)
		(SETQ ANSWER (PARSE.CATCHLIST))))
	    (RETURN ANSWER))))

(PARSE.TRANSFEROP
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (transferop SIGNAL) (transferop ERROR) 
							     (transferop START) (transferop JOIN) 
							     (transferop NEW) (transferop FORK) *)
    (PARSE.BIN)))

(PARSE.PREFIXOP
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")

          (* (prefixop LONG) (prefixop ABS) (prefixop PRED) (prefixop SUCC) (prefixop ORD) (prefixop MIN) 
	  (prefixop MAX) (prefixop BASE) (prefixop LENGTH) *)


    (PARSE.BIN)))

(PARSE.TYPEOP
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* BOTH (typeop FIRST) (typeop LAST) 
							     (typeop NIL) *)
                                                             (* CEDAR (typeop CODE) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE CODE))
	(PARSE.THISIS.CEDAR)))
    (PARSE.BIN)))

(PARSE.DESCLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (EXP1 EXP2 OPTTYPE ANSWER)                       (* (desclist exp , exp opttype) 
							     (desclist exp) *)
	    (SETQ EXP1 (PARSE.EXP))
	    (COND
	      ((EQ PARSE.ATOM (QUOTE ,))
		(PARSE.BIN)
		(SETQ EXP2 (PARSE.EXP))
		(SETQ OPTTYPE (PARSE.OPTTYPE))
		(SETQ ANSWER (LIST (QUOTE desclist)
				       EXP1 EXP2 OPTTYPE))
		(RETURN ANSWER))
	      (T (SETQ ANSWER (LIST (QUOTE desclist)
					EXP1))))
	    (RETURN ANSWER))))

(PARSE.DIRECTORY
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG NIL                                              (* (directory DIRECTORY ;) 
							     (directory DIRECTORY includelist ;) 
							     (directory) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE DIRECTORY))
		(PARSE.BIN)
		(COND
		  ((EQ PARSE.ATOM (QUOTE ;)))
		  (T (PARSE.INCLUDELIST)
		     (PARSE.BIN (QUOTE ;)))))))))

(PARSE.IMPORTS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG NIL                                              (* (imports IMPORTS) (imports IMPORTS modulelist) 
							     (imports) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE IMPORTS))
		(PARSE.BIN)
		(PARSE.MODULELIST))))))

(PARSE.POINTERPREFIX
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (ANSWER)                                         (* (pointerprefix POINTER) 
							     (pointerprefix POINTER interval) *)
	    (PARSE.BIN (QUOTE POINTER))
	    (COND
	      ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST)
		(SETQ ANSWER (LIST (QUOTE POINTER)
				       (PARSE.INTERVAL)))))
	    (RETURN ANSWER))))

(PARSE.EXPORTS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (MODULELIST ANSWER)                              (* (exports EXPORTS) (exports EXPORTS modulelist) 
							     (exports) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE EXPORTS))
		(PARSE.BIN)
		(BUILD.STORE.EXPORTS (PARSE.MODULELIST)))))))

(PARSE.FIELDLIST
  (LAMBDA (KIND)                                             (* kbr: "25-Nov-85 12:48")
    (PROG (ANSWER)                                         (* (fieldlist %[ %]) (fieldlist %[ pairlist %]) 
							     (fieldlist %[ typelist %]) *)
	    (PARSE.BIN (QUOTE %[))
	    (COND
	      ((NOT (EQ PARSE.ATOM (QUOTE %])))
		(COND
		  ((AND (EQ PARSE.CLASS (QUOTE ID))
			  (NOT (FMEMB PARSE.ATOM PARSE.PREDEFINED.TYPES))
			  (FMEMB PARSE.ATOM2 (QUOTE (%( , :))))
		    (SETQ ANSWER (PARSE.PAIRLIST (QUOTE FIELDLIST))))
		  (T (SETQ ANSWER (PARSE.TYPELIST))))))
	    (PARSE.BIN (QUOTE %]))
	    (RETURN ANSWER))))

(PARSE.USING
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (IDLIST)                                         (* (using USING %[ %]) (using USING %[ idlist %]) 
							     (using) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE USING))
		(PARSE.BIN)
		(PARSE.BIN (QUOTE %[))
		(COND
		  ((EQ PARSE.ATOM (QUOTE %]))
		    (PARSE.BIN))
		  (T (SETQ IDLIST (PARSE.IDLIST))
		     (PARSE.BIN (QUOTE %]))))))
	    (RETURN IDLIST))))

(PARSE.CATCHHEAD
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (CATCHCASES ANSWER)                              (* (catchhead) (catchhead catchhead catchcase ;) *)
	    (COND
	      ((FMEMB PARSE.ATOM PARSE.CATCHLIST.FOLLOW)
		(RETURN)))
	    (PUSH CATCHCASES (PARSE.CATCHCASE))
	    (WHILE (EQ PARSE.ATOM (QUOTE ;))
	       DO (PARSE.BIN)
		    (COND
		      ((FMEMB PARSE.ATOM PARSE.CATCHLIST.FOLLOW)
			(RETURN)))
		    (PUSH CATCHCASES (PARSE.CATCHCASE)))
	    (SETQ ANSWER (DREVERSE CATCHCASES))
	    (RETURN ANSWER))))

(PARSE.DECLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (VARLIST)                                        (* (declist declaration) (declist declist ;
							     declaration) *)
	    (SETQ VARLIST (PARSE.DECLARATION))
	    (DO (COND
		    ((EQ PARSE.ATOM (QUOTE ;))
		      (PARSE.BIN))
		    ((FMEMB PARSE.ATOM PARSE.DECLIST.FOLLOW)
		      (RETURN))
		    (T (SHOULDNT "PARSE.DECLIST")))
		  (COND
		    ((NOT (AND (EQ PARSE.CLASS (QUOTE ID))
				   (FMEMB PARSE.ATOM2 (QUOTE (, :)))))
		      (RETURN)))
		  (SETQ VARLIST (NCONC VARLIST (PARSE.DECLARATION))))
	    (BUILD.STORE.VARLIST VARLIST))))

(PARSE.PAIRLIST
  (LAMBDA (KIND)                                             (* kbr: "25-Nov-85 12:48")
    (PROG (PAIRITEMS ANSWER)                               (* (pairlist pairitem) (pairlist pairlist , pairitem) 
							     *)
                                                             (* PARSE.PAIRITEM returns a list of PAIRITEM records.
							     *)
	    (SETQ PAIRITEMS (PARSE.PAIRITEM KIND))
	    (COND
	      ((TYPE? TYPELIST PAIRITEMS)                  (* Thought we we're parsing a pairlist, but found a 
							     typelist. *)
		(RETURN PAIRITEMS)))
	    (WHILE (EQ PARSE.ATOM (QUOTE ,))
	       DO (PARSE.BIN)
		    (SETQ PAIRITEMS (NCONC PAIRITEMS (PARSE.PAIRITEM KIND))))
	    (SETQ ANSWER (CREATE PAIRLIST
				     ITEMS ← PAIRITEMS))
	    (RETURN ANSWER))))

(PARSE.VARIANTLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (VARIANTITEMS ANSWER)                            (* (variantlist variantitem) 
							     (variantlist variantlist , variantitem) *)
	    (PUSH VARIANTITEMS (PARSE.VARIANTITEM))
	    (WHILE (EQ PARSE.ATOM (QUOTE ,))
	       DO (PARSE.BIN)
		    (PUSH VARIANTITEMS (PARSE.VARIANTITEM)))
	    (SETQ ANSWER (CONS (QUOTE variantlist)
				   (DREVERSE VARIANTITEMS)))
	    (RETURN ANSWER))))

(PARSE.ORDERLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (OPTEXPS ANSWER)                                 (* (orderlist optexp) (orderlist orderlist , optexp) 
							     *)
	    (COND
	      ((FMEMB PARSE.ATOM PARSE.ORDERLIST.FOLLOW)
		(RETURN)))
	    (PUSH OPTEXPS (PARSE.OPTEXP))
	    (WHILE (EQ PARSE.ATOM (QUOTE ,))
	       DO (PARSE.BIN)
		    (PUSH OPTEXPS (PARSE.OPTEXP)))
	    (SETQ ANSWER (CREATE ORDERLIST
				     ITEMS ← (DREVERSE OPTEXPS)))
	    (RETURN ANSWER))))

(PARSE.LHSLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (LHSS ANSWER)                                    (* (lhslist lhs) (lhslist lhslist , lhs) *)
	    (PUSH LHSS (PARSE.LHS))
	    (WHILE (EQ PARSE.ATOM (QUOTE ,))
	       DO (PARSE.BIN)
		    (PUSH LHSS (PARSE.LHS)))
	    (SETQ ANSWER (DREVERSE LHSS))
	    (RETURN ANSWER))))

(PARSE.INCLUDELIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG NIL                                              (* (includelist includeitem) 
							     (includelist includelist , includeitem) *)
	    (PARSE.INCLUDEITEM)
	    (WHILE (EQ PARSE.ATOM (QUOTE ,))
	       DO (PARSE.BIN)
		    (PARSE.INCLUDEITEM)))))

(PARSE.MODULELIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (MODULEITEMS ANSWER)                             (* (modulelist moduleitem) 
							     (modulelist modulelist , moduleitem) *)
	    (COND
	      ((FMEMB PARSE.ATOM PARSE.MODULELIST.FOLLOW)
		(RETURN NIL)))
	    (PUSH MODULEITEMS (PARSE.MODULEITEM))
	    (WHILE (EQ PARSE.ATOM (QUOTE ,))
	       DO (PARSE.BIN)
		    (PUSH MODULEITEMS (PARSE.MODULEITEM)))
	    (SETQ ANSWER (DREVERSE MODULEITEMS))
	    (RETURN ANSWER))))

(PARSE.ELEMENTLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (ELEMENTS ANSWER)                                (* (elementlist element) (elementlist elementlist , 
							     element) *)
	    (PUSH ELEMENTS (PARSE.ELEMENT))
	    (WHILE (EQ PARSE.ATOM (QUOTE ,))
	       DO (PARSE.BIN)
		    (PUSH ELEMENTS (PARSE.ELEMENT)))
	    (SETQ ANSWER (DREVERSE ELEMENTS))
	    (RETURN ANSWER))))

(PARSE.BINDLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (BINDITEMS ANSWER)                               (* (bindlist binditem) (bindlist bindlist , binditem) 
							     *)
	    (PUSH BINDITEMS (PARSE.BINDITEM))
	    (WHILE (EQ PARSE.ATOM (QUOTE ,))
	       DO (PARSE.BIN)
		    (PUSH BINDITEMS (PARSE.BINDITEM)))
	    (SETQ ANSWER (DREVERSE BINDITEMS))
	    (RETURN ANSWER))))

(PARSE.STATEMENTLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (STATEMENTS ANSWER)                              (* (statementlist statement) 
							     (statementlist statementlist ;
							     statement) *)
	    (COND
	      ((FMEMB PARSE.ATOM PARSE.STATEMENTLIST.FOLLOW)
		(RETURN)))
	    (PUSH STATEMENTS (PARSE.STATEMENT))
	    (DO (COND
		    ((EQ PARSE.ATOM (QUOTE ;))
		      (PARSE.BIN)))
		  (COND
		    ((FMEMB PARSE.ATOM PARSE.STATEMENTLIST.FOLLOW)
		      (RETURN)))
		  (PUSH STATEMENTS (PARSE.STATEMENT)))
	    (SETQ ANSWER (DREVERSE STATEMENTS))
	    (RETURN ANSWER))))

(PARSE.CASESTMTLIST
  (LAMBDA (CASEHEAD)                                         (* kbr: "25-Nov-85 12:48")
    (PROG (CASESTMTITEMS ANSWER)                           (* (casestmtlist casestmtitem) 
							     (casestmtlist casestmtlist ;
							     casestmtitem) *)
	    (PUSH CASESTMTITEMS (PARSE.CASESTMTITEM CASEHEAD))
	    (DO (COND
		    ((EQ PARSE.ATOM (QUOTE ;))
		      (PARSE.BIN)))
		  (COND
		    ((EQ PARSE.ATOM (QUOTE ENDCASE))
		      (RETURN)))
		  (PUSH CASESTMTITEMS (PARSE.CASESTMTITEM CASEHEAD)))
	    (SETQ ANSWER (DREVERSE CASESTMTITEMS))
	    (RETURN ANSWER))))

(PARSE.CASELABEL
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (CASETESTS IDENT TYPEEXP ANSWER)                 (* (caselabel ident typeexp) 
							     (caselabel caselabel') (caselabel' casetest) 
							     (caselabel' caselabel' , casetest) *)
	    (COND
	      ((AND (EQ PARSE.CLASS (QUOTE ID))
		      (FMEMB PARSE.ATOM2 (QUOTE (: %())))
		(SETQ IDENT (PARSE.IDENT))
		(SETQ TYPEEXP (PARSE.TYPEEXP))
		(SETQ ANSWER (LIST (BUILD.ISTYPE IDENT TYPEEXP)))
		(BUILD.INITIALIZE.VAR IDENT TYPEEXP NIL BUILD.CURRENT.SCOPE)
		(RETURN ANSWER)))
	    (PUSH CASETESTS (PARSE.CASETEST))
	    (WHILE (EQ PARSE.ATOM (QUOTE ,))
	       DO (PARSE.BIN)
		    (PUSH CASETESTS (PARSE.CASETEST)))
	    (SETQ ANSWER (DREVERSE CASETESTS))
	    (RETURN ANSWER))))

(PARSE.EXITLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (EXITITEMS ANSWER)                               (* (exitlist exititem) (exitlist exitlist ;
							     exititem) *)
	    (COND
	      ((FMEMB PARSE.ATOM PARSE.EXITLIST.FOLLOW)
		(RETURN)))
	    (PUSH EXITITEMS (PARSE.EXITITEM))
	    (DO (COND
		    ((EQ PARSE.ATOM (QUOTE ;))
		      (PARSE.BIN)))
		  (COND
		    ((FMEMB PARSE.ATOM PARSE.EXITLIST.FOLLOW)
		      (RETURN)))
		  (PUSH EXITITEMS (PARSE.EXITITEM)))
	    (SETQ ANSWER (DREVERSE EXITITEMS))
	    (RETURN ANSWER))))

(PARSE.KEYLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (KEYITEMS ANSWER)                                (* (keylist keyitem) (keylist keylist , keyitem) *)
	    (PUSH KEYITEMS (PARSE.KEYITEM))
	    (WHILE (EQ PARSE.ATOM (QUOTE ,))
	       DO (PARSE.BIN)
		    (PUSH KEYITEMS (PARSE.KEYITEM)))
	    (SETQ ANSWER (CREATE KEYLIST
				     ITEMS ← (DREVERSE KEYITEMS)))
	    (RETURN ANSWER))))

(PARSE.CASEEXPLIST
  (LAMBDA (CASEHEAD)                                         (* kbr: "25-Nov-85 12:48")
    (PROG (CASEEXPITEMS ANSWER)                            (* (caseexplist caseexpitem) 
							     (caseexplist caseexplist , caseexpitem) *)
	    (PUSH CASEEXPITEMS (PARSE.CASEEXPITEM CASEHEAD))
	    (DO (COND
		    ((EQ PARSE.ATOM (QUOTE ,))
		      (PARSE.BIN)))
		  (COND
		    ((EQ PARSE.ATOM (QUOTE ENDCASE))
		      (RETURN)))
		  (PUSH CASEEXPITEMS (PARSE.CASEEXPITEM CASEHEAD)))
	    (SETQ ANSWER (DREVERSE CASEEXPITEMS))
	    (RETURN ANSWER))))

(PARSE.EXPLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (explist orderlist) (explist keylist) *)
    (PROG (ORDERLIST KEYLIST ANSWER)
	    (COND
	      ((AND (EQ PARSE.CLASS (QUOTE ID))
		      (EQ PARSE.ATOM2 (QUOTE :)))
		(SETQ ANSWER (PARSE.KEYLIST)))
	      (T (SETQ ANSWER (PARSE.ORDERLIST))))
	    (RETURN ANSWER))))

(PARSE.OPEN
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (BINDLIST)                                       (* (open OPEN bindlist ;) (open) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE OPEN))
		(PARSE.BIN)
		(SETQ BINDLIST (PARSE.BINDLIST))
		(PARSE.BIN (QUOTE ;))))
	    (RETURN BINDLIST))))

(PARSE.CLASS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (class PROGRAM) (class MONITOR) *)
    (PARSE.BIN (QUOTE (MONITOR PROGRAM)))))

(PARSE.CASEHEAD
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (ID EXP OPTEXP BINDITEM OPTEXP ANSWER)           (* (casehead SELECT exp FROM) 
							     (casehead WITH binditem SELECT optexp FROM) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE SELECT))
		(PARSE.BIN)
		(SETQ EXP (PARSE.EXP))
		(PARSE.BIN (QUOTE FROM)))
	      (T (PARSE.BIN (QUOTE WITH))
		 (SETQ BINDITEM (PARSE.BINDITEM))
		 (SETQ ID (fetch (BINDITEM ID) of BINDITEM))
		 (SETQ EXP (fetch (BINDITEM EXP) of BINDITEM))
		 (PARSE.BIN (QUOTE SELECT))
		 (SETQ OPTEXP (PARSE.OPTEXP))
		 (PARSE.BIN (QUOTE FROM))))
	    (SETQ ANSWER (CREATE CASEHEAD
				     ID ← ID
				     EXP ← EXP
				     OPTEXP ← OPTEXP))
	    (RETURN ANSWER))))

(PARSE.READONLY
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (readonly READONLY) (readonly) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE READONLY))
	(PARSE.BIN)))))

(PARSE.ORDERED
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (ordered ORDERED) (ordered) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE ORDERED))
	(PARSE.BIN)))))

(PARSE.BASE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (base BASE) (base) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE BASE))
	(PARSE.BIN)))))

(PARSE.PACKED
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (packed PACKED) (packed) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE PACKED))
	(PARSE.BIN)))))

(PARSE.HEAP
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* BOTH (heap UNCOUNTED) *)
                                                             (* CEDAR (heap) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE UNCOUNTED))
	(PARSE.BIN))
      (T (PARSE.THISIS.CEDAR)))))

(PARSE.INLINE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (inline INLINE) (inline) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE INLINE))
	(PARSE.BIN)))))

(PARSE.ARGUMENTS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG NIL                                              (* (arguments arglist returnlist) *)
	    (PARSE.ARGLIST)
	    (PARSE.RETURNLIST))))

(PARSE.INTERFACE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG NIL                                              (* (interface imports exports shares) *)
	    (PARSE.IMPORTS)
	    (PARSE.EXPORTS)
	    (PARSE.SHARES))))

(PARSE.SHARES
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (shares SHARES idlist) (shares) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE SHARES))
	(CONS (PARSE.BIN)
		(PARSE.IDLIST))))))

(PARSE.DEFAULT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (default ← defaultopt) (default) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE ←))
	(PARSE.BIN)
	(PARSE.DEFAULTOPT)))))

(PARSE.OPTSIZE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (EXP ANSWER)                                     (* (optsize %[ exp %]) (optsize) *)
	    (COND
	      ((EQ PARSE.ATOM (QUOTE %[))
		(PARSE.BIN)
		(SETQ EXP (PARSE.EXP))
		(PARSE.BIN (QUOTE %]))
		(SETQ ANSWER EXP)))
	    (RETURN ANSWER))))

(PARSE.BOUNDS
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (EXP1 EXP2 ANSWER)                               (* (bounds exp .. exp) *)
	    (SETQ EXP1 (PARSE.EXP))
	    (PARSE.BIN (QUOTE ..))
	    (SETQ EXP2 (PARSE.EXP))
	    (SETQ ANSWER (LIST EXP1 EXP2))
	    (RETURN ANSWER))))

(PARSE.LENGTH
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (EXP ANSWER)                                     (* (length %[ exp %]) *)
	    (PARSE.BIN (QUOTE %[))
	    (SETQ EXP (PARSE.EXP))
	    (PARSE.BIN (QUOTE %]))
	    (SETQ ANSWER EXP)
	    (RETURN ANSWER))))

(PARSE.INDEXTYPE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (indextype typeexp) (indextype) *)
    (COND
      ((NOT (EQ PARSE.ATOM (QUOTE OF)))
	(PARSE.TYPEEXP)))))

(PARSE.ELSEPART
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (elsepart ELSE statement) 
							     (elsepart) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE ELSE))
	(PARSE.BIN)
	(PARSE.STATEMENT)))))

(PARSE.OTHERPART
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (otherpart => statement) 
							     (otherpart) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE =>))
	(PARSE.BIN)
	(PARSE.STATEMENT)))))

(PARSE.FREE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (LHS ANSWER)                                     (* (free lhs %. FREE) *)
	    (SETQ LHS (PARSE.LHS))
	    (PARSE.BIN (QUOTE %.))
	    (PARSE.BIN (QUOTE FREE))
	    (SETQ ANSWER (LIST (QUOTE FREE)
				   LHS))
	    (RETURN ANSWER))))

(PARSE.CATCHANY
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG (STATEMENT ANSWER)                               (* (catchany ANY => statement) *)
	    (PARSE.BIN (QUOTE ANY))
	    (PARSE.BIN (QUOTE =>))
	    (SETQ STATEMENT (PARSE.STATEMENT))
	    (SETQ ANSWER (LIST (QUOTE ANY)
				   STATEMENT))
	    (RETURN ANSWER))))

(PARSE.NOT
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (not ~) (not NOT) *)
    (PARSE.BIN)))

(PARSE.NEW
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
    (PROG NIL                                              (* BOTH (new lhs %. NEW) *)
                                                             (* CEDAR (new NEW) *)
	    (COND
	      ((AND (EQ PARSE.ATOM (QUOTE NEW))
		      (EQ PARSE.LANGUAGE (QUOTE CEDAR)))
		(PARSE.BIN))
	      (T                                             (* Throw away lhs. Interlisp doesn't have separate 
							     storage "zone" (QUOTE s.) *)
		 (PARSE.LHS)
		 (PARSE.BIN (QUOTE %.))
		 (PARSE.BIN (QUOTE NEW)))))))

(PARSE.OPTTYPE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* (opttype , typeexp) (opttype) *)
    (COND
      ((EQ PARSE.ATOM (QUOTE ,))
	(PARSE.BIN)
	(PARSE.TYPEEXP))
      (T (QUOTE ANY)))))

(PARSE.ARGLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* BOTH (arglist fieldlist) 
							     (arglist) *)
                                                             (* CEDAR (arglist ANY) *)
    (PROG (ARGLIST)
	    (SETQ ARGLIST (COND
		((EQ PARSE.ATOM (QUOTE %[))
		  (COND
		    ((EQ PARSE.ATOM (QUOTE ANY))
		      (PARSE.THISIS.CEDAR)
		      (PARSE.BIN))
		    (T (PARSE.FIELDLIST (QUOTE ARGLIST)))))))
	    (BUILD.STORE.ARGLIST ARGLIST))))

(PARSE.RETURNLIST
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 12:48")
                                                             (* BOTH (returnlist RETURNS fieldlist) 
							     (returnlist) *)
                                                             (* CEDAR (returnlist RETURNS ANY) *)
    (PROG (RETURNLIST)
	    (SETQ RETURNLIST (COND
		((EQ PARSE.ATOM (QUOTE RETURNS))
		  (PARSE.BIN)
		  (COND
		    ((EQ PARSE.ATOM (QUOTE ANY))
		      (PARSE.THISIS.CEDAR)
		      (PARSE.BIN))
		    (T (PARSE.FIELDLIST (QUOTE RETURNLIST)))))))
	    (BUILD.STORE.RETURNLIST RETURNLIST))))
)



(* BUILD *)


(RPAQ? BUILD.NEXT.SCOPE NIL)

(RPAQ? BUILD.CURRENT.SCOPE NIL)

(RPAQ? BUILD.SCOPE.STACK NIL)

(RPAQ? BUILD.PREFIX NIL)

(RPAQ? BUILD.FILECOMS NIL)

(RPAQ? BUILD.BOOLEAN.FNS (QUOTE (AND OR NOT type? IGREATERP ILESSP IGEQ ILEQ IEQP ZEROP MINUSP 
				       EVENP ODDP FGREATERP FLESSP FEQP GREATERP LESSP GEQ LEQ)))

(RPAQ? BUILD.CARDINAL.FNS (QUOTE (ADD1 CHARCODE FIX GCD IDIFFERENCE IMAX IMIN IMINUS IMOD IPLUS 
					 IQUOTIENT IREMAINDER ITIMES LOGAND LOGNOT LOGOR LOGXOR 
					 NTHCHARCODE SUB1)))

(RPAQ? BUILD.MIXED.FNS (QUOTE (ABS DIFFERENCE EXPT MAX MIN MINUS MOD PLUS QUOTIENT REMAINDER TIMES))
)

(RPAQ? BUILD.REAL.FNS (QUOTE (ANTILOG ARCCOS ARCSIN ARCTAN ARCTAN2 COS FDIFFERENCE FLOAT FMAX FMIN 
					FMINUS FMOD FPLUS FQUOTIENT FREMAINDER FTIMES LOG SIN SQRT 
					TAN)))

(RPAQ? BUILD.QUALIFY.WORDS (QUOTE (FREE NEW SIZE)))

(RPAQ? BUILD.CARDINAL.ARITHOP.ALIST (LIST (CONS (QUOTE =)
						  (QUOTE IEQP))
					    (CONS (QUOTE #)
						  (QUOTE IEQP))
					    (CONS (QUOTE <)
						  (QUOTE ILESSP))
					    (CONS (QUOTE <=)
						  (QUOTE ILEQ))
					    (CONS (QUOTE >)
						  (QUOTE IGREATERP))
					    (CONS (QUOTE >=)
						  (QUOTE IGEQ))
					    (CONS (QUOTE +)
						  (QUOTE IPLUS))
					    (CONS (QUOTE -)
						  (QUOTE IDIFFERENCE))
					    (CONS (QUOTE *)
						  (QUOTE ITIMES))
					    (CONS (QUOTE /)
						  (QUOTE IQUOTIENT))
					    (CONS (QUOTE 0-)
						  (QUOTE IMINUS))
					    (CONS (QUOTE MAX)
						  (QUOTE IMAX))
					    (CONS (QUOTE MIN)
						  (QUOTE IMIN))
					    (CONS (QUOTE MOD)
						  (QUOTE IMOD))))

(RPAQ? BUILD.MIXED.ARITHOP.ALIST (LIST (CONS (QUOTE =)
					       (QUOTE EQP))
					 (CONS (QUOTE #)
					       (QUOTE EQP))
					 (CONS (QUOTE <)
					       (QUOTE LESSP))
					 (CONS (QUOTE <=)
					       (QUOTE GREATERP))
					 (CONS (QUOTE >)
					       (QUOTE GREATERP))
					 (CONS (QUOTE >=)
					       (QUOTE LESSP))
					 (CONS (QUOTE +)
					       (QUOTE PLUS))
					 (CONS (QUOTE -)
					       (QUOTE DIFFERENCE))
					 (CONS (QUOTE *)
					       (QUOTE TIMES))
					 (CONS (QUOTE /)
					       (QUOTE QUOTIENT))
					 (CONS (QUOTE 0-)
					       (QUOTE MINUS))
					 (CONS (QUOTE MAX)
					       (QUOTE MAX))
					 (CONS (QUOTE MIN)
					       (QUOTE MIN))
					 (CONS (QUOTE MOD)
					       (QUOTE IMOD))))

(RPAQ? BUILD.REAL.ARITHOP.ALIST (LIST (CONS (QUOTE =)
					      (QUOTE FEQP))
					(CONS (QUOTE #)
					      (QUOTE FEQP))
					(CONS (QUOTE <)
					      (QUOTE FLESSP))
					(CONS (QUOTE <=)
					      (QUOTE FGREATERP))
					(CONS (QUOTE >)
					      (QUOTE FGREATERP))
					(CONS (QUOTE >=)
					      (QUOTE FLESSP))
					(CONS (QUOTE +)
					      (QUOTE FPLUS))
					(CONS (QUOTE -)
					      (QUOTE FDIFFERENCE))
					(CONS (QUOTE *)
					      (QUOTE FTIMES))
					(CONS (QUOTE /)
					      (QUOTE FQUOTIENT))
					(CONS (QUOTE 0-)
					      (QUOTE FMINUS))
					(CONS (QUOTE MAX)
					      (QUOTE FMAX))
					(CONS (QUOTE MIN)
					      (QUOTE FMIN))
					(CONS (QUOTE MOD)
					      (QUOTE IMOD))))

(RPAQ? BUILD.CARDINAL.TYPES (QUOTE (CARDINAL CHAR CHARACTER INT INTEGER NAT WORD)))
[DECLARE: EVAL@COMPILE 

(RECORD SCOPE (ID SYMBOLTABLE INITLIST ARGLIST VARLIST RETURNLIST RETURNS OPEN)
		(ACCESSFNS ((RETURNVARS (FOR PAIRITEM IN (fetch (PAIRLIST ITEMS)
								  of (fetch (SCOPE RETURNLIST)
									  of DATUM))
					     collect (BUILD.LOCALVARID NIL (fetch (PAIRITEM
											  ID)
										  of PAIRITEM)))))))
]
(DEFINEQ

(BUILD.INIT
  (LAMBDA (PREFIX)                                           (* kbr: "25-Nov-85 17:27")
    (PROG NIL
	    (SETQ BUILD.PREFIX PREFIX)
	    (SETQ BUILD.FILECOMS (FILECOMS (U-CASE PREFIX)))
	    (SETTOPVAL BUILD.FILECOMS NIL)
	    (printout T "Creating " BUILD.FILECOMS T)
	    (SETQ BUILD.NEXT.SCOPE (create SCOPE
					       ID ← (QUOTE MODULE)))
	    (SETQ BUILD.CURRENT.SCOPE NIL)
	    (SETQ BUILD.SCOPE.STACK NIL))))

(BUILD.PUSH.SCOPE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 17:27")
    (PROG NIL
	    (COND
	      (BUILD.CURRENT.SCOPE (PUSH BUILD.SCOPE.STACK BUILD.CURRENT.SCOPE)))
	    (SETQ BUILD.CURRENT.SCOPE BUILD.NEXT.SCOPE)
	    (SETQ BUILD.NEXT.SCOPE (CREATE SCOPE))
	    (RETURN (CAR BUILD.SCOPE.STACK)))))

(BUILD.POP.SCOPE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 17:27")
    (PROG NIL
	    (SETQ BUILD.NEXT.SCOPE BUILD.CURRENT.SCOPE)
	    (SETQ BUILD.CURRENT.SCOPE (POP BUILD.SCOPE.STACK))
	    (RETURN BUILD.CURRENT.SCOPE))))

(BUILD.GC.SCOPE
  (LAMBDA NIL                                                (* kbr: "25-Nov-85 17:27")
    (PROG NIL
	    (SETQ BUILD.NEXT.SCOPE (CREATE SCOPE)))))

(BUILD.STORE.EXPORTS
  (LAMBDA (EXPORTS)                                          (* kbr: "25-Nov-85 17:27")
    (PROG NIL
	    (COND
	      (EXPORTS (SETQ BUILD.PREFIX (CAR EXPORTS)))))))

(BUILD.STORE.IDENTLIST
  (LAMBDA (IDENTLIST)                                        (* kbr: "25-Nov-85 17:27")
    (PROG NIL
	    (replace (SCOPE ID) of BUILD.NEXT.SCOPE with (CAR IDENTLIST)))))

(BUILD.STORE.INTERFACES
  (LAMBDA (INTERFACES)                                       (* kbr: "25-Nov-85 17:27")
    (PROG NIL
	    (FOR INTERFACE IN INTERFACES DO (BUILD.STORE.INTERFACE INTERFACE)))))

(BUILD.STORE.INTERFACE
  (LAMBDA (INTERFACE)                                        (* kbr: "25-Nov-85 17:27")
    (PROG NIL
	    (PUTPROP INTERFACE (QUOTE MESA.INTERFACE)
		       T))))

(BUILD.STORE.OPEN
  (LAMBDA (OPEN)                                             (* kbr: "25-Nov-85 17:27")
    (PROG NIL
	    (replace (SCOPE OPEN) of BUILD.NEXT.SCOPE with OPEN))))

(BUILD.STORE.USING
  (LAMBDA (INTERFACE USING)                                  (* kbr: "25-Nov-85 17:27")
    (PROG NIL
	    (FOR USE IN USING DO (PUTPROP USE (QUOTE MESA.USEDBY)
						  INTERFACE)))))

(BUILD.INITIALIZATION
  (LAMBDA (IDENTLIST TYPEEXP INITIALIZATION)                 (* kbr: "25-Nov-85 17:27")
    (PROG (ANSWER)
	    (SELECTQ (BUILD.TYPEATOM TYPEEXP)
		       (PROC (BUILD.INITIALIZE.FN (CAR IDENTLIST)
						    TYPEEXP INITIALIZATION))
		       (MRECORD (BUILD.INITIALIZE.RECORD (CAR IDENTLIST)
							   TYPEEXP INITIALIZATION))
		       (SETQ ANSWER (BUILD.INITIALIZE.VARS IDENTLIST TYPEEXP INITIALIZATION 
							       BUILD.CURRENT.SCOPE)))
	    (RETURN ANSWER))))

(BUILD.INITIALIZE.VARS
  (LAMBDA (IDENTLIST TYPEEXP INITIALIZATION SCOPE)           (* kbr: "25-Nov-85 17:27")
    (PROG (ANSWER)
	    (SETQ ANSWER (FOR ID IN IDENTLIST COLLECT (BUILD.INITIALIZE.VAR ID TYPEEXP 
										   INITIALIZATION 
										      SCOPE)))
	    (RETURN ANSWER))))

(BUILD.INITIALIZE.VAR
  (LAMBDA (ID TYPEEXP INITIALIZATION SCOPE)                  (* kbr: "25-Nov-85 17:27")
    (PROG (PAIRITEM)
	    (SETQ PAIRITEM (CREATE PAIRITEM
				       ID ← ID
				       TYPEEXP ← TYPEEXP
				       DEFAULT ← INITIALIZATION))
	    (replace (SCOPE SYMBOLTABLE) of SCOPE with (NCONC (fetch (SCOPE SYMBOLTABLE)
									 of SCOPE)
								      (LIST PAIRITEM)))
	    (COND
	      ((NULL BUILD.SCOPE.STACK)
		(BUILD.ADD.TO.FILECOMS (LIST ID (BUILD.COERCE INITIALIZATION TYPEEXP))
					 (QUOTE INITVARS))
		(PRIN1 ID T)
		(PRIN1 "," T)))
	    (RETURN ID))))

(BUILD.INITIALIZE.FN
  (LAMBDA (ID TYPEEXP INITIALIZATION)                        (* kbr: "25-Nov-85 17:27")
    (PROG (PROCID ARGLIST RETURNLIST LAMBDA)
	    (SETQ PROCID (BUILD.PROCID BUILD.PREFIX ID))
	    (SETQ ARGLIST (fetch (SCOPE ARGLIST) of BUILD.NEXT.SCOPE))
	    (SETQ RETURNLIST (fetch (SCOPE RETURNLIST) of BUILD.NEXT.SCOPE))
	    (PUTPROP ID (QUOTE MESA.USEDBY)
		       BUILD.PREFIX)
	    (PUTPROP PROCID (QUOTE MESA.FN)
		       T)
	    (PUTPROP PROCID (QUOTE MESA.ARGLIST)
		       ARGLIST)
	    (PUTPROP PROCID (QUOTE MESA.RETURNLIST)
		       RETURNLIST)
	    (SETQ LAMBDA (BUILD.LAMBDA ARGLIST INITIALIZATION))
	    (PUTD PROCID LAMBDA)
	    (BUILD.ADD.TO.FILECOMS PROCID (QUOTE FNS))
	    (BUILD.GC.SCOPE)
	    (PRIN1 ID T)
	    (PRIN1 "," T))))

(BUILD.INITIALIZE.RECORD
  (LAMBDA (ID TYPEEXP INITIALIZATION)                        (* kbr: "25-Nov-85 17:27")
    (PROG (RECORDID FIELDLIST RECORD)
	    (SETQ RECORDID (BUILD.RECORDID BUILD.PREFIX ID))
	    (replace (MRECORD RECORDID) of TYPEEXP with RECORDID)
	    (SETQ RECORD (BUILD.RECORD RECORDID TYPEEXP))
	    (EVAL RECORD)
	    (BUILD.ADD.TO.FILECOMS RECORDID (QUOTE RECORDS))
	    (PUTPROP ID (QUOTE MESA.USEDBY)
		       BUILD.PREFIX)
	    (PUTPROP RECORDID (QUOTE MESA.TYPE)
		       TYPEEXP)
	    (PRIN1 ID T)
	    (PRIN1 "," T))))

(BUILD.RECORD
  (LAMBDA (RECORDID TYPEEXP)                                 (* kbr: "25-Nov-85 17:27")
    (PROG (FIELDLIST FIELDS DEFAULTS ANSWER)
	    (SETQ FIELDLIST (fetch (MRECORD FIELDLIST) of TYPEEXP))
	    (COND
	      ((NULL FIELDLIST)                            (* I'm not really sure what an empty FIELDLIST is 
							     supposed to get you in MESA/CEDAR.
							     *)
		(RETURN (BQUOTE (TYPERECORD (\, RECORDID)))))
	      ((TYPE? PAIRLIST FIELDLIST)
		(FOR ITEM IN (REVERSE (fetch (PAIRLIST ITEMS) of FIELDLIST))
		   DO (PUSH FIELDS (fetch (PAIRITEM ID) of ITEM))
			(COND
			  ((fetch (PAIRITEM DEFAULT) of ITEM)
			    (SETQ DEFAULTS (NCONC DEFAULTS
						      (BQUOTE ((\, (fetch (PAIRITEM ID)
									of ITEM))←
								 (\, (BUILD.COERCE
								       (fetch (PAIRITEM DEFAULT)
									  of ITEM)
								       (fetch (PAIRITEM TYPEEXP)
									  of ITEM)))))))))))
	      ((TYPE? TYPELIST FIELDLIST)
		(FOR ITEM IN (REVERSE (fetch (TYPELIST ITEMS) of FIELDLIST)) AS I
		   FROM 1
		   DO (PUSH FIELDS (PACK* (QUOTE FIELD)
						I))
			(COND
			  ((fetch (TYPEITEM DEFAULT) of ITEM)
			    (SETQ DEFAULTS (NCONC DEFAULTS
						      (BQUOTE ((\, (PACK* (QUOTE FIELD)
									      I))←
								 (\, (BUILD.COERCE
								       (fetch (TYPEITEM DEFAULT)
									  of ITEM)
								       (fetch (TYPEITEM TYPEEXP)
									  of ITEM)))))))))))
	      (T (SHOULDNT)))
	    (SETQ ANSWER (BQUOTE (RECORD (\, RECORDID)
					       (\, FIELDS)
					       (\,@ DEFAULTS))))
	    (RETURN ANSWER))))

(BUILD.TYPE
  (LAMBDA (IDENTLIST TYPEEXP DEFAULT)                        (* kbr: "25-Nov-85 17:27")
    (PROG (ID TYPEID)
	    (SELECTQ (BUILD.TYPEATOM TYPEEXP)
		       (MRECORD (BUILD.INITIALIZE.RECORD (CAR IDENTLIST)
							   TYPEEXP DEFAULT))
		       (PROGN (SETQ TYPEID (BUILD.TYPEID BUILD.PREFIX (CAR IDENTLIST)))
				(COND
				  ((NOT (EQ TYPEID TYPEEXP))
				    (PUTPROP (CAR IDENTLIST)
					       (QUOTE MESA.USEDBY)
					       BUILD.PREFIX)
				    (PUTPROP TYPEID (QUOTE MESA.TYPE)
					       TYPEEXP))))))))

(BUILD.STORE.ARGLIST
  (LAMBDA (ARGLIST)                                        (* kbr: "25-Nov-85 17:27")
                                                             (* ARGLIST = args for coming function scope.
							     *)
    (PROG NIL
	    (replace (SCOPE ARGLIST) of BUILD.NEXT.SCOPE with ARGLIST)
	    (COND
	      ((TYPE? PAIRLIST ARGLIST)
		(BUILD.STORE.PAIRLIST ARGLIST))))))

(BUILD.STORE.RETURNLIST
  (LAMBDA (RETURNLIST)                                       (* kbr: "25-Nov-85 17:27")
                                                             (* RETURNLIST = args for coming function scope.
							     *)
    (PROG NIL
	    (replace (SCOPE RETURNLIST) of BUILD.NEXT.SCOPE with RETURNLIST)
	    (COND
	      ((TYPE? PAIRLIST RETURNLIST)
		(BUILD.STORE.PAIRLIST RETURNLIST))))))

(BUILD.STORE.PAIRLIST
  (LAMBDA (PAIRLIST)                                         (* kbr: "25-Nov-85 17:27")
                                                             (* PAIRLIST = args or return vals for coming function 
							     scope. *)
    (PROG NIL
	    (FOR PAIRITEM IN (fetch (PAIRLIST ITEMS) of PAIRLIST) COLLECT (
									     BUILD.STORE.PAIRITEM
										      PAIRITEM 
										 BUILD.NEXT.SCOPE)))))

(BUILD.STORE.PAIRITEM
  (LAMBDA (PAIRITEM SCOPE)                                   (* kbr: "25-Nov-85 17:27")
    (PROG NIL
	    (replace (SCOPE SYMBOLTABLE) of SCOPE with (NCONC (fetch (SCOPE SYMBOLTABLE)
									 of SCOPE)
								      (LIST PAIRITEM)))
	    (RETURN (fetch (PAIRITEM ID) of PAIRITEM)))))

(BUILD.STORE.VARLIST
  (LAMBDA (VARLIST)                                          (* kbr: "25-Nov-85 17:27")
    (PROG NIL
	    (replace (SCOPE VARLIST) of BUILD.CURRENT.SCOPE with VARLIST))))

(BUILD.ID
  (LAMBDA (INTERFACE ID)                                     (* kbr: "25-Nov-85 17:27")
    (PROG (ANSWER)
	    (COND
	      ((STRPOS "." ID)
		(RETURN ID)))
	    (SETQ INTERFACE (OR INTERFACE (GETPROP ID (QUOTE MESA.USEDBY))))
	    (SETQ ANSWER (COND
		(INTERFACE (PACK* INTERFACE "." ID))
		(T ID)))
	    (RETURN ANSWER))))

(BUILD.FIELDID
  (LAMBDA (INTERFACE ID)                                     (* kbr: "25-Nov-85 17:27")
    ID))

(BUILD.PROCID
  (LAMBDA (INTERFACE ID)                                     (* kbr: "25-Nov-85 17:27")
    (BUILD.ID INTERFACE ID)))

(BUILD.RECORDID
  (LAMBDA (INTERFACE ID)                                     (* kbr: "25-Nov-85 17:27")
    (BUILD.ID INTERFACE ID)))

(BUILD.TYPEID
  (LAMBDA (INTERFACE ID)                                     (* kbr: "25-Nov-85 17:27")
    (COND
      ((FMEMB ID PARSE.PREDEFINED.TYPES)
	ID)
      (T (BUILD.ID INTERFACE ID)))))

(BUILD.VARID
  (LAMBDA (INTERFACE ID)                                     (* kbr: "25-Nov-85 17:27")
    (PROG (ANSWER)
	    (SETQ ANSWER (COND
		((BUILD.LOOKUP ID)
		  (BUILD.LOCALVARID INTERFACE ID))
		(T (BUILD.GLOBALVARID INTERFACE ID))))
	    (RETURN ANSWER))))

(BUILD.LOCALVARID
  (LAMBDA (INTERFACE ID)                                     (* kbr: "25-Nov-85 17:27")
    ID))

(BUILD.GLOBALVARID
  (LAMBDA (INTERFACE ID)                                     (* kbr: "25-Nov-85 17:27")
    (BUILD.ID INTERFACE ID)))

(BUILD.ULTIMATE.TYPE
  (LAMBDA (EXP)                                              (* kbr: "25-Nov-85 17:27")
    (BUILD.REFINE.TYPE (BUILD.IMMEDIATE.TYPE EXP))))

(BUILD.REFINE.TYPE
  (LAMBDA (TYPE)                                             (* kbr: "25-Nov-85 17:27")
    (PROG (PAIRITEM NEXTTYPE)
	LOOP(SETQ NEXTTYPE (COND
		((OR (FMEMB TYPE (QUOTE (ANY MPROC INTERFACE)))
		       (FMEMB TYPE PARSE.PREDEFINED.TYPES))
		  (SELECTQ TYPE
			     (BOOL (QUOTE BOOLEAN))
			     (CHAR (QUOTE CHARACTER))
			     ((INT INTEGER NAT WORD)
			       (QUOTE CARDINAL))
			     (StringBody (QUOTE STRING))
			     (UNSPECIFIED (QUOTE ANY))
			     TYPE))
		((LITATOM TYPE)
		  (OR (BUILD.LOOKUP.TYPE TYPE)
			(PROGN (printout T T TYPE " type unknown." T)
				 (PUTPROP TYPE (QUOTE MESA.TYPE)
					    (QUOTE UNDECLARED))
				 TYPE)))
		((TYPE? MINTERVAL TYPE)
		  (fetch (MINTERVAL LBOUND) of TYPE))
		((TYPE? MPOINTER TYPE)
		  (fetch (MPOINTER TYPE) of TYPE))
		((TYPE? MREF TYPE)
		  (fetch (MREF TYPE) of TYPE))
		(T TYPE)))
	    (COND
	      ((EQ NEXTTYPE (QUOTE UNDECLARED))
		(RETURN TYPE))
	      ((NOT (EQ NEXTTYPE TYPE))
		(SETQ TYPE NEXTTYPE)
		(GO LOOP)))
	    (RETURN TYPE))))

(BUILD.IMMEDIATE.TYPE
  (LAMBDA (EXP)                                              (* kbr: "25-Nov-85 17:27")
    (PROG (TYPE FN RECORDNAME FIELDNAME MRECORD FIELDLIST PAIRITEM)
	    (SETQ TYPE (COND
		((OR (NULL EXP)
		       (EQ EXP T))
		  (QUOTE BOOLEAN))
		((LITATOM EXP)
		  (OR (BUILD.LOOKUP.TYPE EXP)
			(PROGN (printout T T EXP " type unknown." T)
				 (QUOTE ANY))))
		((FIXP EXP)
		  (QUOTE CARDINAL))
		((FLOATP EXP)
		  (QUOTE REAL))
		((STRINGP EXP)
		  (QUOTE STRING))
		((LISTP EXP)
		  (SETQ FN (CAR EXP))
		  (COND
		    ((EQ FN (QUOTE SETQ))
		      (BUILD.IMMEDIATE.TYPE (CADR EXP)))
		    ((EQ FN (QUOTE CAR))
		      (SETQ TYPE (BUILD.ULTIMATE.TYPE (CADR EXP)))
		      (COND
			((TYPE? MLIST TYPE)
			  (fetch (MLIST TYPE) of TYPE))
			(T (printout T T EXP " type unknown." T)
			   (QUOTE ANY))))
		    ((EQ FN (QUOTE CDR))
		      (SETQ TYPE (BUILD.ULTIMATE.TYPE (CADR EXP)))
		      (COND
			((TYPE? MLIST TYPE)
			  TYPE)
			(T (printout T T EXP " type unknown." T)
			   (QUOTE ANY))))
		    ((FMEMB FN (QUOTE (CONS LIST)))
		      (SETQ TYPE (BUILD.IMMEDIATE.TYPE (CADR EXP)))
		      (COND
			(TYPE (CREATE MLIST
					TYPE ← TYPE))
			(T (printout T T EXP " type unknown." T)
			   (QUOTE ANY))))
		    ((EQ FN (QUOTE COND))
		      (BUILD.IMMEDIATE.TYPE (CADR (CADR EXP))))
		    ((EQ FN (QUOTE ELT))
		      (SETQ TYPE (BUILD.ULTIMATE.TYPE (CADR EXP)))
		      (COND
			((TYPE? MARRAY TYPE)
			  (fetch (MARRAY TYPE) of TYPE))
			(T (printout T T EXP " type unknown." T)
			   (QUOTE ANY))))
		    ((EQ FN (QUOTE create))
		      (CADR EXP))
		    ((EQ FN (QUOTE fetch))
		      (SETQ RECORDNAME (CAR (CADR EXP)))
		      (SETQ FIELDNAME (CADR (CADR EXP)))
		      (SETQ MRECORD (GETPROP RECORDNAME (QUOTE MESA.TYPE)))
		      (COND
			((EQ MRECORD (QUOTE UNDECLARED))
			  (QUOTE ANY))
			(T (SETQ FIELDLIST (fetch (MRECORD FIELDLIST) of MRECORD))
			   (COND
			     ((TYPE? PAIRLIST FIELDLIST)
			       (SETQ PAIRITEM (ASSOC FIELDNAME (fetch (PAIRLIST ITEMS)
								      of FIELDLIST)))
			       (fetch (PAIRITEM TYPEEXP) of PAIRITEM))
			     (T (printout T T EXP " type unknown." T)
				(QUOTE ANY))))))
		    ((FMEMB FN BUILD.BOOLEAN.FNS)
		      (QUOTE BOOLEAN))
		    ((FMEMB FN BUILD.CARDINAL.FNS)
		      (QUOTE CARDINAL))
		    ((FMEMB FN BUILD.MIXED.FNS)
		      (QUOTE MIXED))
		    ((FMEMB FN BUILD.REAL.FNS)
		      (QUOTE REAL))
		    (T (printout T T EXP " type unknown." T)
		       (QUOTE ANY))))
		(T (printout T T EXP " type unknown." T)
		   (QUOTE ANY))))
	    (RETURN TYPE))))

(BUILD.LOOKUP.TYPE
  (LAMBDA (ID)                                               (* kbr: "25-Nov-85 17:27")
    (PROG (PAIRITEM TYPE)
	    (SETQ PAIRITEM (BUILD.LOOKUP ID))
	    (COND
	      (PAIRITEM (SETQ TYPE (fetch (PAIRITEM TYPEEXP) of PAIRITEM))
			(RETURN TYPE)))
	    (SETQ TYPE (COND
		((GETPROP ID (QUOTE MESA.TYPE)))
		((GETPROP ID (QUOTE MESA.USEDBY))
		  (BUILD.ID (GETPROP ID (QUOTE MESA.USEDBY))
			      ID))
		((GETPROP ID (QUOTE MESA.FN))
		  (RETURN (QUOTE MPROC)))
		((GETPROP ID (QUOTE MESA.INTERFACE))
		  (RETURN (QUOTE INTERFACE)))))
	    (RETURN TYPE))))

(BUILD.LOOKUP
  (LAMBDA (ID)                                               (* kbr: "25-Nov-85 17:27")
    (PROG (ANSWER)
	    (FOR SCOPE IN (CONS BUILD.CURRENT.SCOPE BUILD.SCOPE.STACK)
	       DO (SETQ ANSWER (ASSOC ID (fetch (SCOPE SYMBOLTABLE) of SCOPE)))
		    (COND
		      (ANSWER (RETURN))))
	    (RETURN ANSWER))))

(BUILD.TYPEATOM
  (LAMBDA (TYPEEXP)                                          (* kbr: "25-Nov-85 17:27")
    (COND
      ((LITATOM TYPEEXP)
	TYPEEXP)
      (T (CAR TYPEEXP)))))

(BUILD.QUALIFY
  (LAMBDA (LHS QUALIFIER)                                    (* kbr: "25-Nov-85 17:27")
    (PROG (TYPE TYPEATOM ANSWER)

          (* (qualifier %. prefixop) (qualifier %. typeop) (qualifier %. SIZE) (qualifier %[ explist optcatch %]) 
	  (qualifier %. id) (qualifier ↑) *)


	    (SETQ ANSWER (COND
		((FMEMB QUALIFIER PARSE.PREFIXOPS)
		  (BUILD.QUALIFY.PREFIXOP LHS QUALIFIER))
		((FMEMB QUALIFIER PARSE.TYPEOPS)
		  (BUILD.QUALIFY.TYPEOP LHS QUALIFIER))
		((EQ QUALIFIER (QUOTE SIZE))
		  (PACK* LHS "." QUALIFIER))
		((EQ QUALIFIER (QUOTE first))
		  (BQUOTE (CAR (\, LHS))))
		((EQ QUALIFIER (QUOTE rest))
		  (BQUOTE (CDR (\, LHS))))
		((OR (NULL QUALIFIER)
		       (LISTP QUALIFIER))
		  (BUILD.QUALIFY.EXPLIST LHS QUALIFIER))
		((EQ QUALIFIER (QUOTE ↑))
		  LHS)
		(T (BUILD.QUALIFY.ID LHS QUALIFIER))))
	    (RETURN ANSWER))))

(BUILD.QUALIFY.PREFIXOP
  (LAMBDA (LHS QUALIFIER)                                    (* kbr: "25-Nov-85 17:27")
    (SELECTQ QUALIFIER
	       ((MAX MIN)
		 (BUILD.ARITH.EXP* QUALIFIER LHS))
	       (CONS QUALIFIER LHS))))

(BUILD.QUALIFY.TYPEOP
  (LAMBDA (LHS QUALIFIER)                                    (* kbr: "25-Nov-85 17:27")
    (CONS QUALIFIER LHS)))

(BUILD.QUALIFY.EXPLIST
  (LAMBDA (LHS EXPLIST)                                      (* kbr: "25-Nov-85 17:27")
                                                             (* Qualify LHS with EXPLIST qualifier.
							     *)
    (PROG (TYPE TYPEATOM EXPITEMS ANSWER)
	    (COND
	      ((LITATOM LHS)
		(SETQ LHS (BUILD.ID NIL LHS))))
	    (SETQ TYPE (BUILD.ULTIMATE.TYPE LHS))
	    (SETQ TYPEATOM (BUILD.TYPEATOM TYPE))
	    (SETQ EXPITEMS (fetch (EXPLIST ITEMS) of EXPLIST))
	    (SETQ ANSWER (SELECTQ TYPEATOM
				      (MARRAY (BQUOTE (ELT (\, LHS)
							       (\,@ EXPITEMS))))
				      (MPROC (BUILD.CALL LHS EXPLIST))
				      (STRING (BQUOTE (NTHCHARCODE (\, LHS)
								       (\,@ EXPITEMS))))
				      (MRECORD               (* Presumably record contains SEQUENCE.
							     *)
					       (BQUOTE (ELT (\, LHS)
								(\,@ EXPITEMS))))
				      (COND
					((AND (LISTP LHS)
						(IEQP (LENGTH LHS)
							2))
                                                             (* "ARG1.FN[ARG2,...,ARGn]" *)
					  (APPEND LHS EXPITEMS))
					(T (printout T T LHS " qualified by " EXPLIST "?" T)
					   (COND
					     ((AND (TYPE? ORDERLIST EXPLIST)
						     (IEQP (LENGTH EXPITEMS)
							     1))
                                                             (* Guess array access. *)
					       (BQUOTE (ELT (\, LHS)
								(\,@ EXPITEMS))))
					     (T (CONS LHS EXPITEMS)))))))
	    (RETURN ANSWER))))

(BUILD.QUALIFY.ID
  (LAMBDA (LHS QUALIFIER)                                    (* kbr: "25-Nov-85 17:27")
                                                             (* Qualify LHS with id QUALIFIER.
							     *)
    (PROG (TYPE TYPEATOM ANSWER)
	    (SETQ TYPE (BUILD.ULTIMATE.TYPE LHS))
	    (SETQ TYPEATOM (BUILD.TYPEATOM TYPE))
	    (SETQ ANSWER (SELECTQ TYPEATOM
				      (MRECORD (BQUOTE (fetch ((\, (fetch (MRECORD RECORDID)
									  of TYPE))
								   (\, QUALIFIER))
							    of (\, LHS))))
				      (MARRAY (printout T T LHS " qualified by " QUALIFIER "?" T)
					      (BQUOTE (ELT (\, LHS)
							       (\, QUALIFIER))))
				      (INTERFACE (BUILD.ID LHS QUALIFIER))
				      (MPROC (COND
					       (QUALIFIER (LIST LHS QUALIFIER))
					       (T (LIST LHS))))
				      (STRING (printout T T LHS " qualified by " QUALIFIER "?" T)
					      (BQUOTE (NTHCHARCODE (\, LHS)
								       (\, QUALIFIER))))
				      (COND
					((EQ (GETPROP TYPE (QUOTE MESA.TYPE))
					       (QUOTE UNDECLARED))
                                                             (* Guess undeclared record.
							     *)
					  (BQUOTE (fetch ((\, TYPE)
							      (\, QUALIFIER))
						       of (\, LHS))))
					(T                   (* Guess undeclared fn. *)
					   (LIST QUALIFIER LHS)))))
	    (RETURN ANSWER))))

(BUILD.ARITH.EXP1
  (LAMBDA (ARITHOP EXP1)                                     (* kbr: "25-Nov-85 17:27")
    (COND
      ((EQ ARITHOP (QUOTE -))
	(SETQ ARITHOP (QUOTE 0-))))
    (BUILD.ARITH.EXP* ARITHOP (LIST EXP1))))

(BUILD.ARITH.EXP2
  (LAMBDA (ARITHOP EXP1 EXP2)                                (* kbr: "25-Nov-85 17:27")
    (PROG (ANSWER)
	    (SETQ ANSWER (BUILD.ARITH.EXP* ARITHOP (LIST EXP1 EXP2)))
	    (RETURN ANSWER))))

(BUILD.ARITH.EXP*
  (LAMBDA (ARITHOP EXPS)                                     (* kbr: "25-Nov-85 17:27")
    (PROG (TYPE NEWARITHOP ANSWER)
	    (SETQ TYPE (BUILD.STRONGEST.TYPE.AMONG EXPS))
	    (SETQ NEWARITHOP (BUILD.COERCE.ARITHOP ARITHOP TYPE))
	    (COND
	      ((EQ TYPE (QUOTE REAL))
		(SETQ EXPS (FOR EXP IN EXPS COLLECT (COND
							      ((FIXP EXP)
								(FLOAT EXP))
							      (T EXP))))))
	    (SETQ ANSWER (CONS NEWARITHOP EXPS))
	    (COND
	      ((FMEMB NEWARITHOP (QUOTE (IPLUS IDIFFERENCE)))
		(SETQ ANSWER (BUILD.ARITH.ADD1SUB1 ANSWER)))
	      ((AND (EQ ARITHOP (QUOTE 0-))
		      (NUMBERP (CADR ANSWER)))
		(SETQ ANSWER (APPLY* (CAR ANSWER)
					 (CADR ANSWER))))
	      ((OR (EQ ARITHOP (QUOTE #))
		     (AND (FMEMB ARITHOP (LIST (QUOTE <=)
						     (QUOTE >=)))
			    (NOT (EQ TYPE (QUOTE CARDINAL)))))
		(SETQ ANSWER (LIST (QUOTE NOT)
				       ANSWER))))
	    (RETURN ANSWER))))

(BUILD.ARITH.ADD1SUB1
  (LAMBDA (EXP)                                              (* kbr: "25-Nov-85 17:27")
                                                             (* Use ADD1 or SUB1 instead of IPLUS or IDIFFERENCE if
							     possible. *)
    (PROG (FN EXP1 EXP2 ANSWER)
	    (COND
	      ((NOT (IEQP (FLENGTH EXP)
			      3))
		(RETURN EXP)))
	    (SETQ FN (CAR EXP))
	    (SETQ EXP1 (CADR EXP))
	    (SETQ EXP2 (CADDR EXP))
	    (COND
	      ((EQ FN (QUOTE IPLUS))
		(COND
		  ((EQ EXP1 1)
		    (SETQ ANSWER (BUILD.ADD1 EXP2)))
		  ((EQ EXP2 1)
		    (SETQ ANSWER (BUILD.ADD1 EXP1)))
		  (T (SETQ ANSWER EXP))))
	      ((AND (EQ FN (QUOTE IDIFFERENCE))
		      (EQ EXP2 1))
		(SETQ ANSWER (BUILD.SUB1 EXP1)))
	      (T (SETQ ANSWER EXP)))
	    (RETURN ANSWER))))

(BUILD.COERCE.ARITHOP
  (LAMBDA (ARITHOP TYPE)                                     (* kbr: "25-Nov-85 17:27")
    (SELECTQ TYPE
	       (CARDINAL (CDR (ASSOC ARITHOP BUILD.CARDINAL.ARITHOP.ALIST)))
	       (MIXED (CDR (ASSOC ARITHOP BUILD.MIXED.ARITHOP.ALIST)))
	       (REAL (CDR (ASSOC ARITHOP BUILD.REAL.ARITHOP.ALIST)))
	       (SHOULDNT))))

(BUILD.STRONGEST.TYPE.AMONG
  (LAMBDA (EXPS)                                             (* kbr: "25-Nov-85 17:27")
    (PROG (TYPE)
	    (SETQ TYPE (QUOTE CARDINAL))
	    (FOR EXP IN EXPS WHILE (NOT (EQ TYPE (QUOTE REAL)))
	       DO (SETQ TYPE (BUILD.STRONGEST.TYPE TYPE (BUILD.ULTIMATE.TYPE EXP))))
	    (RETURN TYPE))))

(BUILD.STRONGEST.TYPE
  (LAMBDA (TYPE1 TYPE2)                                      (* kbr: "25-Nov-85 17:27")
    (COND
      ((FMEMB TYPE1 BUILD.CARDINAL.TYPES)
	(SETQ TYPE1 (QUOTE CARDINAL))))
    (COND
      ((FMEMB TYPE2 BUILD.CARDINAL.TYPES)
	(SETQ TYPE2 (QUOTE CARDINAL))))
    (SELECTQ TYPE1
	       (CARDINAL (SELECTQ TYPE2
				    (CARDINAL (QUOTE CARDINAL))
				    (REAL (QUOTE REAL))
				    (QUOTE MIXED)))
	       (MIXED (SELECTQ TYPE2
				 (REAL (QUOTE REAL))
				 (QUOTE MIXED)))
	       (REAL (QUOTE REAL))
	       (QUOTE MIXED))))

(BUILD.COERCE
  (LAMBDA (EXP TYPE)                                         (* kbr: "25-Nov-85 17:27")
    (PROG (TYPEEXP ANSWER)
	    (SETQ TYPEEXP (BUILD.REFINE.TYPE TYPE))
	    (SETQ ANSWER (COND
		((TYPE? MARRAY TYPEEXP)
		  (FRESHLINE T)
		  (printout T T "Coercion to " TYPE " array type." T)
		  (BUILD.COERCE.MARRAY EXP TYPEEXP))
		((TYPE? MLIST TYPEEXP)
		  (BUILD.COERCE.MLIST EXP TYPEEXP))
		((TYPE? EXPLIST EXP)
		  (BUILD.COERCE.EXPLIST EXP TYPEEXP))
		(T EXP)))
	    (RETURN ANSWER))))

(BUILD.COERCE.MARRAY
  (LAMBDA (EXP MARRAY)                                       (* kbr: "25-Nov-85 17:27")
    (PROG (TYPE ANSWER)                                    (* This is legal MESA/CEDAR code with no very elegant 
							     Interlisp translation. *)
	    (SETQ TYPE (fetch (MARRAY TYPE) of MARRAY))
	    (SETQ ANSWER (COND
		((TYPE? EXPLIST EXP)                       (* Should be an ORDERLIST. *)
		  (CONS (QUOTE LIST)
			  (FOR ITEM IN (fetch (EXPLIST ITEMS) of EXP)
			     COLLECT (BUILD.COERCE ITEM TYPE))))
		(T                                           (* EXP might be an MARRAY var.
							     *)
		   EXP)))
	    (RETURN ANSWER))))

(BUILD.COERCE.MLIST
  (LAMBDA (EXP MLIST)                                        (* kbr: "25-Nov-85 17:27")
    (PROG (TYPE ANSWER)
	    (SETQ TYPE (fetch (MLIST TYPE) of MLIST))
	    (SETQ ANSWER (COND
		((NOT (LISTP EXP))
		  EXP)
		((EQ (CAR EXP)
		       (QUOTE LIST))
		  (BQUOTE (LIST (\,@ (FOR ITEM IN (CDR EXP) COLLECT (BUILD.COERCE
										  ITEM TYPE))))))
		((EQ (CAR EXP)
		       (QUOTE CONS))
		  (BQUOTE (CONS (\, (BUILD.COERCE (CADR EXP)
							TYPE))
				    (\, (BUILD.COERCE (CADDR EXP)
							MLIST)))))
		(T EXP)))
	    (RETURN ANSWER))))

(BUILD.COERCE.EXPLIST
  (LAMBDA (EXPLIST MRECORD)                                  (* kbr: "25-Nov-85 17:27")
                                                             (* Converts a Mesa explist EXPLIST 
							     (ambiguous by itself) into a CREATE TYPE Lisp 
							     expression. *)
    (PROG (FIELDLIST ALIGNMENT SETTINGS ANSWER)
	    (COND
	      ((NOT (TYPE? EXPLIST EXPLIST))
		(RETURN EXPLIST)))
	    (COND
	      ((NOT (TYPE? MRECORD MRECORD))
		(printout T T MRECORD " not a record" T)     (* Proceed to do the best we can.
							     *)
		(COND
		  ((TYPE? KEYLIST EXPLIST)
		    (SETQ SETTINGS (FOR ITEM IN (fetch (KEYLIST ITEMS) of EXPLIST)
					JOIN (BQUOTE ((\, (fetch (KEYITEM ID) of ITEM))←
							  (\, (fetch (KEYITEM OPTEXP) of ITEM)))))
		      )
		    (RETURN (BQUOTE (create (\, MRECORD)
						  (\,@ SETTINGS))))))
		(RETURN (BQUOTE ((\, MRECORD)
				     (\,@ (fetch (EXPLIST ITEMS) of EXPLIST)))))))
	    (SETQ FIELDLIST (fetch (MRECORD FIELDLIST) of MRECORD))
	    (SETQ ALIGNMENT (BUILD.ALIGN FIELDLIST EXPLIST))
	    (SETQ SETTINGS (COND
		((TYPE? PAIRLIST FIELDLIST)
		  (FOR PAIRITEM IN (fetch (PAIRLIST ITEMS) of FIELDLIST) AS ALIGNVALUE
		     IN ALIGNMENT WHEN (NOT (FMEMB ALIGNVALUE (QUOTE (NIL TRASH))))
		     JOIN (BQUOTE ((\, (fetch (PAIRITEM ID) of PAIRITEM))← (\, ALIGNVALUE)))))
		((TYPE? TYPELIST FIELDLIST)
		  (FOR TYPEITEM IN (fetch (TYPELIST ITEMS) of FIELDLIST) AS ALIGNVALUE
		     IN ALIGNMENT AS I FROM 1 WHEN (NOT (FMEMB ALIGNVALUE
									   (QUOTE (NIL TRASH))))
		     JOIN (BQUOTE ((\, (PACK* (QUOTE FIELD)
						    I))← (\, ALIGNVALUE)))))
		(T (SHOULDNT))))
	EXIT(SETQ ANSWER (BQUOTE (create (\, (fetch (MRECORD RECORDID) of MRECORD))
					       (\,@ SETTINGS))))
	    (RETURN ANSWER))))

(BUILD.ALIGN
  (LAMBDA (FIELDLIST EXPLIST)                                (* kbr: "25-Nov-85 17:27")
    (PROG (ANSWER)
	    (SETQ ANSWER (COND
		((AND (NULL FIELDLIST)
			(NULL EXPLIST))
		  NIL)
		((EQ FIELDLIST (QUOTE ANY))
		  (fetch (EXPLIST ITEMS) of EXPLIST))
		((TYPE? ORDERLIST EXPLIST)
		  (COND
		    ((TYPE? PAIRLIST FIELDLIST)
		      (FOR PAIRITEM IN (fetch (PAIRLIST ITEMS) of FIELDLIST) AS OPTEXP
			 IN (fetch (ORDERLIST ITEMS) of EXPLIST)
			 COLLECT (BUILD.ALIGN.VALUE (fetch (PAIRITEM TYPEEXP) of PAIRITEM)
							(fetch (PAIRITEM DEFAULT) of PAIRITEM)
							OPTEXP)))
		    ((TYPE? TYPELIST FIELDLIST)
		      (FOR TYPEITEM IN (fetch (TYPELIST ITEMS) of FIELDLIST) AS OPTEXP
			 IN (fetch (ORDERLIST ITEMS) of EXPLIST)
			 COLLECT (BUILD.ALIGN.VALUE (fetch (TYPEITEM TYPEEXP) of TYPEITEM)
							(fetch (TYPEITEM DEFAULT) of TYPEITEM)
							OPTEXP)))
		    (T (SHOULDNT))))
		((TYPE? KEYLIST EXPLIST)
		  (COND
		    ((NOT (TYPE? PAIRLIST FIELDLIST))
		      (SHOULDNT)))
		  (FOR PAIRITEM IN (fetch (PAIRLIST ITEMS) of FIELDLIST)
		     COLLECT (BUILD.ALIGN.VALUE (fetch (PAIRITEM TYPEEXP) of PAIRITEM)
						    (fetch (PAIRITEM DEFAULT) of PAIRITEM)
						    (fetch (KEYITEM OPTEXP)
						       of (ASSOC (fetch (PAIRITEM ID)
									of PAIRITEM)
								     (fetch (KEYLIST ITEMS)
									of EXPLIST))))))
		(T (SHOULDNT))))
	    (RETURN ANSWER))))

(BUILD.ALIGN.VALUE
  (LAMBDA (TYPEEXP DEFAULT OPTEXP)                           (* kbr: "25-Nov-85 17:27")
    (PROG (ANSWER)
	    (SETQ ANSWER (OR (COND
				   ((AND (fetch (DEFAULT TRASH) of DEFAULT)
					   (EQ OPTEXP (QUOTE TRASH)))
				     (QUOTE TRASH)))
				 (BUILD.COERCE OPTEXP TYPEEXP)
				 (COPY (fetch (DEFAULT EXP) of DEFAULT))))
	    (RETURN ANSWER))))

(BUILD.ADD.TO.FILECOMS
  (LAMBDA (NAME TYPE)                                        (* kbr: "25-Nov-85 17:27")
    (PROG (FILECOMSVAR FILECOMS)
	    (SETQ FILECOMSVAR BUILD.FILECOMS)
	    (SETQ FILECOMS (GETTOPVAL FILECOMSVAR))      (* FILECOMS is reversed at this point.
							     *)
	    (COND
	      ((AND FILECOMS (EQ (CAR (CAR FILECOMS))
				     TYPE))
		(NCONC (CAR FILECOMS)
			 (LIST NAME)))
	      (T (PUSH FILECOMS (LIST TYPE NAME))))
	    (SETTOPVAL FILECOMSVAR FILECOMS))))

(BUILD.ADD1
  (LAMBDA (EXP)                                              (* kbr: "25-Nov-85 17:27")
    (COND
      ((FIXP EXP)
	(ADD1 EXP))
      (T (BQUOTE (ADD1 (\, EXP)))))))

(BUILD.CALL
  (LAMBDA (FN EXPLIST)                                       (* kbr: "25-Nov-85 17:27")
                                                             (* Function call. Cons FN onto front of coerced 
							     EXPLIST items. *)
    (CONS FN (BUILD.ALIGN (GETPROP FN (QUOTE MESA.ARGLIST))
			      EXPLIST))))

(BUILD.CHARCODE
  (LAMBDA (CHARCODE)                                       (* kbr: "25-Nov-85 17:27")
    (PROG (META CONTROL CHAR NAME ANSWER)
	    (SETQ NAME (SELECTQ CHARCODE
				    (0 (QUOTE NULL))
				    (7 (QUOTE BELL))
				    (8 (QUOTE BS))
				    (9 (QUOTE TAB))
				    (10 (QUOTE LF))
				    (12 (QUOTE FF))
				    (13 (QUOTE CR))
				    (27 (QUOTE ESC))
				    (32 (QUOTE SPACE))
				    (127 (QUOTE DEL))
				    (PROGN (COND
					       ((IGEQ CHARCODE 128)
						 (SETQ META T)
						 (SETQ CHARCODE (IDIFFERENCE CHARCODE 128))))
					     (COND
					       ((ILESSP CHARCODE 32)
						 (SETQ CONTROL T)
						 (SETQ CHARCODE (IPLUS CHARCODE 32))))
					     (SETQ CHAR (MKATOM (CHARACTER CHARCODE)))
					     (COND
					       ((AND META CONTROL)
						 (PACK* (QUOTE #↑)
							  CHAR))
					       (META (PACK* (QUOTE #)
							      CHAR))
					       (CONTROL (PACK* (QUOTE ↑)
								   CHAR))
					       (T CHAR)))))
	    (SETQ ANSWER (LIST (QUOTE CHARCODE)
				   NAME))
	    (RETURN ANSWER))))

(BUILD.COND
  (LAMBDA (EXP1 EXP2 EXP3)                                   (* kbr: "25-Nov-85 17:27")
    (PROG (HEAD TAIL ANSWER)
	    (SETQ HEAD (CONS EXP1 (BUILD.TAIL EXP2)))
	    (SETQ TAIL (COND
		((NULL EXP3)
		  NIL)
		((AND (LISTP EXP3)
			(EQ (CAR EXP3)
			      (QUOTE COND)))
		  (CDR EXP3))
		(T (BQUOTE ((T (\,@ (BUILD.TAIL EXP3))))))))
	    (SETQ ANSWER (BQUOTE (COND
				       (\, HEAD)
				       (\,@ TAIL))))
	    (RETURN ANSWER))))

(BUILD.COPY.OF
  (LAMBDA (EXP)                                              (* kbr: "25-Nov-85 17:27")
    (COND
      ((AND (LISTP EXP)
	      (EQ (CAR EXP)
		    (QUOTE SETQ)))
	(CADR EXP))
      (T (COPY EXP)))))

(BUILD.FETCH
  (LAMBDA (RECORDNAME FIELDNAME DATUM)                       (* kbr: "25-Nov-85 17:27")
    (PROG (MRECORD ANSWER)
	    (SETQ MRECORD (COND
		(RECORDNAME (BUILD.REFINE.TYPE RECORDNAME))
		(T (BUILD.ULTIMATE.TYPE DATUM))))
	    (SETQ ANSWER (COND
		((TYPE? MRECORD MRECORD)
		  (SETQ RECORDNAME (fetch (MRECORD RECORDID) of MRECORD))
		  (BQUOTE (fetch ((\, RECORDNAME)
				      (\, FIELDNAME))
			       of (\, DATUM))))
		(T (printout T T "Bad fetch " RECORDNAME " " FIELDNAME " " DATUM T)
		   (LIST FIELDNAME DATUM))))
	    (RETURN ANSWER))))

(BUILD.FORCLAUSE.BY
  (LAMBDA (CONTROLID EXP1 EXP2)                              (* kbr: "25-Nov-85 17:27")
    (BQUOTE (for (\, CONTROLID)← (\, EXP1) by (\, EXP2)))))

(BUILD.FORCLAUSE.IN
  (LAMBDA (CONTROLID DIRECTION RANGE)                        (* kbr: "25-Nov-85 17:27")
    (PROG (INTERVAL LBOUND UBOUND ANSWER)
	    (SETQ INTERVAL (fetch (MRANGE INTERVAL) of RANGE))
	    (SETQ LBOUND (fetch (MINTERVAL LBOUND) of INTERVAL))
	    (SETQ UBOUND (fetch (MINTERVAL UBOUND) of INTERVAL))
	    (SELECTQ (fetch (MINTERVAL KIND) of INTERVAL)
		       (CC)
		       (CO (SETQ UBOUND (BUILD.SUB1 UBOUND)))
		       (OC (SETQ LBOUND (BUILD.ADD1 LBOUND)))
		       (OO (SETQ LBOUND (BUILD.ADD1 LBOUND))
			   (SETQ UBOUND (BUILD.SUB1 UBOUND)))
		       (SHOULDNT))
	    (SETQ ANSWER (COND
		((EQ DIRECTION (QUOTE DECREASING))
		  (BQUOTE (for (\, CONTROLID) from (\, LBOUND) to (\, UBOUND) by -1)))
		(T (BQUOTE (for (\, CONTROLID) from (\, LBOUND) to (\, UBOUND))))))
	    (RETURN ANSWER))))

(BUILD.FORCLAUSE.THROUGH
  (LAMBDA (RANGE)                                            (* kbr: "25-Nov-85 17:27")
    (BUILD.FORCLAUSE.IN (QUOTE X)
			  NIL RANGE)))

(BUILD.IN
  (LAMBDA (EXP RANGE)                                        (* kbr: "25-Nov-85 17:28")
    (PROG (INTERVAL EXP2 LPRED UPRED ANSWER)
	    (SETQ RANGE (BUILD.REFINE.TYPE RANGE))
	    (COND
	      ((NOT (TYPE? MRANGE RANGE))
		(printout T T RANGE " not a range." T)
		(RETURN (BQUOTE (in (\, RANGE))))))
	    (SETQ INTERVAL (fetch (MRANGE INTERVAL) of RANGE))
	    (SELECTQ (fetch (MINTERVAL KIND) of INTERVAL)
		       (CC (SETQ LPRED (QUOTE IGEQ))
			   (SETQ UPRED (QUOTE ILEQ)))
		       (CO (SETQ LPRED (QUOTE IGEQ))
			   (SETQ UPRED (QUOTE ILESSP)))
		       (OC (SETQ LPRED (QUOTE IGREATERP))
			   (SETQ UPRED (QUOTE ILEQ)))
		       (OO (SETQ LPRED (QUOTE ILESSP))
			   (SETQ UPRED (QUOTE IGREATERP)))
		       (SHOULDNT))
	    (SETQ EXP2 (BUILD.COPY.OF EXP))
	    (SETQ ANSWER (BQUOTE (AND ((\, LPRED)
					     (\, EXP)
					     (\, (fetch (MINTERVAL LBOUND) of INTERVAL)))
					    ((\, UPRED)
					     (\, EXP2)
					     (\, (fetch (MINTERVAL UBOUND) of INTERVAL))))))
	    (RETURN ANSWER))))

(BUILD.ISTYPE
  (LAMBDA (EXP TYPE)                                         (* kbr: "25-Nov-85 17:28")
    (PROG (MRECORD RECORDID ANSWER)
	    (SETQ MRECORD (BUILD.REFINE.TYPE TYPE))
	    (SETQ RECORDID (COND
		((TYPE? MRECORD MRECORD)
		  (fetch (MRECORD RECORDID) of MRECORD))
		(T (printout T T "Bad istype " EXP " " TYPE T)
		   TYPE)))
	    (SETQ ANSWER (BQUOTE (type? (\, TYPE)
					      (\, EXP))))
	    (RETURN ANSWER))))

(BUILD.LAMBDA
  (LAMBDA (PAIRLIST BODY)                                    (* kbr: "25-Nov-85 17:28")
    (PROG (ARGLIST ANSWER)
	    (SETQ ARGLIST (FOR ITEM IN (fetch (PAIRLIST ITEMS) of PAIRLIST)
			       COLLECT (BUILD.LOCALVARID NIL (fetch (PAIRITEM ID) of ITEM))))
	    (SETQ ANSWER (BQUOTE (LAMBDA (\, ARGLIST)
				       (\,@ (BUILD.TAIL BODY)))))
	    (RETURN ANSWER))))

(BUILD.NEW
  (LAMBDA (TYPEEXP INITIALIZATION)                           (* kbr: "25-Nov-85 17:28")
    (BUILD.COERCE INITIALIZATION TYPEEXP)))

(BUILD.OR
  (LAMBDA (EXPS)                                             (* kbr: "25-Nov-85 17:28")
    (COND
      ((NULL EXPS)
	T)
      ((NULL (CDR EXPS))
	(CAR EXPS))
      (T (BQUOTE (OR (\,@ EXPS)))))))

(BUILD.PROG
  (LAMBDA (STATEMENTLIST)                                    (* kbr: "25-Nov-85 17:28")
    (PROG (VARS LAST ANSWER)
	    (SETQ ANSWER (APPEND (fetch (SCOPE INITLIST) of BUILD.CURRENT.SCOPE)
				     (BUILD.TAIL (BUILD.PROGN STATEMENTLIST))))
	    (SETQ VARS (APPEND (fetch (SCOPE VARLIST) of BUILD.CURRENT.SCOPE)
				   (fetch (SCOPE RETURNVARS) of BUILD.CURRENT.SCOPE)))
	    (COND
	      ((OR VARS (fetch (SCOPE RETURNS) of BUILD.CURRENT.SCOPE)
		     (FOR EXP IN ANSWER THEREIS (LITATOM EXP)))
                                                             (* Local vars, return, or go here.
							     *)
		(COND
		  (ANSWER (SETQ LAST (CAR (LAST ANSWER)))))
		(COND
		  ((NOT (OR (NULL (fetch (SCOPE RETURNVARS) of BUILD.CURRENT.SCOPE))
				(AND (LISTP LAST)
				       (FMEMB (CAR LAST)
						(QUOTE (GO RETURN))))))
		    (SETQ ANSWER (APPEND ANSWER (LIST (BUILD.RETURN))))))
		(SETQ ANSWER (BQUOTE (PROG (\, VARS)
					         (\,@ ANSWER)))))
	      (T (SETQ ANSWER (BUILD.PROGN ANSWER))))
	    (RETURN ANSWER))))

(BUILD.PROGN
  (LAMBDA (EXPS)                                             (* kbr: "25-Nov-85 17:28")
    (COND
      ((NULL EXPS)
	NIL)
      ((NULL (CDR EXPS))
	(CAR EXPS))
      (T (CONS (QUOTE PROGN)
		 (FOR EXP IN EXPS JOIN (BUILD.TAIL EXP)))))))

(BUILD.REPLACE
  (LAMBDA (RECORDNAME FIELDNAME DATUM VALUE)                 (* kbr: "25-Nov-85 17:28")
    (PROG (MRECORD ANSWER)
	    (SETQ MRECORD (COND
		(RECORDNAME (BUILD.REFINE.TYPE RECORDNAME))
		(T (BUILD.ULTIMATE.TYPE DATUM))))
	    (SETQ ANSWER (COND
		((TYPE? MRECORD MRECORD)
		  (SETQ RECORDNAME (fetch (MRECORD RECORDID) of MRECORD))
		  (BQUOTE (replace ((\, RECORDNAME)
					(\, FIELDNAME))
			       of (\, DATUM) with (\, VALUE))))
		(T (printout T T "Bad replace " RECORDNAME " " FIELDNAME " " DATUM " " VALUE T)
		   (LIST FIELDNAME DATUM))))
	    (RETURN ANSWER))))

(BUILD.RETURN
  (LAMBDA (OPTARGS)                                          (* kbr: "25-Nov-85 17:28")
                                                             (* COPY so DEDIT won't get confused by shared 
							     structure. *)
    (PROG (SCOPE FN PROCID FIELDLIST EXPLIST ALIGNMENT ANSWER)
                                                             (* Get scope of innermost PROC or DO.
							     *)
	    (SETQ SCOPE (FOR SCOPE IN (CONS BUILD.CURRENT.SCOPE BUILD.SCOPE.STACK)
			     THEREIS (fetch (SCOPE ID) of SCOPE)))
	    (replace (SCOPE RETURNS) of SCOPE with T)
	    (SETQ FN (fetch (SCOPE ID) of SCOPE))
	    (SETQ ALIGNMENT (COND
		((EQ FN (QUOTE DO))
		  OPTARGS)
		(OPTARGS (SETQ PROCID (BUILD.PROCID BUILD.PREFIX FN))
			 (SETQ FIELDLIST (OR (GETPROP PROCID (QUOTE MESA.RETURNLIST))
						 (PROGN (printout T T "No returnlist for " PROCID 
								    "."
								    T)
							  (QUOTE ANY))))
			 (BUILD.ALIGN FIELDLIST OPTARGS))
		(T (fetch (SCOPE RETURNVARS) of SCOPE))))
	    (SETQ ANSWER (COND
		((NULL ALIGNMENT)
		  (LIST (QUOTE RETURN)))
		((NULL (CDR ALIGNMENT))
		  (BQUOTE (RETURN (\,@ ALIGNMENT))))
		(T (BQUOTE (RETURN (LIST (\,@ ALIGNMENT)))))))
	    (RETURN ANSWER))))

(BUILD.SELECTQ
  (LAMBDA (CASEHEAD CLAUSES OTHERWISE)                       (* kbr: "25-Nov-85 17:28")
    (PROG (ID EXP OPTEXP TYPE FN CCLAUSES SCLAUSES ANSWER)
	    (SETQ ID (fetch (CASEHEAD ID) of CASEHEAD))
	    (SETQ EXP (fetch (CASEHEAD EXP) of CASEHEAD))
	    (SETQ OPTEXP (fetch (CASEHEAD OPTEXP) of CASEHEAD))
	    (SETQ EXP (OR OPTEXP ID EXP))
	    (COND
	      ((EQ EXP T)                                  (* Mesa SELECT TRUE FROM statement.
							     *)
		(SETQ ANSWER (BUILD.SELECTTRUEFROM CLAUSES OTHERWISE))
		(RETURN ANSWER)))
	    (SETQ TYPE (BUILD.ULTIMATE.TYPE EXP))
	    (SETQ FN (BUILD.SELECTQ.FN TYPE))
	    (FOR CLAUSE IN CLAUSES DO (COND
					      ((FOR CASETEST IN (CAR CLAUSE)
						  THEREIS (COND
							      ((AND (LISTP CASETEST)
								      (FMEMB (CAR CASETEST)
									       (QUOTE (IN type?)))))
							      ))
						(PUSH CCLAUSES CLAUSE))
					      (T (PUSH SCLAUSES CLAUSE))))
	    (SETQ CCLAUSES (DREVERSE CCLAUSES))
	    (SETQ SCLAUSES (DREVERSE SCLAUSES))
	    (SETQ CCLAUSES (FOR CCLAUSE IN CCLAUSES COLLECT (BUILD.SELECTQ.CCLAUSE EXP 
											  CCLAUSE 
											     TYPE)))
	    (SETQ SCLAUSES (FOR SCLAUSE IN SCLAUSES COLLECT (BUILD.SELECTQ.SCLAUSE SCLAUSE 
											     TYPE)))
	    (SETQ ANSWER (COND
		(SCLAUSES (BQUOTE ((\, FN)
				     (\, EXP)
				     (\,@ SCLAUSES)
				     (\, OTHERWISE))))
		(T OTHERWISE)))
	    (SETQ ANSWER (COND
		(CCLAUSES (COND
			    (ANSWER (BQUOTE (COND
						(\,@ CCLAUSES)
						(T (\,@ (BUILD.TAIL ANSWER))))))
			    (T (BQUOTE (COND
					   (\,@ CCLAUSES))))))
		(T ANSWER)))
	    (RETURN ANSWER))))

(BUILD.SELECTQ.FN
  (LAMBDA (TYPE)                                             (* kbr: "25-Nov-85 17:28")
    (COND
      ((EQ TYPE (QUOTE CHARACTER))
	(QUOTE SELCHARQ))
      (T (QUOTE SELECTQ)))))

(BUILD.SELECTQ.CCLAUSE
  (LAMBDA (EXP CCLAUSE TYPE)                                 (* kbr: "25-Nov-85 17:28")
    (PROG (EXP2 KEYS TESTS ANSWER)
	    (SETQ EXP2 (BUILD.COPY.OF EXP))
	    (SETQ KEYS (CAR CCLAUSE))
	    (SETQ TESTS (CONS (BUILD.SELECTQ.TEST EXP (CAR KEYS))
				  (FOR KEY IN (CDR KEYS) COLLECT (BUILD.SELECTQ.TEST EXP 
											      KEY))))
	    (COND
	      ((NULL (CDR TESTS))
		(SETQ TESTS (CAR TESTS)))
	      (T (SETQ TESTS (CONS (QUOTE OR)
				       TESTS))))
	    (SETQ ANSWER (CONS TESTS (CDR CCLAUSE)))
	    (RETURN ANSWER))))

(BUILD.SELECTQ.TEST
  (LAMBDA (EXP KEY)                                          (* kbr: "25-Nov-85 17:28")
    (COND
      ((AND (LISTP KEY)
	      (EQ (CAR KEY)
		    (QUOTE IN)))
	(BUILD.IN EXP (CADR KEY)))
      ((AND (LISTP KEY)
	      (EQ (CAR KEY)
		    (QUOTE type?)))
	KEY)
      (T (BQUOTE (FMEMB (\, EXP)
			    (QUOTE (\, KEY))))))))

(BUILD.SELECTQ.SCLAUSE
  (LAMBDA (SCLAUSE TYPE)                                     (* kbr: "25-Nov-85 17:28")
    (PROG (KEYS ANSWER)
	    (SETQ KEYS (CAR SCLAUSE))
	    (SETQ KEYS (FOR KEY IN KEYS COLLECT (BUILD.SELECTQ.KEY KEY TYPE)))
	    (COND
	      ((NULL (CDR KEYS))
		(SETQ KEYS (CAR KEYS))))
	    (SETQ ANSWER (CONS KEYS (CDR SCLAUSE)))
	    (RETURN ANSWER))))

(BUILD.SELECTQ.KEY
  (LAMBDA (KEY TYPE)                                         (* kbr: "25-Nov-85 17:28")
    (COND
      ((EQ TYPE (QUOTE CHARACTER))
	(COND
	  ((LISTP KEY)
	    (COND
	      ((EQ (CAR KEY)
		     (QUOTE CHARCODE))
		(CADR KEY))
	      ((EQ (CAR KEY)
		     (QUOTE IN))
		(LIST (QUOTE IN)
			(LIST (CAR (CADR KEY))
				(BUILD.SELECTQ.KEY (CADR (CADR KEY))
						     (QUOTE CHARACTER))
				(BUILD.SELECTQ.KEY (CADDR (CADR KEY))
						     (QUOTE CHARACTER)))))))
	  (T KEY)))
      (T KEY))))

(BUILD.SELECTTRUEFROM
  (LAMBDA (CLAUSES OTHERWISE)                                (* kbr: "25-Nov-85 17:28")
    (PROG (ANSWER)
	    (SETQ CLAUSES (FOR CLAUSE IN CLAUSES COLLECT (BUILD.SELECTTRUEFROM.CLAUSE
								   CLAUSE)))
	    (SETQ ANSWER (COND
		(CLAUSES (COND
			   (OTHERWISE (BQUOTE (COND
						  (\,@ CLAUSES)
						  (T (\,@ (BUILD.TAIL OTHERWISE))))))
			   (T (BQUOTE (COND
					  (\,@ CLAUSES))))))
		(T OTHERWISE)))
	    (RETURN ANSWER))))

(BUILD.SELECTTRUEFROM.CLAUSE
  (LAMBDA (CLAUSE)                                           (* kbr: "25-Nov-85 17:28")
    (CONS (BUILD.OR (CAR CLAUSE))
	    (CDR CLAUSE))))

(BUILD.SETQ
  (LAMBDA (LHS RHS)                                          (* kbr: "25-Nov-85 17:28")
    (PROG (TYPE ANSWER)
	    (COND
	      ((TYPE? ORDERLIST LHS)
		(SETQ ANSWER (BUILD.SETQ.ORDERLIST LHS RHS))
		(RETURN ANSWER)))
	    (SETQ TYPE (BUILD.ULTIMATE.TYPE LHS))
	    (SETQ RHS (BUILD.COERCE RHS TYPE))
	    (SETQ ANSWER (COND
		((NULL LHS)
		  RHS)
		((TYPE? MARRAY TYPE)
		  (BUILD.SETQ.ARRAY LHS RHS))
		((LISTP LHS)
		  (SELECTQ (CAR LHS)
			     (ELT (BQUOTE (SETA (\, (CADR LHS))
						      (\, (CADDR LHS))
						      (\, RHS))))
			     (fetch (BQUOTE (replace (\,@ (CDR LHS)) with (\, RHS))))
			     (NTHCHARCODE (BQUOTE (RPLCHARCODE (\, (CADR LHS))
								     (\, (CADDR LHS))
								     (\, RHS))))
			     (PROGN (printout T "Bad setq " LHS " " RHS)
				      (COND
					((IEQP (LENGTH LHS)
						 2)
					  (COND
					    ((FIXP (CADR LHS))
                                                             (* Guess array access. *)
					      (BQUOTE (SETA (\, (CAR LHS))
								(\, (CADR LHS))
								(\, RHS))))
					    (T               (* Guess record access. *)
					       (BUILD.REPLACE NIL (CAR LHS)
								(CADR LHS)
								RHS))))
					(T                   (* Guess it could be anything.
							     *)
					   (BQUOTE (SETQ (\, LHS)
						       (\, RHS))))))))
		(T (BQUOTE (SETQ (\, LHS)
			       (\, RHS))))))
	    (RETURN ANSWER))))

(BUILD.SETQ.ARRAY
  (LAMBDA (LHS RHS)                                          (* kbr: "25-Nov-85 17:28")
                                                             (* SETQ array LHS. I.e., FILLARRAY.
							     *)
    (PROG (EXPS ANSWER)
	    (COND
	      ((NOT (TYPE? ORDERLIST RHS))
		(printout T T "Bad setq array " LHS " " RHS T)
		(SETQ ANSWER (BQUOTE (SETQ (\, LHS)
					   (\, RHS))))
		(RETURN ANSWER)))
	    (SETQ EXPS (FOR ORDERITEM IN (fetch (ORDERLIST ITEMS) of RHS) AS I
			    FROM 0 COLLECT (BUILD.SETQ (BQUOTE (ELT (\, LHS)
									      (\, I)))
							     ORDERITEM)))
	    (SETQ ANSWER (BUILD.PROGN EXPS))
	    (RETURN ANSWER))))

(BUILD.SETQ.ORDERLIST
  (LAMBDA (ORDERLIST RHS)                                    (* kbr: "25-Nov-85 17:28")
                                                             (* SETQ orderlist ORDERLIST.
							     *)
    (PROG (ORDERITEMS TEMP TEMPPOS EXPS ANSWER)            (* Get ORDERITEMS *)
	    (SETQ ORDERITEMS (fetch (ORDERLIST ITEMS) of ORDERLIST))
	    (COND
	      ((NULL ORDERITEMS)
		(RETURN RHS))
	      ((NULL (CDR ORDERITEMS))
		(SETQ ANSWER (BUILD.SETQ (CAR ORDERITEMS)
					     (BQUOTE (CAR (\, RHS)))))
		(RETURN ANSWER)))                          (* Get TEMPorary variable. *)
	    (SETQ TEMP (CAR RHS))
	    (SETQ TEMPPOS (STRPOS "." TEMP))
	    (COND
	      (TEMPPOS (SETQ TEMP (SUBATOM TEMP (ADD1 TEMPPOS)
					       -1))))        (* Get EXPS. *)
	    (SETQ EXPS (COND
		((ILEQ (LENGTH ORDERITEMS)
			 3)
		  (FOR ID IN ORDERITEMS WHEN ID AS ACCESS IN (QUOTE (CAR CADR CADDR))
		     COLLECT (BUILD.SETQ ID (BQUOTE ((\, ACCESS)
							   (\, TEMP))))))
		(T (FOR ID IN ORDERITEMS WHEN ID COLLECT (BUILD.SETQ
								   ID
								   (BQUOTE (POP (\, TEMP))))))))
	    (PUSH EXPS (BQUOTE (SETQ (\, TEMP)
				     (\, RHS))))             (* Build PROGN ANSWER. *)
	    (SETQ ANSWER (BUILD.PROGN EXPS))
	    (RETURN ANSWER))))

(BUILD.SUB1
  (LAMBDA (EXP)                                              (* kbr: "25-Nov-85 17:28")
    (COND
      ((FIXP EXP)
	(SUB1 EXP))
      (T (BQUOTE (SUB1 (\, EXP)))))))

(BUILD.TAIL
  (LAMBDA (EXP)                                              (* kbr: "25-Nov-85 17:28")
    (COND
      ((NULL EXP)
	NIL)
      ((AND (LISTP EXP)
	      (EQ (CAR EXP)
		    (QUOTE PROGN)))
	(CDR EXP))
      (T (LIST EXP)))))
)
(BUILD.INIT)
(PUTPROPS MESATOLISP COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (20646 50622 (SCAN.INIT 20656 . 21155) (SCAN.STRING 21157 . 21737) (SCAN.TEST 21739 . 
22242) (SCAN.TESTFILE 22244 . 22768) (SCAN.OPENSTREAM 22770 . 23220) (SCAN.TOKEN 23222 . 32718) (
SCAN.NUMBER 32720 . 36476) (SCAN.ACCEPT 36478 . 36953) (SCAN.APPENDDECIMAL 36955 . 37570) (
SCAN.APPENDOCTAL 37572 . 38084) (SCAN.APPENDHEX 38086 . 38788) (SCAN.APPENDTOSCALE 38790 . 39400) (
SCAN.VALIDFRACTION 39402 . 39931) (SCAN.DECIMAL 39933 . 41482) (SCAN.OCTAL 41484 . 43027) (
SCAN.OCTALCHAR 43029 . 44141) (SCAN.HEX 44143 . 46209) (SCAN.FLOATING 46211 . 49171) (SCAN.ESCAPE 
49173 . 50620)) (55495 178030 (PARSE.MESA 55505 . 55668) (PARSE.CEDAR 55670 . 55835) (PARSE.FILE 55837
 . 56318) (PARSE.GET.STATE 56320 . 57006) (PARSE.SET.STATE 57008 . 58259) (PARSE.BIN 58261 . 58956) (
PARSE.VARID 58958 . 59125) (PARSE.SMURF 59127 . 60095) (PARSE.THISIS.MESA 60097 . 60394) (
PARSE.THISIS.CEDAR 60396 . 60696) (PARSE.MODULE 60698 . 61531) (PARSE.INCLUDEITEM 61533 . 62536) (
PARSE.INCLUDECHECK 62538 . 63343) (PARSE.SEADIRT 63345 . 63736) (PARSE.PROGHEAD 63738 . 64368) (
PARSE.RESIDENT 64370 . 64772) (PARSE.SAFE 64774 . 65184) (PARSE.DEFHEAD 65186 . 65593) (PARSE.TILDE 
65595 . 66062) (PARSE.DEFINITIONS 66064 . 66297) (PARSE.DEFBODY 66299 . 66897) (PARSE.LOCKS 66899 . 
67261) (PARSE.LAMBDA 67263 . 67729) (PARSE.MODULEITEM 67731 . 68226) (PARSE.DECLARATION 68228 . 69851)
 (PARSE.PUBLIC 69853 . 70185) (PARSE.ENTRY 70187 . 70515) (PARSE.IDLIST 70517 . 71015) (
PARSE.IDENTLIST 71017 . 72336) (PARSE.POSITION 72338 . 72805) (PARSE.OPTBITS 72807 . 73127) (
PARSE.INTERVAL 73129 . 74103) (PARSE.TYPEEXP.HERE 74105 . 74230) (PARSE.TYPEEXP 74232 . 74970) (
PARSE.RANGE 74972 . 76098) (PARSE.TYPEAPPL 76100 . 76444) (PARSE.TYPEAPPL.CONT 76446 . 77098) (
PARSE.TYPEID 77100 . 77270) (PARSE.TYPEID.CONT 77272 . 78034) (PARSE.TYPECONS 78036 . 78263) (
PARSE.TYPECONS1 78265 . 79441) (PARSE.TYPECONS.CONT 79443 . 81527) (PARSE.TYPECONS.RANGE 81529 . 81847
) (PARSE.TYPECONS.RELATIVE 81849 . 82200) (PARSE.TYPECONS.PAINTED 82202 . 82581) (PARSE.TYPECONS2 
82583 . 84285) (PARSE.TYPECONS.INTERVAL 84287 . 84649) (PARSE.TYPECONS.DEPENDENT 84651 . 85142) (
PARSE.TYPECONS.ENUMERATED 85144 . 85496) (PARSE.TYPECONS.RECORD 85498 . 85865) (PARSE.TYPECONS.ORDERED
 85867 . 86217) (PARSE.TYPECONS.VAR 86219 . 86598) (PARSE.TYPECONS.PACKED 86600 . 87165) (
PARSE.TYPECONS.DESCRIPTOR 87167 . 87650) (PARSE.TYPECONS.SAFE 87652 . 88017) (PARSE.TYPECONS.HEAP 
88019 . 88327) (PARSE.TYPECONS.LONG 88329 . 88651) (PARSE.TYPECONS.FRAME 88653 . 89137) (
PARSE.TYPECONS.REF 89139 . 89898) (PARSE.TYPECONS.LIST 89900 . 90393) (PARSE.IDENT 90395 . 90827) (
PARSE.ELEMENT 90829 . 91429) (PARSE.MONITORED 91431 . 91732) (PARSE.DEPENDENT 91734 . 92128) (
PARSE.RECLIST 92130 . 93673) (PARSE.VARIANTPAIR 93675 . 94294) (PARSE.PAIRITEM 94296 . 95621) (
PARSE.DEFAULTOPT 95623 . 96493) (PARSE.VARIANTPART 96495 . 97619) (PARSE.VCASEHEAD 97621 . 98359) (
PARSE.TAGTYPE 98361 . 98678) (PARSE.VARIANTITEM 98680 . 99133) (PARSE.TYPELIST 99135 . 99844) (
PARSE.TYPEITEM 99846 . 100352) (PARSE.POINTERTYPE 100354 . 100949) (PARSE.TRANSFERMODE 100951 . 101419
) (PARSE.INITIALIZATION 101421 . 102082) (PARSE.INITVALUE 102084 . 103273) (PARSE.CHECKED 103275 . 
103752) (PARSE.CODELIST 103754 . 104034) (PARSE.STATEMENT 104036 . 104274) (PARSE.STATEMENT1 104276 . 
105332) (PARSE.STATEMENT2 105334 . 107865) (PARSE.STATEMENT.CASEHEAD 107867 . 108763) (
PARSE.STATEMENT.FORCLAUSE 108765 . 109934) (PARSE.STATEMENT.RETURN 109936 . 110317) (
PARSE.STATEMENT.TRANSFER 110319 . 110720) (PARSE.STATEMENT.LBRACKET 110722 . 111215) (
PARSE.STATEMENT.IF 111217 . 111743) (PARSE.BLOCK 111745 . 112292) (PARSE.SCOPE 112294 . 112939) (
PARSE.BINDITEM 112941 . 113803) (PARSE.EXITS 113805 . 114117) (PARSE.CASESTMTITEM 114119 . 114580) (
PARSE.CASEEXPITEM 114582 . 115017) (PARSE.EXITITEM 115019 . 115479) (PARSE.CASETEST 115481 . 115951) (
PARSE.CONTROLID 115953 . 116532) (PARSE.FORCLAUSE 116534 . 117649) (PARSE.DIRECTION 117651 . 117954) (
PARSE.DOTEST 117956 . 118439) (PARSE.DOEXIT 118441 . 119245) (PARSE.ENABLES 119247 . 120162) (
PARSE.CATCHLIST 120164 . 121001) (PARSE.CATCHCASE 121003 . 121462) (PARSE.OPTARGS 121464 . 122016) (
PARSE.TRANSFER 122018 . 122731) (PARSE.KEYITEM 122733 . 123472) (PARSE.OPTEXP 123474 . 123975) (
PARSE.EXP 123977 . 124189) (PARSE.EXP1 124191 . 124787) (PARSE.EXP2 124789 . 126466) (
PARSE.EXP.TRANSFEROP 126468 . 126865) (PARSE.EXP.IF 126867 . 127386) (PARSE.EXP.CASEHEAD 127388 . 
127929) (PARSE.EXP.LHS 127931 . 128341) (PARSE.EXP.LBRACKET 128343 . 128852) (PARSE.EXP.ERROR 128854
 . 129120) (PARSE.EXP.DISJUNCT 129122 . 129350) (PARSE.DISJUNCT 129352 . 129955) (PARSE.CONJUNCT 
129957 . 130563) (PARSE.NEGATION 130565 . 131062) (PARSE.RELATION 131064 . 132005) (PARSE.SUM 132007
 . 132963) (PARSE.PRODUCT 132965 . 134142) (PARSE.OPTRELATION 134144 . 134894) (PARSE.RELATIONTAIL 
134896 . 135478) (PARSE.RELOP 135480 . 135760) (PARSE.ADDOP 135762 . 135983) (PARSE.MULTOP 135985 . 
136222) (PARSE.FACTOR 136224 . 136740) (PARSE.PRIMARY 136742 . 138823) (PARSE.ATOM 138825 . 139116) (
PARSE.PRIMARY.NIL 139118 . 139364) (PARSE.PRIMARY.LBRACKET 139366 . 139725) (PARSE.PRIMARY.PREFIXOP 
139727 . 140238) (PARSE.PRIMARY.VAL 140240 . 140746) (PARSE.PRIMARY.ALL 140748 . 141254) (
PARSE.PRIMARY.NEW 141256 . 141822) (PARSE.PRIMARY.TYPEOP 141824 . 142280) (PARSE.PRIMARY.SIZE 142282
 . 143027) (PARSE.PRIMARY.ISTYPE 143029 . 143598) (PARSE.PRIMARY.AT 143600 . 143928) (
PARSE.PRIMARY.DESCRIPTOR 143930 . 144423) (PARSE.PRIMARY.CONS 144425 . 144996) (PARSE.PRIMARY.LIST 
144998 . 145534) (PARSE.PRIMARY.LHS 145536 . 146576) (PARSE.PRIMARY.LHS.NEW 146578 . 147189) (
PARSE.PRIMARY.LHS.CONS 147191 . 147715) (PARSE.PRIMARY.LHS.LIST 147717 . 148210) (PARSE.QUALIFIER 
148212 . 149663) (PARSE.LHS 149665 . 151553) (PARSE.QUALIFIER.HERE 151555 . 151976) (PARSE.OPTCATCH 
151978 . 152343) (PARSE.TRANSFEROP 152345 . 152696) (PARSE.PREFIXOP 152698 . 153004) (PARSE.TYPEOP 
153006 . 153449) (PARSE.DESCLIST 153451 . 154087) (PARSE.DIRECTORY 154089 . 154590) (PARSE.IMPORTS 
154592 . 154960) (PARSE.POINTERPREFIX 154962 . 155446) (PARSE.EXPORTS 155448 . 155842) (
PARSE.FIELDLIST 155844 . 156578) (PARSE.USING 156580 . 157134) (PARSE.CATCHHEAD 157136 . 157800) (
PARSE.DECLIST 157802 . 158566) (PARSE.PAIRLIST 158568 . 159451) (PARSE.VARIANTLIST 159453 . 160033) (
PARSE.ORDERLIST 160035 . 160656) (PARSE.LHSLIST 160658 . 161107) (PARSE.INCLUDELIST 161109 . 161523) (
PARSE.MODULELIST 161525 . 162143) (PARSE.ELEMENTLIST 162145 . 162655) (PARSE.BINDLIST 162657 . 163162)
 (PARSE.STATEMENTLIST 163164 . 163903) (PARSE.CASESTMTLIST 163905 . 164579) (PARSE.CASELABEL 164581 . 
165512) (PARSE.EXITLIST 165514 . 166199) (PARSE.KEYLIST 166201 . 166716) (PARSE.CASEEXPLIST 166718 . 
167365) (PARSE.EXPLIST 167367 . 167860) (PARSE.OPEN 167862 . 168257) (PARSE.CLASS 168259 . 168522) (
PARSE.CASEHEAD 168524 . 169402) (PARSE.READONLY 169404 . 169700) (PARSE.ORDERED 169702 . 169993) (
PARSE.BASE 169995 . 170271) (PARSE.PACKED 170273 . 170559) (PARSE.HEAP 170561 . 170964) (PARSE.INLINE 
170966 . 171252) (PARSE.ARGUMENTS 171254 . 171526) (PARSE.INTERFACE 171528 . 171825) (PARSE.SHARES 
171827 . 172152) (PARSE.DEFAULT 172154 . 172468) (PARSE.OPTSIZE 172470 . 172879) (PARSE.BOUNDS 172881
 . 173265) (PARSE.LENGTH 173267 . 173631) (PARSE.INDEXTYPE 173633 . 173939) (PARSE.ELSEPART 173941 . 
174279) (PARSE.OTHERPART 174281 . 174622) (PARSE.FREE 174624 . 175023) (PARSE.CATCHANY 175025 . 175457
) (PARSE.NOT 175459 . 175676) (PARSE.NEW 175678 . 176352) (PARSE.OPTTYPE 176354 . 176688) (
PARSE.ARGLIST 176690 . 177326) (PARSE.RETURNLIST 177328 . 178028)) (181598 233998 (BUILD.INIT 181608
 . 182091) (BUILD.PUSH.SCOPE 182093 . 182472) (BUILD.POP.SCOPE 182474 . 182762) (BUILD.GC.SCOPE 182764
 . 182948) (BUILD.STORE.EXPORTS 182950 . 183162) (BUILD.STORE.IDENTLIST 183164 . 183386) (
BUILD.STORE.INTERFACES 183388 . 183616) (BUILD.STORE.INTERFACE 183618 . 183824) (BUILD.STORE.OPEN 
183826 . 184030) (BUILD.STORE.USING 184032 . 184266) (BUILD.INITIALIZATION 184268 . 184804) (
BUILD.INITIALIZE.VARS 184806 . 185130) (BUILD.INITIALIZE.VAR 185132 . 185797) (BUILD.INITIALIZE.FN 
185799 . 186672) (BUILD.INITIALIZE.RECORD 186674 . 187296) (BUILD.RECORD 187298 . 189089) (BUILD.TYPE 
189091 . 189692) (BUILD.STORE.ARGLIST 189694 . 190129) (BUILD.STORE.RETURNLIST 190131 . 190582) (
BUILD.STORE.PAIRLIST 190584 . 191056) (BUILD.STORE.PAIRITEM 191058 . 191418) (BUILD.STORE.VARLIST 
191420 . 191636) (BUILD.ID 191638 . 192029) (BUILD.FIELDID 192031 . 192150) (BUILD.PROCID 192152 . 
192295) (BUILD.RECORDID 192297 . 192442) (BUILD.TYPEID 192444 . 192658) (BUILD.VARID 192660 . 192962) 
(BUILD.LOCALVARID 192964 . 193086) (BUILD.GLOBALVARID 193088 . 193236) (BUILD.ULTIMATE.TYPE 193238 . 
193415) (BUILD.REFINE.TYPE 193417 . 194597) (BUILD.IMMEDIATE.TYPE 194599 . 197579) (BUILD.LOOKUP.TYPE 
197581 . 198271) (BUILD.LOOKUP 198273 . 198650) (BUILD.TYPEATOM 198652 . 198847) (BUILD.QUALIFY 198849
 . 199822) (BUILD.QUALIFY.PREFIXOP 199824 . 200070) (BUILD.QUALIFY.TYPEOP 200072 . 200220) (
BUILD.QUALIFY.EXPLIST 200222 . 201826) (BUILD.QUALIFY.ID 201828 . 203303) (BUILD.ARITH.EXP1 203305 . 
203560) (BUILD.ARITH.EXP2 203562 . 203801) (BUILD.ARITH.EXP* 203803 . 204915) (BUILD.ARITH.ADD1SUB1 
204917 . 205835) (BUILD.COERCE.ARITHOP 205837 . 206222) (BUILD.STRONGEST.TYPE.AMONG 206224 . 206611) (
BUILD.STRONGEST.TYPE 206613 . 207241) (BUILD.COERCE 207243 . 207801) (BUILD.COERCE.MARRAY 207803 . 
208548) (BUILD.COERCE.MLIST 208550 . 209231) (BUILD.COERCE.EXPLIST 209233 . 211313) (BUILD.ALIGN 
211315 . 212971) (BUILD.ALIGN.VALUE 212973 . 213408) (BUILD.ADD.TO.FILECOMS 213410 . 213974) (
BUILD.ADD1 213976 . 214182) (BUILD.CALL 214184 . 214536) (BUILD.CHARCODE 214538 . 215736) (BUILD.COND 
215738 . 216271) (BUILD.COPY.OF 216273 . 216528) (BUILD.FETCH 216530 . 217161) (BUILD.FORCLAUSE.BY 
217163 . 217350) (BUILD.FORCLAUSE.IN 217352 . 218323) (BUILD.FORCLAUSE.THROUGH 218325 . 218505) (
BUILD.IN 218507 . 219717) (BUILD.ISTYPE 219719 . 220205) (BUILD.LAMBDA 220207 . 220654) (BUILD.NEW 
220656 . 220810) (BUILD.OR 220812 . 221054) (BUILD.PROG 221056 . 222299) (BUILD.PROGN 222301 . 222603)
 (BUILD.REPLACE 222605 . 223267) (BUILD.RETURN 223269 . 224670) (BUILD.SELECTQ 224672 . 226543) (
BUILD.SELECTQ.FN 226545 . 226771) (BUILD.SELECTQ.CCLAUSE 226773 . 227440) (BUILD.SELECTQ.TEST 227442
 . 227859) (BUILD.SELECTQ.SCLAUSE 227861 . 228307) (BUILD.SELECTQ.KEY 228309 . 228931) (
BUILD.SELECTTRUEFROM 228933 . 229458) (BUILD.SELECTTRUEFROM.CLAUSE 229460 . 229655) (BUILD.SETQ 229657
 . 231265) (BUILD.SETQ.ARRAY 231267 . 232025) (BUILD.SETQ.ORDERLIST 232027 . 233506) (BUILD.SUB1 
233508 . 233714) (BUILD.TAIL 233716 . 233996)))))
STOP