9 <OR <TYPE? ,.ATM FUNCTION>
10 <TYPE? ,.ATM MACRO>>>>
12 <DEFINE PREV (LS SUBLS)
13 #DECL ((LS SUBLS) LIST (VALUE) LIST)
14 <REST .LS <- <LENGTH .LS> <LENGTH .SUBLS> 1>>>
16 <DEFINE SPLOUTEM (FL OU)
17 #DECL ((FL) LIST (OU) ATOM)
19 #DECL ((TEM) <OR FALSE LIST>)
20 <COND (<EMPTY? .FL> <RETURN T>)
21 (<SET TEM <MEMQ .OU <1 .FL>>>
22 <COND (<==? <1 .FL> .TEM> <PUT .FL 1 <REST .TEM>>)
23 (ELSE <PUTREST <PREV <1 .FL> .TEM> <REST .TEM>>)>)>
24 <SET FL <REST .FL 2>>>>
28 <REPEAT ((RES ()) (TEM ()))
29 #DECL ((RES TEM) LIST)
30 <COND (<EMPTY? .LS> <RETURN .RES>)>
32 <SET RES <PUTREST .LS .RES>>
35 <DEFINE ORDEREM (FLIST)
37 <REPEAT (TEM (RES ()))
38 #DECL ((RES) <LIST [REST <OR ATOM LIST>]>
39 (VALUE) <LIST [REST <OR ATOM LIST>]>
40 (TEM) <PRIMTYPE LIST>)
42 (<EMPTY? .FLIST> <RETURN <REVERSE .RES>>)
43 (<SET TEM <MEMQ () .FLIST>>
44 <SET RES (<2 .TEM> !.RES)>
45 <COND (<==? .TEM .FLIST> <SET FLIST <REST .FLIST 2>>)
46 (ELSE <PUTREST <PREV .FLIST .TEM> <REST .TEM 2>>)>
47 <SPLOUTEM .FLIST <1 .RES>>)
49 <PROG ((RES2 ()) GOTONE)
52 <REPEAT ((RES1 .FLIST))
54 <COND (<NOT <CALLME <2 .RES1> .FLIST>>
56 <SET RES2 (<2 .RES1> !.RES2)>
57 <COND (<==? .FLIST .RES1>
58 <SET FLIST <REST .FLIST 2>>)
60 <PUTREST <PREV .FLIST .RES1>
62 <AND <EMPTY? <SET RES1 <REST .RES1 2>>> <RETURN>>>
63 <COND (.GOTONE <AGAIN>)
64 (<NOT <EMPTY? .FLIST>> <SET FLIST <CORDER .FLIST>>)>
65 <SET TEM <REVERSE .RES>>
66 <COND (<NOT <EMPTY? .FLIST>>
69 <SET RES <REST .FLIST <- <LENGTH .FLIST> 1>>>)
72 <REST <PUTREST .RES .FLIST>
74 <COND (<EMPTY? .RES> <SET RES .RES2>)
75 (ELSE <PUTREST .RES .RES2> <SET RES .TEM>)>>
78 <DEFINE CALLME (ATM LST)
79 #DECL ((ATM) ATOM (LST) <LIST [REST <LIST [REST ATOM]> ATOM]>)
81 <AND <EMPTY? .LST> <RETURN <>>>
82 <AND <MEMQ .ATM <1 .LST>> <RETURN>>
83 <SET LST <REST .LST 2>>>>
85 <DEFINE CORDER (LST "AUX" (RES ()))
86 #DECL ((LST) <LIST [REST <LIST [REST ATOM]> ATOM]> (RES) LIST)
88 #DECL ((LS) <LIST [REST LIST ATOM]>)
89 <AND <EMPTY? .LS> <RETURN>>
90 <PUT .LS 1 <ALLREACH (<2 .LS>) <1 .LS> .LST>>
91 <SET LS <REST .LS 2>>>
93 #DECL ((PNT) <LIST [REST LIST ATOM]>)
94 <REPEAT ((SHORT <CHTYPE <MIN> FIX>) (TL 0) (LST .LST))
95 #DECL ((SHORT TL) FIX (LST) <LIST [REST LIST ATOM]>)
96 <AND <EMPTY? .LST> <RETURN>>
97 <COND (<L? <SET TL <LENGTH <1 .LST>>> .SHORT>
100 <SET LST <REST .LST 2>>>
102 (<COND (<1? <LENGTH <1 .PNT>>> <1 <1 .PNT>>)
105 <MAPF <> <FUNCTION (ATM) <SPLOUTEM .LST .ATM>> <1 .PNT>>
107 <COND (<SET TEM <MEMQ () .LST>>
108 <COND (<==? .TEM .LST> <SET LST <REST .TEM 2>>)
110 <PUTREST <PREV .LST .TEM>
113 <AND <EMPTY? .LST> <RETURN>>>
116 <DEFINE ALLREACH (LATM LST MLST)
117 #DECL ((LATM LST) <LIST [REST ATOM]>
118 (MLST) <LIST [REST <LIST [REST ATOM]> ATOM]>)
122 <COND (<MEMQ .ATM .LATM>)
125 <ALLREACH (.ATM !.LATM)
127 #DECL ((L) <LIST [REST LIST ATOM]>)
128 <AND <==? <2 .L> .ATM>
135 <DEFINE REMEMIT (ATM)
136 #DECL ((ATM) ATOM (FUNC) <SPECIAL ATOM>
137 (FUNCL) <SPECIAL <LIST [REST ATOM]>>)
140 <SET FUNCL (.ATM !.FUNCL)>>>
142 <DEFINE FINDREC (OBJ "AUX" (FM '<>))
144 <COND (<MONAD? .OBJ>)
145 (<AND <TYPE? .OBJ FORM SEGMENT>
146 <NOT <EMPTY? <SET FM <CHTYPE .OBJ FORM>>>>>
147 <COND (<AND <TYPE? <1 .FM> ATOM> <GASSIGNED? <1 .FM>>>
148 <AND <TYPE? ,<1 .FM> FUNCTION> <REMEMIT <1 .FM>>>
149 <AND <TYPE? ,<1 .FM> MACRO>
150 <NOT <EMPTY? ,<1 .FM>>>
151 <FINDREC <EMACRO .FM>>>
152 ;"Analyze expansion of MACRO call"
153 <AND <OR <==? ,<1 .FM> ,MAPF> <==? ,<1 .FM> ,MAPR>>
154 <NOT <LENGTH? .FM 3>>
156 <AND <TYPE? <2 .FM> FORM> <CHK-GVAL <2 .FM>>>
159 <AND <TYPE? <3 .FM> FORM>
160 <CHK-GVAL <3 .FM>>>>>)
161 (<STRUCTURED? <1 .OBJ>> <MAPF <> ,FINDREC <1 .OBJ>>)>
162 <COND (<EMPTY? <REST .OBJ>>)
163 (ELSE <MAPF <> ,FINDREC <REST .OBJ>>)>)
164 (ELSE <MAPF <> ,FINDREC .OBJ>)>>
166 <DEFINE EMACRO (OBJ "AUX" (ERR <CLASS "ERROR">) TEM)
167 <COND (.ERR <OFF .ERR>)>
169 <FUNCTION (FR "TUPLE" T)
170 <COND (<AND <GASSIGNED? MACACT> <LEGAL? ,MACACT>>
171 <DISMISS [!.T] ,MACACT>)
174 <COND (<TYPE? <SET TEM
175 <PROG MACACT () #DECL ((MACACT) <SPECIAL ANY>)
176 <SETG MACACT .MACACT>
180 <COND (.ERR <ON .ERR>)>
181 <ERROR " MACRO EXPANSION LOSSAGE " !.TEM>)
182 (ELSE <OFF "ERROR"> <AND .ERR <ON .ERR>> <1 .TEM>)>>
184 <DEFINE CHK-GVAL (FM) #DECL ((FM) FORM)
185 <AND <==? <LENGTH .FM> 2>
190 <OR <TYPE? ,<2 .FM> FUNCTION>
191 <AND <TYPE? ,<2 .FM> MACRO>
192 <NOT <EMPTY? ,<2 .FM>>>
193 <TYPE? <1 ,<2 .FM>> FUNCTION>>>
196 <DEFINE FINDEM (FUNC "AUX" (FUNCL ()))
197 #DECL ((FUNC) <SPECIAL ATOM> (FUNCL) <SPECIAL <LIST [REST ATOM]>>
198 (VALUE) <LIST [REST ATOM]>)
202 <DEFINE FINDEMALL (ATM
207 <LIST <LIST [REST ATOM]> ATOM>)
208 <AND <EMPTY? .ATM> <RETURN .TD>>
209 <SET TD (<FINDEM <1 .ATM>> <1 .ATM> !.TD)>
210 <SET ATM <REST .ATM>>>))
211 #DECL ((ATM) <<PRIMTYPE VECTOR> [REST ATOM]>
212 (TOPDO) <LIST <LIST [REST ATOM]> ATOM>)
213 <REPEAT ((TODO .TOPDO) (CURDO <1 .TOPDO>))
215 (CURDO) <LIST [REST ATOM]>)
216 <COND (<EMPTY? .CURDO>
217 <COND (<EMPTY? <SET TODO <REST .TODO 2>>>
219 (ELSE <SET CURDO <1 .TODO>> <AGAIN>)>)
220 (<MEMQ <1 .CURDO> .TOPDO>)
222 <PUTREST <REST .TODO <- <LENGTH .TODO> 1>>
223 (<FINDEM <1 .CURDO>> <1 .CURDO>)>)>
224 <SET CURDO <REST .CURDO>>>>
226 <DEFINE GETORDER ("TUPLE" ATMS)
227 #DECL ((ATMS) <TUPLE [REST ATOM]>)
228 <COND (<NOT <MEMQ #FALSE () <MAPF ,LIST ,CHECK .ATMS>>>
229 <ORDEREM <FINDEMALL .ATMS>>)
230 (ELSE <ERROR BAD-ARG GETORDER>)>>
234 <SET LIST_OF_FUNCTIONS