4 <EXTERNAL TOOL!-PACKAGE>
6 <DEFINE <ENTRY MESSAGE> (SEVERITY STR "TUPLE" TEXT)
13 <COND (<EMPTY? .TEXT> <RETURN 0>)
14 (<==? <TYPE <1 .TEXT>> ATOM> <PRINC <1 .TEXT>>)
15 (ELSE <PRIN1 <1 .TEXT>>)>
18 <COND (<==? .SEVERITY ERROR> <EXIT .COMPILER "COMPILATION ABORTED">)
19 (<==? .SEVERITY STOP> <LISTEN>)>>
23 <EXTERNAL OP!-PACKAGE GLOBAL!-PACKAGE>
25 <DEFINE BLOCK:INITIAL () 0>
27 <DEFINE BRANCH (TAG) <EMIT <INSTRUCTION JRST .TAG>>>
29 <DEFINE SUBR:CALL (ADR ARG-NUMBER) <EMIT <INSTRUCTION MCALL .ARG-NUMBER .ADR>>>
31 <DEFINE BINDINGS:INITIAL () 0>
33 <DEFINE BINDINGS:FINAL () 0>
35 <DEFINE TEST:TRUE (TAG)
36 <EMIT <INSTRUCTION HLRZ O* A>>
37 <EMIT <INSTRUCTION CAIE O* TFALSE>>
38 <EMIT <INSTRUCTION JRST .TAG>>>
40 <SETG INSTRUCTION #SUBR *000000402161*>
42 <DEFINE BINDING:INITIAL () 0>
44 <DEFINE BINDING:ATOM (ATM)
46 <EMIT <INSTRUCTION HRRI A* -1>>
49 <DEFINE TAGMAK ("OPTIONAL" (STR "TAG"))
50 <SET STR <STRING .STR <UNPARSE ,TAG:COUNT>>>
51 <SETG TAG:COUNT <+ ,TAG:COUNT 1>>
52 <OR <LOOKUP .STR <MOBLIST INITIAL>> <INSERT .STR <MOBLIST INITIAL>>>>
54 <DEFINE VARIABLES () ((REFERENCES ()) (CODING ()) (TAGS ()))>
56 <DEFINE STACK:ARGUMENT ()
57 <EMIT <INSTRUCTION PUSH TP* A>>
58 <EMIT <INSTRUCTION PUSH TP* B>>>
60 <DEFINE BINDING:FINAL ()
61 <EMIT <INSTRUCTION PUSH TP* [0]>>
62 <EMIT <INSTRUCTION PUSH TP* [0]>>
63 <EMIT <INSTRUCTION PUSHJ P* SPECBIND>>>
65 <DEFINE LABEL (TAG) <EMIT .TAG>>
68 <PUTREST .CODE:PTR (.INSTR)>
69 <SET CODE:PTR <REST .CODE:PTR>>>
71 <DEFINE TEST:ARG (NUMBER TAG)
72 <EMIT <INSTRUCTION HLRE C* AB>>
73 <EMIT <INSTRUCTION MOVMS C>>
74 <EMIT <INSTRUCTION CAIGE C* <* 2 .NUMBER>>>
75 <EMIT <INSTRUCTION JRST .TAG>>>
77 <DEFINE REFERENCE (OBJECT "EXTRA" TTYPE)
78 <COND (<AND!- <==? <PRIMTYPE .OBJECT> WORD>
80 <LOOKUP <STRING !"T <PNAME <TYPE .OBJECT>>>
81 <GET OP!-PACKAGE OBLIST>>>>
82 <EMIT <INSTRUCTION MOVSI A* .TTYPE>>
83 <EMIT <INSTRUCTION MOVE B* [.OBJECT]>>)
85 <SET OBJECT <FORM QUOTE .OBJECT>>
86 <EMIT <INSTRUCTION MOVE A* <FORM MQUOTE .OBJECT> -1>>
87 <EMIT <INSTRUCTION MOVE B* <FORM MQUOTE .OBJECT>>>)>>
89 <DEFINE FUNCTION:FINAL (PRINFLG)
90 <EMIT <INSTRUCTION JRST FINIS>>
91 <ASSEMBLE!-CODING <REST .CODE:TOP> .PRINFLG <MOBLIST INITIAL>>>
93 <DEFINE BINDING:VALUE () <STACK:ARGUMENT>>
95 <DEFINE BINDING:UNBOUND ()
96 <EMIT <INSTRUCTION MOVSI A* TUNBOUND>>
97 <EMIT <INSTRUCTION SETO B*>>
100 <DEFINE BINDING:ARG (NUMBER)
101 <EMIT <INSTRUCTION PUSH TP* (AB) <- <* .NUMBER 2> 2>>>
102 <EMIT <INSTRUCTION PUSH TP* (AB) <- <* .NUMBER 2> 1>>>>
104 <DEFINE TEST:FALSE (TAG)
105 <EMIT <INSTRUCTION HLRZ O* A>>
106 <EMIT <INSTRUCTION CAIN O* TFALSE>>
107 <EMIT <INSTRUCTION JRST .TAG>>>
111 <DEFINE FUNCTION:INITIAL (NAME) <EMIT <FORM TITLE .NAME>>>
113 <DEFINE BLOCK:FINAL () 0>
115 <FINISHUP <SETG INSTRUCTION ,FORM> <SETG TAG:COUNT 0>>
122 <DEFINE <ENTRY COMPILE> (NAME "OPTIONAL" (PFLG <>) "NAME" COMPILER)
123 <COND (<NOT <==? <TYPE .NAME> ATOM>>
124 <MESSAGE ERROR "ARGUMENT NOT ATOMIC">)
125 (<NOT <GASSIGNED? .NAME>>
126 <MESSAGE ERROR "GLOBALLY UNASSIGNED" .NAME>)
127 (<NOT <==? <TYPE ,.NAME> FUNCTION>>
128 <MESSAGE ERROR "IMPROPERLY VALUED" .NAME>)>
129 <PUT .NAME APPLY:OBJECT <GET RSUBR APPLY:TYPE>> ;"Recursive calls"
130 <SETG .NAME <COMPILE-FUNCTION ,.NAME .NAME>>
131 <PUT .NAME APPLY:OBJECT> ;"Remove"
132 <EXIT .COMPILER "DONE">>
135 <SUBR:CALL!-SETUP <PRIMTYPE .OBJ>
137 <IF <EMPTY? .OBJ> <RETURN .I>>
139 <STACK:ARGUMENT!-SETUP>
144 <DEFINE BINDINGS (ARGS "OPTIONAL" (MODE INITIAL) "NAME" BINDER)
145 <IF-NOT <==? <TYPE .ARGS> LIST> <MESSAGE ERROR "ILLEGAL ARGUMENT LIST" .ARGS>>
146 <IF <EMPTY? .ARGS> <EXIT .BINDER 0>>
147 <BINDINGS:INITIAL!-SETUP>
148 <REPEAT (ITEM DEFAULT:TAG GIVEN:TAG (ARG-NUMBER 1))
150 <COND (<==? <TYPE .ITEM> ATOM>
151 <COND (<==? .MODE INITIAL>
152 <BINDING:INITIAL!-SETUP>
153 <BINDING:ATOM!-SETUP .ITEM>
154 <BINDING:ARG!-SETUP .ARG-NUMBER>
155 <BINDING:FINAL!-SETUP>
158 <BINDING:INITIAL!-SETUP>
159 <BINDING:ATOM!-SETUP .ITEM>
160 <BINDING:UNBOUND!-SETUP>
161 <BINDING:FINAL!-SETUP>)
162 (<==? .MODE OPTIONAL>
163 <SET DEFAULT:TAG <TAGMAK!-SETUP>>
164 <SET GIVEN:TAG <TAGMAK!-SETUP>>
165 <BINDING:INITIAL!-SETUP>
166 <BINDING:ATOM!-SETUP .ITEM>
167 <TEST:ARG!-SETUP .ARG-NUMBER .DEFAULT:TAG>
168 <BINDING:ARG!-SETUP .ARG-NUMBER>
169 <BRANCH!-SETUP .GIVEN:TAG>
170 <LABEL!-SETUP .DEFAULT:TAG>
171 <BINDING:UNBOUND!-SETUP>
172 <LABEL!-SETUP .GIVEN:TAG>
173 <BINDING:FINAL!-SETUP>
175 (ELSE <MESSAGE WARNING "BINDING ATTEMPTED FOR" .ITEM .MODE>)>)
176 (<AND <==? <TYPE .ITEM> LIST> <==? <LENGTH .ITEM> 2>>
177 <COND (<==? .MODE EXTRA>
178 <BINDING:INITIAL!-SETUP>
179 <BINDING:ATOM!-SETUP <1 .ITEM>>
181 <BINDING:VALUE!-SETUP>
182 <BINDING:FINAL!-SETUP>)
183 (<==? .MODE OPTIONAL>
184 <SET DEFAULT:TAG <TAGMAK!-SETUP>>
185 <SET GIVEN:TAG <TAGMAK!-SETUP>>
186 <BINDING:INITIAL!-SETUP>
187 <BINDING:ATOM!-SETUP <1 .ITEM>>
188 <TEST:ARG!-SETUP .ARG-NUMBER .DEFAULT:TAG>
189 <BINDING:ARG!-SETUP .ARG-NUMBER>
190 <BRANCH!-SETUP .GIVEN:TAG>
191 <LABEL!-SETUP .DEFAULT:TAG>
193 <BINDING:VALUE!-SETUP>
194 <LABEL!-SETUP .GIVEN:TAG>
195 <BINDING:FINAL!-SETUP>
198 <MESSAGE ERROR "BINDING ATTEMPTED FOR" .ITEM>)>)
199 (<==? <TYPE .ITEM> STRING>
200 <COND (<=? .ITEM "OPTIONAL"> <SET MODE OPTIONAL>)
201 (<OR <=? .ITEM "EXTRA"> <=? .ITEM "AUX">>
204 <MESSAGE UNIMPLEMENTED "BINDINGS FOR" .ITEM>
206 (ELSE <MESSAGE UNIMPLEMENTED "BINDINGS FOR" .ITEM>)>
207 <IF <EMPTY? <CHOP ARGS>> <RETURN 0>>>
208 <BINDINGS:FINAL!-SETUP>>
210 <DEFINE COMPILE-FUNCTION (FUNCTN
211 "OPTIONAL" (NAME NOT-NAMED)
212 "EXTRA" (CODE:TOP!-SETUP (()))
213 (CODE:PTR!-SETUP .CODE:TOP!-SETUP)
215 <FUNCTION:INITIAL!-SETUP .NAME>
216 <IF <EMPTY? .FUNCTN> <MESSAGE ERROR "EMPTY FUNCTION">>
217 <IF <==? <TYPE <1 .FUNCTN>> ATOM> ;"Activation name ?"
218 <MESSAGE UNIMPLEMENTED "ACTIVATION NAMES">
220 <IF <EMPTY? .FUNCTN> <MESSAGE ERROR "NO ARGUMENT LIST">>
221 <BINDINGS <1 .FUNCTN>>
222 <IF <EMPTY? <CHOP FUNCTN>> <MESSAGE ERROR "EMPTY FUNCTION BODY">>
224 <COMP <1 .FUNCTN>> ;"Go do the real compilation for this object"
225 <CHOP FUNCTN> ;"Next object in the body"
226 <IF <EMPTY? .FUNCTN> <RETURN 0>>>
227 <FUNCTION:FINAL!-SETUP .PFLG>>
229 <DEFINE PROG-REPEAT (OB "EXTRA" (NAME <1 .OB>) AGAIN:TAG EXIT:TAG)
230 <BLOCK:INITIAL!-SETUP>
231 <IF <EMPTY? <CHOP OB>> <MESSAGE ERROR "EMPTY" .NAME>>
232 <IF <==? <TYPE <1 .OB>> ATOM>
233 <MESSAGE UNIMPLEMENTED "ACTIVATION TAGS">
235 <IF <EMPTY? .OB> <MESSAGE ERROR "NO VARIABLE LIST" .NAME>>
236 <BINDINGS <1 .OB> EXTRA>
237 <IF <EMPTY? <CHOP OB>> <MESSAGE ERROR "NO BODY FOR" .NAME>>
238 <LABEL!-SETUP <SET AGAIN:TAG <TAGMAK!-SETUP "AGAIN">>>
239 <SET EXIT:TAG <TAGMAK!-SETUP "EXIT">>
241 <IF <==? <TYPE <1 .OB>> ATOM> <LABEL!-SETUP <1 .OB>>>
243 <IF <EMPTY? <CHOP OB>> <RETURN 0>>>
244 <IF <==? .NAME REPEAT> <BRANCH!-SETUP .AGAIN:TAG>>
245 <LABEL!-SETUP .EXIT:TAG>
246 <BLOCK:FINAL!-SETUP>>
248 <DEFINE BOOL (PREDS TEST RESULT "EXTRA" (BOOL:TAG <TAGMAK!-SETUP "BOOL">))
249 <COND (<EMPTY? .PREDS> <COMP .RESULT>)
252 <SET RESULT <1 .PREDS>>
253 <IF <EMPTY? <CHOP PREDS>> <RETURN BOOL>>
257 <LABEL!-SETUP .BOOL:TAG>)>>
259 <DEFINE COMP (OBJECT)
260 <<OR <GET .OBJECT THIS:OBJECT>
261 ;"Is there some function to compile this object ?"
262 <GET <TYPE .OBJECT> THIS:TYPE>
263 ;"Is there some function for this type ?"
267 <FINISHUP <PUT VECTOR THIS:TYPE ,COPY>
268 <PUT UVECTOR THIS:TYPE ,COPY>
269 <PUT LIST THIS:TYPE ,COPY>
270 <PUT SEGMENT THIS:TYPE <FUNCTION (OBJ) <MESSAGE UNIMPLEMENTED "SEGMENT" .OBJ>>>
271 <PUT '<> THIS:OBJECT <FUNCTION (OBJ) <REFERENCE!-SETUP #FALSE ()>>>
273 THIS:TYPE ;"FORMs are compiled specially"
277 <<OR <GET .APPLY APPLY:OBJECT>
278 ;"Do we know how to apply this ?"
279 <GET <TYPE .APPLY> APPLY:TYPE>
281 <GET <PRIMTYPE .APPLY> APPLY:PRIMTYPE>
284 <REFERENCE!-SETUP .OBJECT>
285 ;"Otherwise go to eval with form"
286 <STACK:ARGUMENT!-SETUP>
287 <SUBR:CALL!-SETUP EVAL 1>>>
290 APPLY:TYPE ;"Apply an ATOM as you would apply its value"
292 <COND (<GASSIGNED? .APPLY>
293 ;"Try again with the global value if possible"
295 <AGAIN .APPLICATION>)
296 (<AND <BOUND? .APPLY> <ASSIGNED? .APPLY>>
297 ;"Else with local value"
298 <MESSAGE NOTE "LOCAL VALUE USED FOR" .APPLY>
300 <AGAIN .COMPILE-APPLY>)
302 <MESSAGE NOTE "NO VALUE FOR" .APPLY>
303 <REFERENCE!-SETUP .OB>
304 ;"Otherwise go to EVAL with the form"
305 <STACK:ARGUMENT!-SETUP>
306 <SUBR:CALL!-SETUP EVAL 1>)>>>
310 <SUBR:CALL!-SETUP <1 .OB>
312 <IF <EMPTY? <CHOP OB>> <RETURN .I>>
314 <STACK:ARGUMENT!-SETUP>
319 <COMP <1 .OB>> ;"Get atomic name of RSUBR"
320 <STACK:ARGUMENT!-SETUP>
321 <SUBR:CALL!-SETUP GVAL 1>
322 <STACK:ARGUMENT!-SETUP>
323 <SUBR:CALL!-SETUP APPLY
325 <IF <EMPTY? <CHOP OB>> <RETURN .I>>
327 <STACK:ARGUMENT!-SETUP>
330 APPLY:TYPE ;"Integer as function is a selector of component"
332 <IF <NOT <==? <LENGTH .OB> 2>>
333 <MESSAGE ERROR "IMPROPER SELECTOR" .OB>>
334 <COMP <2 .OB>> ;"Get the structure"
335 <STACK:ARGUMENT!-SETUP>
336 <COMP .APPLY> ;"Get the indicator"
337 <STACK:ARGUMENT!-SETUP>
338 <SUBR:CALL!-SETUP NTH 2>>>
339 <PUT ,PROG APPLY:OBJECT ,PROG-REPEAT>
340 <PUT ,REPEAT APPLY:OBJECT ,PROG-REPEAT>
344 <IF-NOT <==? <LENGTH .OB> 2>
345 <MESSAGE ERROR "WRONG NUMBER OF ARGUMENTS TO RETURN">>
347 <BRANCH!-SETUP .EXIT:TAG>>>
351 <COND (<EMPTY? <CHOP OB>> <BRANCH!-SETUP .AGAIN:TAG>)
352 (<==? <LENGTH .OB> 1>
354 <STACK:ARGUMENT!-SETUP>
355 <SUBR:CALL!-SETUP AGAIN 1>)
356 (ELSE <MESSAGE ERROR "TOO MANY ARGUMENTS TO AGAIN">)>>>
360 <IF <NOT <==? <LENGTH .OB> 2>>
361 <MESSAGE ERROR "NO TAG IN GO">>
362 <BRANCH!-SETUP <2 .OB>>>>
365 <FUNCTION (OB "EXTRA" (COND:TAG <TAGMAK!-SETUP "COND">))
366 <IF <EMPTY? <CHOP OB>> <MESSAGE ERROR "EMPTY COND">>
367 <REPEAT (PHRASE PHRASE:TAG)
368 <SET PHRASE:TAG <TAGMAK!-SETUP "PHRASE">>
369 <IF <EMPTY? <SET PHRASE <1 .OB>>>
370 <MESSAGE ERROR "MISSING PREDICATE IN COND">>
372 <TEST:FALSE!-SETUP .PHRASE:TAG>
374 <IF <EMPTY? <CHOP PHRASE>> <RETURN 0>>
376 <BRANCH!-SETUP .COND:TAG>
377 <LABEL!-SETUP .PHRASE:TAG>
378 <IF <EMPTY? <CHOP OB>> <RETURN 0>>>
379 <LABEL!-SETUP .COND:TAG>>>
382 <FUNCTION (OB) <BOOL <REST .OB> ,TEST:TRUE!-SETUP T>>>
385 <FUNCTION (OB) <BOOL <REST .OB> ,TEST:FALSE!-SETUP #FALSE ()>>>>
390 \f\f\ 3\f\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f