(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