--- /dev/null
+
+<PACKAGE "PARSE-DEFINITIONS">
+
+"Definitions of types and offsets appropriate for trees built by ADAPLEX
+ parser"
+
+<ENTRY PRETTY
+ NOT-PRETTY
+ USETYPE
+ FOR-LOOP
+ ITERATOR
+ FOR-BODY
+ ITERATION
+ LOOP-CONTROL
+ LOOP-IDENTIFIER
+ LOOP-SET-EXPRESSION
+ LOOP-PREDICATE
+ LOOP-ORDER
+ LOOP-ORDER-FUNCTION
+ RETRIEVE
+ RETRIEVE-SET
+ RETRIEVE-WORKSPACE
+ RETRIEVE-TARGET-LIST
+ PRINTYPE
+ IFTYPE
+ CLAUSE
+ CLAUSE-PREDICATE
+ CLAUSE-LIST-OF-COMMANDS
+ SETTYPE
+ FCN
+ FCN-NAME
+ FCN-ARGUMENT
+ RESTRICTION
+ RESTRICT-ID
+ RESTRICT-SET
+ RESTRICT-PRED
+ OPERATOR
+ OP-NAME
+ OP-OP1
+ OP-OP2
+ QUANTIFIER
+ QUANT-TYPE
+ QUANT-NUM
+ QUANT-ID
+ QUANT-SET
+ QUANT-PRED
+ QUANT-TEST
+ EXISTS
+ EXISTS-TYPE
+ EXISTS-SET
+ AGGREGATE
+ AGG-NAME
+ AGG-FCN
+ AGG-SET
+ AGG-OVER
+ IDENTIFIER
+ ID-NAME
+ ID-TYPE
+ ID-OTHER
+ VIRTUAL
+ ENTITY-DEF-EXTENT
+ ENTITY-DEF-VIRTUAL?
+ SUPERTYPE
+ COTYPE
+ FCN-DFN
+ FCN-DFN-NAME
+ FCN-DFN-FORMAT
+ EXTENT
+ EXTENT-NAME
+ EXTENT-EMAP
+ EXTENT-FMAP
+ JOIN
+ PROJECT
+ PROJECT-MAPLIST
+ PROJECT-FCNLIST
+ FCNMAP
+ FCNMAP-NAME
+ FCNMAP-SETEXP
+ ENTITY-DEF
+ ENTITY-DEF-NAME
+ ENTITY-DEF-FCN-LIST
+ ENTITY-DEF-SUPERTYPES
+ ENTITY-DEF-COTYPES>
+
+"\f"
+
+"Define MSETG to SETG an atom and make it manifest as well"
+
+<DEFINE MSETG (ATOM VAL) <SETG .ATOM .VAL> <MANIFEST .ATOM>>
+
+
+"INDENTATION and INDENT-AMT are used in pretty printing of ADAPLEX"
+
+<SET INDENTATION 0>
+
+<MSETG INDENT-AMT 8>
+
+"Define type for USE statement"
+
+<NEWTYPE USETYPE LIST>
+
+<DEFINE P-USETYPE (L) <IPRINC "USE ">
+ <PRINT-LIST .L>
+ <PRINC !\;>>
+
+<NEWTYPE FOR-LOOP VECTOR '<<PRIMTYPE VECTOR> ITERATION LIST>>
+
+"FOR loops have iteration spec and a list of commands"
+
+<MSETG ITERATOR <OFFSET 1 FOR-LOOP>>
+
+<MSETG FOR-BODY <OFFSET 2 FOR-LOOP>>
+
+"Function to print for loops nicely"
+
+<DEFINE PRINT-FOR (FL)
+ #DECL ((FL) FOR-LOOP)
+ <IPRINT <ITERATOR .FL>>
+ <CRLF>
+ <SET INDENTATION <+ .INDENTATION ,INDENT-AMT>>
+ <PRINT-SEQ <FOR-BODY .FL>>
+ <IPRINC "END;">
+ <SET INDENTATION <- .INDENTATION ,INDENT-AMT>>>
+
+"\f"
+"Type ITERATION specifies the range of a for loop."
+
+<NEWTYPE ITERATION
+ VECTOR
+ '<<PRIMTYPE VECTOR> <OR FALSE FIX>
+ IDENTIFIER
+ ANY
+ ANY
+ ATOM
+ <OR IDENTIFIER FALSE>>>
+
+<MSETG LOOP-CONTROL <OFFSET 1 ITERATION>>
+
+<MSETG LOOP-IDENTIFIER <OFFSET 2 ITERATION>>
+
+<MSETG LOOP-SET-EXPRESSION <OFFSET 3 ITERATION>>
+
+<MSETG LOOP-PREDICATE <OFFSET 4 ITERATION>>
+
+<MSETG LOOP-ORDER <OFFSET 5 ITERATION>>
+
+<MSETG LOOP-ORDER-FUNCTION <OFFSET 6 ITERATION>>
+
+
+
+<DEFINE ITERATOR-PRINT (ITER)
+ #DECL ((ITER) ITERATION)
+ <IPRINC "FOR ">
+ <COND (<LOOP-CONTROL .ITER>
+ <PRINC "UP TO ">
+ <PRIN1 <LOOP-CONTROL .ITER>>)
+ (ELSE <PRINC "EACH">)>
+ <PRINC " ">
+ <PRIN1 <LOOP-IDENTIFIER .ITER>>
+ <PRINC " IN ">
+ <PRIN1 <LOOP-SET-EXPRESSION .ITER>>
+ <COND (<LOOP-PREDICATE .ITER>
+ <PRINC " WHERE ">
+ <PRIN1 <LOOP-PREDICATE .ITER>>)>
+ <COND (<N==? <LOOP-ORDER .ITER> RANDOM>
+ <PRINC " IN ">
+ <PRIN1 <LOOP-ORDER .ITER>>
+ <PRINC " BY ">
+ <PRIN1 <LOOP-ORDER-FUNCTION .ITER>>)>>
+
+"Type RETRIEVE is produced by a Retrieve statement in the language"
+
+<NEWTYPE RETRIEVE VECTOR '<<PRIMTYPE VECTOR> ANY IDENTIFIER LIST>>
+
+<MSETG RETRIEVE-SET <OFFSET 1 RETRIEVE>>
+
+<MSETG RETRIEVE-WORKSPACE <OFFSET 2 RETRIEVE>>
+
+<MSETG RETRIEVE-TARGET-LIST <OFFSET 3 RETRIEVE>>
+
+<DEFINE PRINT-RETRIEVE (RETRV) #DECL ((RETRV) RETRIEVE)
+ <IPRINC "RETRIEVE ">
+ <PRIN1 <RETRIEVE-SET .RETRV>>
+ <PRINC " INTO ">
+ <PRIN1 <RETRIEVE-WORKSPACE .RETRV>>
+ <PRINC " ">
+ <PRINT-LIST <RETRIEVE-TARGET-LIST .RETRV>>
+ <PRINC ";">>
+
+"\f"
+"Type PRINTYPE is produced for a PRINT command"
+
+<NEWTYPE PRINTYPE LIST>
+
+<DEFINE PRINT-PRINT (L)
+ <IPRINC "PRINT ">
+ <PRINT-LIST .L>>
+
+"Various kinds of IFs become IFTYPE. IFTYPE is a list of CLAUSEs. Each
+ clause has a predicate and a list of things to do on truth."
+
+<NEWTYPE IFTYPE LIST>
+
+<DEFINE IFTYPE-PRINT (L "AUX" (FIRST T))
+ #DECL ((L) IFTYPE)
+ <MAPF <>
+ <FUNCTION (C)
+ #DECL ((C) CLAUSE)
+ <COND (<==? <CLAUSE-PREDICATE .C> ELSE> <IPRINC "ELSE ">)
+ (ELSE
+ <COND (.FIRST <IPRINC "IF ">)
+ (ELSE <IPRINC "ELSEIF ">)>
+ <PRIN1 <CLAUSE-PREDICATE .C>>
+ <PRINC " THEN ">)>
+ <CRLF>
+ <SET INDENTATION <+ .INDENTATION ,INDENT-AMT>>
+ <PRINT-SEQ <CLAUSE-LIST-OF-COMMANDS .C>>
+ <SET INDENTATION <- .INDENTATION ,INDENT-AMT>>
+ <SET FIRST <>>>
+ .L>
+ <IPRINC "END IF">>
+
+<NEWTYPE CLAUSE VECTOR '<<PRIMTYPE VECTOR> ANY LIST>>
+
+<MSETG CLAUSE-PREDICATE <OFFSET 1 CLAUSE>>
+
+<MSETG CLAUSE-LIST-OF-COMMANDS <OFFSET 2 CLAUSE>>
+
+"\f"
+
+"Explicit sets become lists of the explicit objects in the set"
+
+<NEWTYPE SETTYPE LIST>
+
+<DEFINE SET-PRINT (L) <PRINT-LIST .L>>
+
+"Type FCN is for entity function calls"
+
+<NEWTYPE FCN VECTOR '<<PRIMTYPE VECTOR> IDENTIFIER ANY>>
+
+<MSETG FCN-NAME <OFFSET 1 FCN>>
+
+<MSETG FCN-ARGUMENT <OFFSET 2 FCN>>
+
+<DEFINE FCN-PRINT (FC) #DECL ((FC) FCN)
+ <PRIN1 <FCN-NAME .FC>>
+ <PRINC " (">
+ <PRIN1 <FCN-ARGUMENT .FC>>
+ <PRINC ")">>
+
+"Type RESTRICTION is for restricted sets. It has a variable, an input set and
+ a predicate"
+
+<NEWTYPE RESTRICTION VECTOR '<<PRIMTYPE VECTOR> IDENTIFIER ANY ANY>>
+
+<MSETG RESTRICT-ID <OFFSET 1 RESTRICTION>>
+
+<MSETG RESTRICT-SET <OFFSET 2 RESTRICTION>>
+
+<MSETG RESTRICT-PRED <OFFSET 3 RESTRICTION>>
+
+<DEFINE RESTRICT-PRINT (RES) #DECL ((RES) RESTRICTION)
+ <PRINC "(">
+ <PRIN1 <RESTRICT-ID .RES>>
+ <PRINC " IN ">
+ <PRIN1 <RESTRICT-SET .RES>>
+ <PRINC " WHERE ">
+ <PRIN1 <RESTRICT-PRED .RES>>
+ <PRINC ")">>
+"\f"
+"Type OPERATOR is for +,- etc."
+
+<NEWTYPE OPERATOR VECTOR '<<PRIMTYPE VECTOR> ATOM ANY ANY>>
+
+<MSETG OP-NAME <OFFSET 1 OPERATOR>>
+
+<MSETG OP-OP1 <OFFSET 2 OPERATOR>>
+
+<MSETG OP-OP2 <OFFSET 3 OPERATOR>>
+
+<DEFINE OP-PRINT (OP) #DECL ((OP) OPERATOR)
+ <COND (<OP-OP2 .OP> ;"Binary operator"
+ <COND (<TYPE? <OP-OP1 .OP> OPERATOR>
+ <PRINC "(">)>
+ <PRIN1 <OP-OP1 .OP>>
+ <COND (<TYPE? <OP-OP1 .OP> OPERATOR>
+ <PRINC ")">)>
+ <COND (<L=? <LENGTH <SPNAME <OP-NAME .OP>>> 2>
+ <PRINC <OP-NAME .OP>>)
+ (ELSE
+ <PRINC " ">
+ <PRINC <OP-NAME .OP>>
+ <PRINC " ">)>
+ <COND (<TYPE? <OP-OP2 .OP> OPERATOR>
+ <PRINC "(">)>
+ <PRIN1 <OP-OP2 .OP>>
+ <COND (<TYPE? <OP-OP2 .OP> OPERATOR>
+ <PRINC ")">)>)
+ (ELSE
+ <COND (<L=? <LENGTH <SPNAME <OP-NAME .OP>>> 2>
+ <PRINC <OP-NAME .OP>>)
+ (ELSE
+ <PRINC <OP-NAME .OP>>
+ <PRINC " ">)>
+ <PRIN1 <OP-OP1 .OP>>)>>
+
+"\f"
+"Type QUANTIFIER is for DAPLEX quantifiers FOR SOME etc."
+
+<NEWTYPE QUANTIFIER
+ VECTOR
+ '<<PRIMTYPE VECTOR> ATOM FIX IDENTIFIER ANY ANY ANY>>
+
+<MSETG QUANT-TYPE <OFFSET 1 QUANTIFIER>>
+
+<MSETG QUANT-NUM <OFFSET 2 QUANTIFIER>>
+
+<MSETG QUANT-ID <OFFSET 3 QUANTIFIER>>
+
+<MSETG QUANT-SET <OFFSET 4 QUANTIFIER>>
+
+<MSETG QUANT-PRED <OFFSET 5 QUANTIFIER>>
+
+<MSETG QUANT-TEST <OFFSET 6 QUANTIFIER>>
+
+<DEFINE QUANT-PRINT (Q)
+ #DECL ((Q) QUANTIFIER)
+ <PRINC "FOR ">
+ <COND (<0? <QUANT-NUM .Q>> <PRIN1 <QUANT-TYPE .Q>>)
+ (ELSE
+ <PRINC <COND (<==? <QUANT-TYPE .Q> AT-LEAST> "AT LEAST ")
+ (ELSE "AT MOST ")>>
+ <PRIN1 <QUANT-NUM .Q>>)>
+ <PRINC " ">
+ <PRIN1 <QUANT-ID .Q>>
+ <PRINC " IN ">
+ <PRIN1 <QUANT-SET .Q>>
+ <COND (<QUANT-PRED .Q> <PRINC " WHERE "> <PRIN1 <QUANT-PRED .Q>>)>
+ <PRINC " TEST ">
+ <PRIN1 <QUANT-TEST .Q>>>
+
+<NEWTYPE EXISTS VECTOR '<<PRIMTYPE VECTOR> ATOM FIX ANY>>
+
+<MSETG EXISTS-TYPE <OFFSET 1 EXISTS>>
+
+<MSETG EXISTS-NUM <OFFSET 2 EXISTS>>
+
+<MSETG EXISTS-SET <OFFSET 3 EXISTS>>
+
+<NEWTYPE AGGREGATE
+ VECTOR
+ '<<PRIMTYPE VECTOR> ATOM <OR IDENTIFIER FALSE> ANY <OR FALSE ATOM>>>
+
+<MSETG AGG-NAME <OFFSET 1 AGGREGATE>>
+
+<MSETG AGG-FCN <OFFSET 2 AGGREGATE>>
+
+<MSETG AGG-SET <OFFSET 3 AGGREGATE>>
+
+<MSETG AGG-OVER <OFFSET 4 AGGREGATE>>
+
+<NEWTYPE IDENTIFIER VECTOR '<<PRIMTYPE VECTOR> ATOM ANY ANY>>
+
+<MSETG ID-NAME <OFFSET 1 IDENTIFIER>>
+
+<MSETG ID-TYPE <OFFSET 1 IDENTIFIER>>
+
+<MSETG ID-OTHER <OFFSET 1 IDENTIFIER>>
+
+<DEFINE PRINT-ID (ID) #DECL ((ID) IDENTIFIER) <PRIN1 <ID-NAME .ID>>>
+
+<NEWTYPE SUPERTYPE LIST>
+
+<NEWTYPE COTYPE LIST>
+
+<NEWTYPE FCN-DFN VECTOR '<<PRIMTYPE VECTOR> IDENTIFIER ANY>>
+
+<MSETG FCN-DFN-NAME <OFFSET 1 FCN-DFN>>
+
+<MSETG FCN-DFN-FORMAT <OFFSET 2 FCN-DFN>>
+
+<NEWTYPE EXTENT
+ VECTOR
+ '<<PRIMTYPE VECTOR> IDENTIFIER
+ <OR JOIN RESTRICTION PROJECT>
+ <LIST [REST FCNMAP]>>>
+
+<MSETG EXTENT-NAME <OFFSET 1 EXTENT>>
+
+<MSETG EXTENT-EMAP <OFFSET 2 EXTENT>>
+
+<MSETG EXTENT-FMAP <OFFSET 3 EXTENT>>
+
+<NEWTYPE JOIN LIST>
+
+<NEWTYPE PROJECT VECTOR '<<PRIMTYPE VECTOR> LIST LIST>>
+
+<MSETG PROJECT-MAPLIST <OFFSET 1 PROJECT>>
+
+<MSETG PROJECT-FCNLIST <OFFSET 2 PROJECT>>
+
+<NEWTYPE FCNMAP VECTOR '<<PRIMTYPE VECTOR> IDENTIFIER ANY>>
+
+<MSETG FCNMAP-NAME <OFFSET 1 FCNMAP>>
+
+<MSETG FCNMAP-SETEXP <OFFSET 2 FCNMAP>>
+
+<NEWTYPE ENTITY-DEF
+ VECTOR
+ '<<PRIMTYPE VECTOR> IDENTIFIER
+ LIST
+ <OR FALSE <LIST ANY>>
+ <OR FALSE <LIST ANY>>
+ <OR FALSE ATOM>
+ <OR EXTENT FALSE>>>
+
+<MSETG ENTITY-DEF-NAME <OFFSET 1 ENTITY-DEF>>
+
+<MSETG ENTITY-DEF-FCN-LIST <OFFSET 2 ENTITY-DEF>>
+
+<MSETG ENTITY-DEF-SUPERTYPES <OFFSET 3 ENTITY-DEF>>
+
+<MSETG ENTITY-DEF-COTYPES <OFFSET 4 ENTITY-DEF>>
+
+<MSETG ENTITY-DEF-VIRTUAL? <OFFSET 5 ENTITY-DEF>>
+
+<MSETG ENTITY-DEF-EXTENT <OFFSET 6 ENTITY-DEF>>
+
+
+"Utility print stuff"
+
+<DEFINE PRINT-LIST (L) #DECL ((L) <PRIMTYPE LIST>)
+ <PRINC "(">
+ <MAPR <>
+ <FUNCTION (LL "AUX" (X <1 .LL>))
+ <PRIN1 .X>
+ <COND (<EMPTY? <REST .LL>> <PRINC ")">)
+ (ELSE <PRINC ", ">)>>
+ .L>>
+
+<DEFINE PRINT-SEQ (L) #DECL ((L) <PRIMTYPE LIST>)
+ <MAPF <>
+ <FUNCTION (X)
+ <IPRINT .X>
+ <PRINC ";">
+ <CRLF>> .L>>
+
+<DEFINE IPRINT (OBJ)
+ <INDENT-TO .INDENTATION>
+ <PRIN1 .OBJ>>
+
+<DEFINE IPRINC (OBJ)
+ <INDENT-TO .INDENTATION>
+ <PRINC .OBJ>>
+
+
+
+<DEFINE PRETTY ()
+ <MAPF <> <FUNCTION (TYPE FCN) <PRINTTYPE .TYPE .FCN>> ,TYPES ,PSUBRS>>
+
+<DEFINE NOT-PRETTY ()
+ <MAPF <> <FUNCTION (TYPE) <PRINTTYPE .TYPE ,PRINT>> ,TYPES>>
+
+<SETG TYPES
+ '![USETYPE
+ FOR-LOOP
+ ITERATION
+ RETRIEVE
+ PRINTYPE
+ IFTYPE
+ SETTYPE
+ FCN
+ RESTRICTION
+ OPERATOR
+ QUANTIFIER
+ IDENTIFIER!]>
+
+<SETG PSUBRS
+ [,P-USETYPE
+ ,PRINT-FOR
+ ,ITERATOR-PRINT
+ ,PRINT-RETRIEVE
+ ,PRINT-PRINT
+ ,IFTYPE-PRINT
+ ,SET-PRINT
+ ,FCN-PRINT
+ ,RESTRICT-PRINT
+ ,OP-PRINT
+ ,QUANT-PRINT
+ ,PRINT-ID]>
+
+<ENDPACKAGE>
+\0
\ No newline at end of file
--- /dev/null
+
+"GETORDER FUNCTIONS"
+
+<DEFINE CHECK (ATM)
+ #DECL ((ATM) <UNSPECIAL ATOM>)
+ <AND <TYPE? .ATM ATOM>
+ <GASSIGNED? .ATM>
+ <OR <TYPE? ,.ATM FUNCTION>
+ <TYPE? ,.ATM MACRO>>>>
+
+<DEFINE PREV (LS SUBLS)
+ #DECL ((LS SUBLS) <UNSPECIAL LIST> (VALUE) LIST)
+ <REST .LS <- <LENGTH .LS> <LENGTH .SUBLS> 1>>>
+
+<DEFINE SPLOUTEM (FL OU)
+ #DECL ((FL) <UNSPECIAL LIST> (OU) <UNSPECIAL ATOM>)
+ <REPEAT (TEM)
+ #DECL ((TEM) <UNSPECIAL <PRIMTYPE LIST>>)
+ <COND (<EMPTY? .FL> <RETURN T>)
+ (<SET TEM <MEMQ .OU <1 .FL>>>
+ <COND (<==? <1 .FL> .TEM> <PUT .FL 1 <REST .TEM>>)
+ (ELSE <PUTREST <PREV <1 .FL> .TEM> <REST .TEM>>)>)>
+ <SET FL <REST .FL 2>>>>
+
+<DEFINE REVERSE (LS)
+ #DECL ((LS) <UNSPECIAL LIST>)
+ <REPEAT ((RES ()) (TEM ()))
+ #DECL ((RES TEM) LIST)
+ <COND (<EMPTY? .LS> <RETURN .RES>)>
+ <SET TEM <REST .LS>>
+ <SET RES <PUTREST .LS .RES>>
+ <SET LS .TEM>>>
+
+<DEFINE ORDEREM (FLIST)
+ #DECL ((FLIST) <UNSPECIAL LIST>)
+ <REPEAT (TEM (RES ()))
+ #DECL ((RES) <UNSPECIAL <LIST [REST <OR ATOM LIST>]>>
+ (VALUE) <LIST [REST <OR ATOM LIST>]>
+ (TEM) <UNSPECIAL <PRIMTYPE LIST>>)
+ <COND
+ (<EMPTY? .FLIST> <RETURN <REVERSE .RES>>)
+ (<SET TEM <MEMQ () .FLIST>>
+ <SET RES (<2 .TEM> !.RES)>
+ <COND (<==? .TEM .FLIST> <SET FLIST <REST .FLIST 2>>)
+ (ELSE <PUTREST <PREV .FLIST .TEM> <REST .TEM 2>>)>
+ <SPLOUTEM .FLIST <1 .RES>>)
+ (ELSE
+ <PROG ((RES2 ()) GOTONE)
+ #DECL ((RES2) LIST)
+ <SET GOTONE <>>
+ <REPEAT ((RES1 .FLIST))
+ #DECL ((RES1) LIST)
+ <COND (<NOT <CALLME <2 .RES1> .FLIST>>
+ <SET GOTONE T>
+ <SET RES2 (<2 .RES1> !.RES2)>
+ <COND (<==? .FLIST .RES1>
+ <SET FLIST <REST .FLIST 2>>)
+ (ELSE
+ <PUTREST <PREV .FLIST .RES1>
+ <REST .RES1 2>>)>)>
+ <AND <EMPTY? <SET RES1 <REST .RES1 2>>> <RETURN>>>
+ <COND (.GOTONE <AGAIN>)
+ (<NOT <EMPTY? .FLIST>> <SET FLIST <CORDER .FLIST>>)>
+ <SET TEM <REVERSE .RES>>
+ <COND (<NOT <EMPTY? .FLIST>>
+ <COND (<EMPTY? .RES>
+ <SET TEM .FLIST>
+ <SET RES <REST .FLIST <- <LENGTH .FLIST> 1>>>)
+ (ELSE
+ <SET RES
+ <REST <PUTREST .RES .FLIST>
+ <LENGTH .FLIST>>>)>)>
+ <COND (<EMPTY? .RES> <SET RES .RES2>)
+ (ELSE <PUTREST .RES .RES2> <SET RES .TEM>)>>
+ <RETURN .RES>)>>>
+
+<DEFINE CALLME (ATM LST)
+ #DECL ((ATM) ATOM (LST) <LIST [REST <LIST [REST ATOM]> ATOM]>)
+ <REPEAT ()
+ <AND <EMPTY? .LST> <RETURN <>>>
+ <AND <MEMQ .ATM <1 .LST>> <RETURN>>
+ <SET LST <REST .LST 2>>>>
+
+<DEFINE CORDER (LST "AUX" (RES ()))
+ #DECL ((LST) <LIST [REST <LIST [REST ATOM]> ATOM]> (RES) LIST)
+ <REPEAT ((LS .LST))
+ #DECL ((LS) <LIST [REST LIST ATOM]>)
+ <AND <EMPTY? .LS> <RETURN>>
+ <PUT .LS 1 <ALLREACH (<2 .LS>) <1 .LS> .LST>>
+ <SET LS <REST .LS 2>>>
+ <REPEAT ((PNT ()))
+ #DECL ((PNT) <LIST [REST LIST ATOM]>)
+ <REPEAT ((SHORT <CHTYPE <MIN> FIX>) (TL 0) (LST .LST))
+ #DECL ((SHORT TL) FIX (LST) <LIST [REST LIST ATOM]>)
+ <AND <EMPTY? .LST> <RETURN>>
+ <COND (<L? <SET TL <LENGTH <1 .LST>>> .SHORT>
+ <SET SHORT .TL>
+ <SET PNT .LST>)>
+ <SET LST <REST .LST 2>>>
+ <SET RES
+ (<COND (<1? <LENGTH <1 .PNT>>> <1 <1 .PNT>>)
+ (ELSE <1 .PNT>)>
+ !.RES)>
+ <MAPF <> <FUNCTION (ATM) <SPLOUTEM .LST .ATM>> <1 .PNT>>
+ <REPEAT (TEM)
+ <COND (<SET TEM <MEMQ () .LST>>
+ <COND (<==? .TEM .LST> <SET LST <REST .TEM 2>>)
+ (ELSE
+ <PUTREST <PREV .LST .TEM>
+ <REST .TEM 2>>)>)
+ (ELSE <RETURN>)>>
+ <AND <EMPTY? .LST> <RETURN>>>
+ <REVERSE .RES>>
+
+<DEFINE ALLREACH (LATM LST MLST)
+ #DECL ((LATM LST) <LIST [REST ATOM]>
+ (MLST) <LIST [REST <LIST [REST ATOM]> ATOM]>)
+ <MAPF <>
+ <FUNCTION (ATM)
+ #DECL ((ATM) ATOM)
+ <COND (<MEMQ .ATM .LATM>)
+ (ELSE
+ <SET LATM
+ <ALLREACH (.ATM !.LATM)
+ <REPEAT ((L .MLST))
+ #DECL ((L) <LIST [REST LIST ATOM]>)
+ <AND <==? <2 .L> .ATM>
+ <RETURN <1 .L>>>
+ <SET L <REST .L 2>>>
+ .MLST>>)>>
+ .LST>
+ .LATM>
+
+<DEFINE REMEMIT (ATM)
+ #DECL ((ATM) ATOM (FUNC) <SPECIAL ATOM>
+ (FUNCL) <SPECIAL <LIST [REST ATOM]>>)
+ <OR <==? .ATM .FUNC>
+ <MEMQ .ATM .FUNCL>
+ <SET FUNCL (.ATM !.FUNCL)>>>
+
+<DEFINE FINDREC (OBJ "AUX" (FM '<>))
+ #DECL ((FM) FORM)
+ <COND (<MONAD? .OBJ>)
+ (<AND <TYPE? .OBJ FORM SEGMENT>
+ <NOT <EMPTY? <SET FM <CHTYPE .OBJ FORM>>>>>
+ <COND (<AND <TYPE? <1 .FM> ATOM> <GASSIGNED? <1 .FM>>>
+ <AND <TYPE? ,<1 .FM> FUNCTION> <REMEMIT <1 .FM>>>
+ <AND <TYPE? ,<1 .FM> MACRO>
+ <NOT <EMPTY? ,<1 .FM>>>
+ <FINDREC <EMACRO .FM>>>
+ ;"Analyze expansion of MACRO call"
+ <AND <OR <==? ,<1 .FM> ,MAPF> <==? ,<1 .FM> ,MAPR>>
+ <NOT <LENGTH? .FM 3>>
+ <PROG ()
+ <AND <TYPE? <2 .FM> FORM> <CHK-GVAL <2 .FM>>>
+ T>
+ <PROG ()
+ <AND <TYPE? <3 .FM> FORM>
+ <CHK-GVAL <3 .FM>>>>>)
+ (<STRUCTURED? <1 .OBJ>> <MAPF <> ,FINDREC <1 .OBJ>>)>
+ <COND (<EMPTY? <REST .OBJ>>)
+ (ELSE <MAPF <> ,FINDREC <REST .OBJ>>)>)
+ (ELSE <MAPF <> ,FINDREC .OBJ>)>>
+
+<DEFINE EMACRO (OBJ "AUX" (ERR <GET ERROR!-INTERRUPTS INTERRUPT>) TEM)
+ <COND (.ERR <OFF .ERR>)>
+ <ON "ERROR"
+ <FUNCTION (FR "TUPLE" T)
+ <COND (<AND <GASSIGNED? MACACT> <LEGAL? ,MACACT>>
+ <DISMISS [!.T] ,MACACT>)
+ (ELSE <APPLY ,<PARSE "OVALRET!-COMBAT!-"> " ">)>>
+ 100>
+ <COND (<TYPE? <SET TEM
+ <PROG MACACT () #DECL ((MACACT) <SPECIAL ACTIVATION>)
+ <SETG MACACT .MACACT>
+ (<EXPAND .OBJ>)>>
+ VECTOR>
+ <OFF "ERROR">
+ <COND (.ERR <EVENT .ERR>)>
+ <ERROR " MACRO EXPANSION LOSSAGE " !.TEM>)
+ (ELSE <OFF "ERROR"> <AND .ERR <EVENT .ERR>> <1 .TEM>)>>
+
+<DEFINE CHK-GVAL (FM) #DECL ((FM) FORM)
+ <AND <==? <LENGTH .FM> 2>
+ <TYPE? <1 .FM> ATOM>
+ <==? ,<1 .FM> ,GVAL>
+ <TYPE? <2 .FM> ATOM>
+ <GASSIGNED? <2 .FM>>
+ <OR <TYPE? ,<2 .FM> FUNCTION>
+ <AND <TYPE? ,<2 .FM> MACRO>
+ <NOT <EMPTY? ,<2 .FM>>>
+ <TYPE? <1 ,<2 .FM>> FUNCTION>>>
+ <REMEMIT <2 .FM>>>>
+
+<DEFINE FINDEM (FUNC "AUX" (FUNCL ()))
+ #DECL ((FUNC) <SPECIAL ATOM> (FUNCL) <SPECIAL <LIST [REST ATOM]>>
+ (VALUE) <LIST [REST ATOM]>)
+ <FINDREC ,.FUNC>
+ .FUNCL>
+
+<DEFINE FINDEMALL (ATM
+ "AUX" (TOPDO
+ <REPEAT ((TD ()))
+ #DECL ((TD) LIST
+ (VALUE)
+ <LIST <LIST [REST ATOM]> ATOM>)
+ <AND <EMPTY? .ATM> <RETURN .TD>>
+ <SET TD (<FINDEM <1 .ATM>> <1 .ATM> !.TD)>
+ <SET ATM <REST .ATM>>>))
+ #DECL ((ATM) <UNSPECIAL <TUPLE [REST ATOM]>>
+ (TOPDO) <UNSPECIAL <LIST <LIST [REST ATOM]> ATOM>>)
+ <REPEAT ((TODO .TOPDO) (CURDO <1 .TOPDO>))
+ #DECL ((TODO) <UNSPECIAL LIST>
+ (CURDO) <UNSPECIAL <LIST [REST ATOM]>>)
+ <COND (<EMPTY? .CURDO>
+ <COND (<EMPTY? <SET TODO <REST .TODO 2>>>
+ <RETURN .TOPDO>)
+ (ELSE <SET CURDO <1 .TODO>> <AGAIN>)>)
+ (<MEMQ <1 .CURDO> .TOPDO>)
+ (ELSE
+ <PUTREST <REST .TODO <- <LENGTH .TODO> 1>>
+ (<FINDEM <1 .CURDO>> <1 .CURDO>)>)>
+ <SET CURDO <REST .CURDO>>>>
+
+<DEFINE GETORDER ("TUPLE" ATMS)
+ #DECL ((ATMS) <UNSPECIAL <TUPLE [REST ATOM]>>)
+ <COND (<NOT <MEMQ #FALSE () <MAPF ,LIST ,CHECK .ATMS>>>
+ <ORDEREM <FINDEMALL .ATMS>>)
+ (ELSE <ERROR BAD-ARG GETORDER>)>>
+
+
+
+<SET LIST_OF_FUNCTIONS
+ '(CHECK
+ PREV
+ SPLOUTEM
+ REVERSE
+ ORDEREM
+ REMEMIT
+ FINDREC
+ FINDEM
+ FINDEMALL
+ GETORDER)>
+\f\ 3\ 3\ 3
\ No newline at end of file
projects / pdp10-muddle.git / commitdiff