19 <USE "GC-DUMP" "CHKDCL" "COMPDEC" "MIMGEN" "ADVMESS" "CDRIVE">
21 " This file contains the first pass of the MUDDLE compiler.
22 The functions therein take a MUDDLE function and build a more detailed
23 model of it. Each entity in the function is represented by an object
24 of type NODE. The entire function is represented by the functions node
25 and it points to the rest of the nodes for the function."
27 " Nodes vary in complexity and size depending on what they represent.
28 A function or prog/repeat node is contains more information than a node
29 for a quoted object. All nodes have some fields in common to allow
30 general programs to traverse the model."
32 " The model built by PASS1 is used by the analyzer (SYMANA), the
33 variable allocator (VARANA) and the code generator (CODGEN). In some
34 cases the analyzers and generators for certain classes of SUBRs are
35 together in their own files (e.g. CARITH, STRUCT, ISTRUC)."
37 " This the top level program for PASS1. It takes a function as
38 input and returns the data structure representing the model."
40 <COND (<NOT ,MIM> <SETG PMAX ,NUMPRI!-MUDDLE>)>
46 <COND (<NOT ,MIM> <FLOAD "PRCOD.NBIN">)>
48 <DEFINE PASS1 (FNAME FUNC
49 "AUX" RESULT (VARTBL ,LVARTBL) (DCL #DECL ()) (ARGL ())
50 (HATOM <>) (TT ()) (FCN .FUNC) TEM (RQRG 0) (TRG 0))
51 #DECL ((FUNC) FUNCTION (VARTBL) <SPECIAL SYMTAB> (FNAME) <SPECIAL ATOM>
52 (FCN) <PRIMTYPE LIST> (ARGL TT) LIST (RESULT) <SPECIAL NODE>
53 (RQRG TRG) <SPECIAL FIX>)
54 <COND (<EMPTY? .FCN> <COMPILE-ERROR "Empty function: " .FNAME>)>
55 <COND (<TYPE? <1 .FCN> ATOM ADECL>
57 <SET FCN <REST .FCN>>)>
58 <COND (<EMPTY? .FCN> <COMPILE-ERROR "Empty function: " .FNAME>)>
61 <COND (<AND <NOT <EMPTY? .FCN>> <TYPE? <1 .FCN> DECL>>
63 <SET FCN <REST .FCN>>)>
64 <COND (<EMPTY? .FCN> <COMPILE-ERROR "Function has no body: " .FNAME>)>
66 <NODEF ,FUNCTION-CODE () <FIND_DECL VALUE .DCL> .FNAME ()
67 () () .HATOM .VARTBL 0 0>>
68 <GEN-D .ARGL .DCL .HATOM .RESULT>
69 <PUTPROP .FNAME .IND .RESULT>
72 ("VALUE" <RESULT-TYPE .RESULT> !<RSUBR-DECLS .RESULT>)>
73 <PUT .RESULT ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .RESULT>> .FCN>>
74 <ACT-FIX .RESULT <BINDING-STRUCTURE .RESULT>>
76 <PUTPROP .FNAME RSUB-DEC <RSUBR-DECLS .RESULT>>
79 "Vector of legal strings in decl list."
95 <PROG ((N <LENGTH ,TOT-MODES>))
97 <FUNCTION (S "AUX" (ATM <PARSE <STRING "ACODE-" .S>>))
102 <SET N <+ <LENGTH ,TOT-MODES> 1>>
104 <FUNCTION (ATM) <SETG .ATM .N> <MANIFEST .ATM> <SET N <+ .N 1>>>
105 '[ACODE-INIT ACODE-INIT1 ACODE-ERR ACODE-NORM]>>
107 "Amount to rest off decl vector after each encounter."
109 <SETG RESTS ![1 1 1 2 1 2 1 2 1 2 1 1]>
111 " This function (and others on this page) take an arg list and
112 decls and parses them.
114 1) An RSUBR decl list.
116 2) A machine readable binding specification.
118 Atoms are also entered into the symbol table."
120 <DEFINE GEN-D (ARGL DCL HATOM FCNNOD
121 "AUX" (SVTBL .VARTBL) (RES_TOP (())) (RES_BOT .RES_TOP) (ARGN 1)
122 (BNDL_TOP (())) (BNDL_BOT .BNDL_TOP) TIX VIX
123 (MODE ,TOT-MODES) (ST <>) T T1 SVT (IX ,ACODE-INIT))
124 #DECL ((BNDL_BOT RES_BOT) <SPECIAL LIST> (BNDL_TOP RES_TOP) LIST
125 (ARGN) <SPECIAL FIX> (VIX) <VECTOR [REST STRING]>
126 (MODE) <SPECIAL <VECTOR [REST STRING]>> (IX) <SPECIAL FIX>
127 (ARGL) LIST (SVTBL SVT) SYMTAB (DCL) <SPECIAL <PRIMTYPE LIST>>)
129 <COND (<EMPTY? .ARGL> <RETURN>)>
130 <COND (<TYPE? <SET T <1 .ARGL>> ATOM FORM LIST ADECL>
132 <RUN-ARGER .IX .T .FCNNOD>)
135 <COMPILE-ERROR "Two arg list strings in a row: "
139 <COND (<NOT <SET TIX <MEMBER .T .MODE>>>
140 <COMPILE-ERROR "Unrecognized arg list string: "
144 <REST .MODE <NTH ,RESTS <SET IX <LENGTH .VIX>>>>>
145 <COND (<NOT <OR <L? .IX 7> <G? .IX 11>>>
146 <PUT-RES (<COND (<=? <1 .ARGL> "OPT"> "OPTIONAL")
147 (ELSE <1 .ARGL>)>)>)>)
149 <COMPILE-ERROR "Unknown type of object in arglist "
151 <SET ARGL <REST .ARGL>>>
152 <COND (.HATOM <ACT-D .HATOM>)>
154 #DECL ((DC1) FORM (DC) ANY (VARTBL) <SPECIAL SYMTAB>)
155 <COND (<EMPTY? .DCL> <RETURN>)
156 (<EMPTY? <REST .DCL>>
157 <COMPILE-ERROR "DECL in bad format (no DECL for): "
160 <COND (<AND <TYPE? .DC FORM>
162 <==? <LENGTH .DC1> 2>
163 <OR <==? <1 .DC1> SPECIAL>
164 <==? <1 .DC1> UNSPECIAL>>>
168 <COND (<NOT <OR <==? .ATM VALUE>
170 <ADDVAR .ATM T -1 0 T .DC <> <>>)>>
171 <CHTYPE <1 .DCL> LIST>>
172 <SET DCL <REST .DCL 2>>>
175 <COND (<N==? .SVTBL .SVT>
178 <COND (<==? <NEXT-SYM .SV> .SVTBL>
179 <PUT .SV ,NEXT-SYM .VARTBL>
182 (ELSE <SET SV <NEXT-SYM .SV>>)>>)>
183 <AND <L? <SET TRG <- .ARGN 1>> 0> <SET RQRG -1>>
184 <PUT .FCNNOD ,BINDING-STRUCTURE <REST .BNDL_TOP>>
185 <COND (<==? <NODE-TYPE .FCNNOD> ,FUNCTION-CODE>
186 <PUT <PUT <PUT .FCNNOD ,REQARGS .RQRG> ,TOTARGS .TRG>
189 <PUT .FCNNOD ,SYMTAB .VARTBL>>
191 "RUN-ARGER dispatches to different arg handlers"
193 <DEFINE RUN-ARGER (INDX ARG N)
197 (,ACODE-BIND <BIND-D .ARG>)
198 (,ACODE-CALL <CALL-D .ARG>)
199 (,ACODE-OPT <OPT-D .ARG>)
200 (,ACODE-OPTIONAL <OPT-D .ARG>)
201 (,ACODE-ARGS <ARGS-D .ARG>)
202 (,ACODE-TUPLE <TUPL-D .ARG>)
203 (,ACODE-AUX <AUX-D .ARG>)
204 (,ACODE-EXTRA <AUX-D .ARG>)
205 (,ACODE-ACT <ACT-D .ARG>)
206 (,ACODE-NAME <ACT-D .ARG>)
207 (,ACODE-INIT <INIT-D .ARG>)
208 (,ACODE-INIT1 <INIT1-D .ARG>)
209 (,ACODE-NORM <NORM-D .ARG>)
210 (,ACODE-DECL <DECL-D .ARG>)
211 (,ACODE-VALUE <VDECL-D .ARG .N>)
212 (,ACODE-ERR <ERR-D .ARG>)>>
214 <DEFINE SRCH-SYM (ATM "AUX" (TB .VARTBL))
215 #DECL ((ATM) ATOM (TB) <PRIMTYPE VECTOR>)
217 <COND (<EMPTY? .TB> <RETURN <>>)>
218 <COND (<==? .ATM <NAME-SYM .TB>> <RETURN .TB>)>
219 <SET TB <NEXT-SYM .TB>>>>
221 "This function used for normal args when \"BIND\" and \"CALL\" still possible."
224 #DECL ((MODE) <VECTOR STRING>)
225 <SET MODE <REST .MODE>>
228 "This function for normal args when \"CALL\" still possible."
230 <DEFINE INIT1-D (OBJ)
231 #DECL ((MODE) <VECTOR STRING>)
232 <SET MODE <REST .MODE>>
236 "Handle a normal argument or quoted normal argument."
238 <DEFINE NORM-D (OBJ "OPTIONAL" DC "AUX" DC1)
239 #DECL ((RQRG ARGN) FIX (DCL) DECL)
240 <COND (<TYPE? .OBJ LIST>
241 <COMPILE-ERROR "LIST not in OPT(IONAL) or AUX: " .OBJ>)>
242 <COND (<TYPE? .OBJ ATOM>
243 <PUT-RES (<PUT-DCL ,ARGL-ARG
246 <COND (<ASSIGNED? DC> .DC)
247 (ELSE <FIND_DECL .OBJ .DCL>)>
250 <COND (<N==? <LENGTH .OBJ> 2>
251 <COMPILE-ERROR "Bad ADECL: " .OBJ>)>
252 <NORM-D <1 .OBJ> <2 .OBJ>>)
253 (<SET OBJ <QUOTCH .OBJ>>
254 <COND (<TYPE? .OBJ ADECL>
255 <COND (<N==? <LENGTH .OBJ> 2>
256 <COMPILE-ERROR "Bad ADECL: " .OBJ>)>
263 <COND (<ASSIGNED? DC> .DC)
264 (<ASSIGNED? DC1> .DC1)
265 (ELSE <FIND_DECL .OBJ .DCL>)>
267 <COND (<NOT <ASSIGNED? DC>>
268 <SET ARGN <+ .ARGN 1>>
269 <SET RQRG <+ .RQRG 1>>)>>
271 "Handle \"BIND\" decl."
273 <DEFINE BIND-D (OBJ "AUX" DC)
274 #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
275 <COND (<TYPE? .OBJ ADECL>
276 <COND (<N==? <LENGTH .OBJ> 2>
277 <COMPILE-ERROR "Bad ADECL: " .OBJ>)>
280 <COND (<NOT <TYPE? .OBJ ATOM>>
281 <COMPILE-ERROR "Bad object after \"BIND\": " .OBJ>)>
286 <COND (<ASSIGNED? DC> .DC) (ELSE <FIND_DECL .OBJ .DCL>)>
288 <TYPE-ATOM-OK? .DC FRAME .OBJ>
289 <SET IX ,ACODE-INIT1>>
291 "Handle \"CALL\" decl."
293 <DEFINE CALL-D (OBJ "AUX" DC)
294 #DECL ((TYP) ATOM (RQRG ARGN) FIX (DCL) DECL)
295 <SET RQRG <+ .RQRG 1>>
296 <COND (<TYPE? .OBJ ADECL>
297 <COND (<N==? <LENGTH .OBJ> 2>
298 <COMPILE-ERROR "Bad ADECL: " .OBJ>)>
301 <COND (<NOT <TYPE? .OBJ ATOM>>
302 <COMPILE-ERROR "Bad object after \"CALL\": " .OBJ>)>
307 <COND (<ASSIGNED? DC> .DC)
308 (ELSE <FIND_DECL .OBJ .DCL>)>
310 <TYPE-ATOM-OK? .DC FORM .OBJ>
311 <SET ARGN <+ .ARGN 1>>
314 "Flush on extra atoms after \"CALL\", \"ARGS\" etc."
316 <DEFINE ERR-D (OBJ) <COMPILE-ERROR "Bad DECL syntax: " .OBJ>>
318 "Handle \"OPTIONAL\" decl."
320 <DEFINE OPT-D (OBJ "AUX" DC OBJ1)
321 #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
322 <COND (<TYPE? .OBJ ADECL>
323 <COND (<N==? <LENGTH .OBJ> 2>
324 <COMPILE-ERROR "Bad ADECL: " .OBJ>)>
327 <COND (<TYPE? .OBJ ATOM>
328 <PUT-RES (<PUT-DCL ,ARGL-OPT
331 <COND (<ASSIGNED? DC> .DC)
332 (ELSE <FIND_DECL .OBJ .DCL>)>
335 <SET OBJ <QUOTCH .OBJ>>
336 <COND (<TYPE? .OBJ ADECL>
337 <COND (<N==? <LENGTH .OBJ> 2>
338 <COMPILE-ERROR "Bad ADECL: " .OBJ>)>
345 <COND (<ASSIGNED? DC> .DC)
346 (ELSE <FIND_DECL .OBJ .DCL>)>
348 (<TYPE? <SET OBJ1 <LISTCH .OBJ>> ATOM ADECL>
349 <COND (<TYPE? .OBJ1 ADECL>
350 <COND (<N==? <LENGTH .OBJ1> 2>
351 <COMPILE-ERROR "Bad ADECL: " .OBJ1>)>
353 <SET OBJ1 <1 .OBJ1>>)>
354 <PUT-RES (<PAUX .OBJ1
355 <2 <CHTYPE .OBJ LIST>>
356 <COND (<ASSIGNED? DC> .DC)
357 (ELSE <FIND_DECL .OBJ1 .DCL>)>
360 <SET OBJ1 <QUOTCH .OBJ1>>
361 <COND (<TYPE? .OBJ1 ADECL>
362 <COND (<N==? <LENGTH .OBJ1> 2>
363 <COMPILE-ERROR "Bad ADECL: " .OBJ1>)>
365 <SET OBJ1 <1 .OBJ1>>)>
368 <2 <CHTYPE .OBJ LIST>>
369 <COND (<ASSIGNED? DC> .DC)
370 (ELSE <FIND_DECL .OBJ1 .DCL>)>
372 (ELSE <COMPILE-ERROR "Bad use of \"OPT(IONAL)\": " .OBJ>)>
373 <SET ARGN <+ .ARGN 1>>>
375 "Handle \"ARGS\" decl."
377 <DEFINE ARGS-D (OBJ "AUX" DC)
378 #DECL ((TYP) ATOM (RQRG ARGN) FIX (DCL) DECL (BNDL_BOT) <LIST SYMTAB>)
379 <COND (<TYPE? .OBJ ADECL>
380 <COND (<N==? <LENGTH .OBJ> 2>
381 <COMPILE-ERROR "Bad ADECL: " .OBJ>)>
384 <COND (<NOT <TYPE? .OBJ ATOM>>
385 <COMPILE-ERROR "Bad use of \"ARGS\": " .OBJ>)>
390 <COND (<ASSIGNED? DC> .DC)
391 (ELSE <FIND_DECL .OBJ .DCL>)>
393 <TYPE-ATOM-OK? .DC LIST .OBJ>
395 <SET ARGN <+ .ARGN 1>>>
397 "Handle \"TUPLE\" decl."
399 <DEFINE TUPL-D (OBJ "AUX" DC)
400 #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
401 <COND (<TYPE? .OBJ ADECL>
402 <COND (<N==? <LENGTH .OBJ> 2>
403 <COMPILE-ERROR "Bad ADECL: " .OBJ>)>
406 <COND (<NOT <TYPE? .OBJ ATOM>>
407 <COMPILE-ERROR "Bad use of \"TUPLE\": " .OBJ>)>
412 <COND (<ASSIGNED? DC> .DC)
413 (ELSE <FIND_DECL .OBJ .DCL>)>
415 <TYPE-ATOM-OK? .DC TUPLE .OBJ>
418 "Handle \"AUX\" decl."
420 <DEFINE AUX-D (OBJ "AUX" DC OBJ1)
421 #DECL ((ARGN) FIX (DCL) DECL)
422 <COND (<TYPE? .OBJ ADECL>
423 <COND (<N==? <LENGTH .OBJ> 2>
424 <COMPILE-ERROR "Bad ADECL: " .OBJ>)>
427 <COND (<TYPE? .OBJ ATOM>
431 <COND (<ASSIGNED? DC> .DC)
432 (ELSE <FIND_DECL .OBJ .DCL>)>
434 (<AND <TYPE? .OBJ LIST> <TYPE? <SET OBJ1 <LISTCH .OBJ>> ADECL ATOM>>
435 <COND (<TYPE? .OBJ1 ADECL>
436 <COND (<N==? <LENGTH .OBJ1> 2>
437 <COMPILE-ERROR "Bad ADECL: " .OBJ1>)>
439 <SET OBJ1 <1 .OBJ1>>)>
442 <COND (<ASSIGNED? DC> .DC) (ELSE <FIND_DECL .OBJ1 .DCL>)>
444 (ELSE <COMPILE-ERROR "Bad usage of \"AUX\" : " .OBJ>)>>
446 "Handle \"NAME\" and \"ACT\" decl."
448 <DEFINE ACT-D (OBJ "AUX" DC)
449 #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
450 <COND (<TYPE? .OBJ ADECL>
451 <COND (<N==? <LENGTH .OBJ> 2>
452 <COMPILE-ERROR "Bad ADECL: " .OBJ>)>
455 <COND (<NOT <TYPE? .OBJ ATOM>>
456 <COMPILE-ERROR "Bad use of \"ACT\": " .OBJ>)>
461 <COND (<ASSIGNED? DC> .DC) (ELSE <FIND_DECL .OBJ .DCL>)>
463 <TYPE-ATOM-OK? .DC FRAME .OBJ>>
465 "Fixup activation atoms after node generated."
467 <DEFINE ACT-FIX (N L "AUX" (FLG <>))
468 #DECL ((N) NODE (L) <LIST [REST SYMTAB]>)
471 <COND (<EMPTY? .L> <RETURN .FLG>)>
472 <COND (<AND <==? <CODE-SYM <SET SYM <1 .L>>> ,ARGL-ACT>
474 <NOT <SPEC-SYM .SYM>>>
475 <PUT .SYM ,RET-AGAIN-ONLY .N>)>
479 <COND (<TYPE? .ARG ADECL>
480 <COND (<NOT <SRCH-SYM <1 .ARG>>>
481 <ADDVAR <1 .ARG> T -1 0 T <2 .ARG> <> <>>)>)
483 <COMPILE-ERROR "DECL in bad format (no DECL for): " .ARG>)>>
485 <DEFINE VDECL-D (ARG N)
487 <PUT .N ,RESULT-TYPE .ARG>
488 <PUT .N ,INIT-DECL-TYPE .ARG>>
490 <GDECL (TOT-MODES) <VECTOR [REST STRING]> (RESTS) <UVECTOR [REST FIX]>>
492 "Check for quoted arguments."
495 #DECL ((OB) FORM (VALUE) <OR ATOM ADECL>)
496 <COND (<AND <==? <LENGTH .OB> 2>
498 <TYPE? <2 .OB> ATOM ADECL>>
500 (ELSE <COMPILE-ERROR "Bad form in argument list" .OB> T)>>
502 "Chech for (arg init) or ('arg init)."
506 <COND (<AND <==? <LENGTH .OB> 2>
507 <OR <TYPE? <1 .OB> ATOM ADECL>
508 <AND <TYPE? <1 .OB> FORM> <QUOTCH <1 .OB>>>>>
510 (ELSE <COMPILE-ERROR "Bad list in arg list: " .OB> T)>>
512 "Add a decl to RSUBR decls and update AC call spec."
515 #DECL ((L) LIST (RES_BOT) LIST)
516 <SET RES_BOT <REST <PUTREST .RES_BOT .L> <LENGTH .L>>>
519 "Add code to set up a certain kind of argument."
521 <DEFINE PUT-DCL (COD ATM VAL DC COM "AUX" SPC DC1 TT SYM)
522 #DECL ((DC1) FORM (ATM) ATOM (BNDL_BOT BNDL_TOP TT) LIST (COD) FIX
524 <COND (<AND <TYPE? .DC FORM>
526 <==? <LENGTH .DC1> 2>
527 <OR <SET SPC <==? <1 .DC1> SPECIAL>>
528 <==? <1 .DC1> UNSPECIAL>>>
530 (ELSE <SET SPC .GLOSP>)>
531 <SET SYM <ADDVAR .ATM .SPC .COD .ARGN T .DC <> .VAL>>
532 <SET BNDL_BOT <REST <PUTREST .BNDL_BOT (.SYM)>>>
535 "Find decl associated with a variable, if none, use ANY."
537 <DEFINE FIND_DECL (ATM "OPTIONAL" (DC .DECLS))
538 #DECL ((DC) <PRIMTYPE LIST> (ATM) ATOM)
541 <COND (<OR <EMPTY? .DC> <EMPTY? <SET TT <REST .DC>>>>
543 <COND (<NOT <TYPE? <1 .DC> LIST>>
544 <COMPILE-ERROR "Malformed DECL: " .DC>)>
545 <COND (<MEMQ .ATM <CHTYPE <1 .DC> LIST>> <RETURN <1 .TT>>)>
546 <SET DC <REST .TT>>>>
548 "Add an AUX variable spec to structure."
551 '[VECTOR UVECTOR STRING BYTES ISTRING IBYTES IVECTOR IUVECTOR]>
553 <GDECL (OBJ-BUILDERS) <VECTOR [REST ATOM]>>
555 <DEFINE PAUX (ATM OBJ DC NTUP "AUX" EV TT AP OBJ2 AP2)
556 #DECL ((EV TT) NODE (TUP NTUP) FIX (ATM) ATOM)
557 <COND (<PROG ((OBJ .OBJ))
558 <AND <TYPE? .OBJ FORM>
560 <COND (<OR <AND <==? <SET AP <1 .OBJ>> STACK>
561 <==? <LENGTH .OBJ> 2>
562 <OR <AND <TYPE? <SET OBJ2 <2 .OBJ>> FORM>
564 <MEMQ <1 .OBJ2> ,OBJ-BUILDERS>>
565 <TYPE? .OBJ2 VECTOR UVECTOR>>>
566 <AND <==? .AP CHTYPE>
567 <==? <LENGTH .OBJ> 3>
568 <TYPE? <SET OBJ2 <2 .OBJ>> FORM>
569 <==? <LENGTH .OBJ2> 2>
570 <==? <1 .OBJ2> STACK>
571 <OR <AND <TYPE? <SET OBJ2 <2 .OBJ2>> FORM>
573 <MEMQ <1 .OBJ2> ,OBJ-BUILDERS>>
574 <TYPE? .OBJ2 VECTOR UVECTOR>>
575 <SET OBJ2 <CHTYPE (CHTYPE .OBJ2 <3 .OBJ>)
577 <SET TT <NODEFM ,STACK-CODE () <> STACK () STACK>>
578 <PUT .TT ,KIDS (<PCOMP .OBJ2 .TT>)>)
590 <FUNCTION (O) <PCOMP .O .TT>>
594 #DECL ((PARENT) <SPECIAL ANY>)
596 <PSTRUC .OBJ ITUPLE ITUPLE TUPLE>>>)
597 (<AND <TYPE? .AP ATOM>
600 <SET OBJ <EXPAND .OBJ>>
602 (ELSE <SET TT <PCOMP .OBJ ()>>)>
603 <PUT-DCL .NTUP .ATM .TT .DC <>>>
605 "Main dispatch function during pass1."
607 <DEFINE PCOMP (OBJ PARENT)
608 #DECL ((PARENT) <SPECIAL ANY> (VALUE) NODE)
609 <APPLY <OR <GETPROP .OBJ PTHIS-OBJECT>
610 <GETPROP <TYPE .OBJ> PTHIS-TYPE>
614 "Build a node for <> or #FALSE ()."
618 <NODE1 ,QUOTE-CODE .PARENT BOOL-FALSE <> ()>>
620 <COND (<GASSIGNED? FALSE-QT> <PUTPROP '<> PTHIS-OBJECT ,FALSE-QT>)>
622 "Build a node for ()."
624 <DEFINE NIL-QT (O) #DECL ((VALUE) NODE) <NODE1 ,QUOTE-CODE .PARENT LIST () ()>>
626 <COND (<GASSIGNED? NIL-QT> <PUTPROP () PTHIS-OBJECT ,NIL-QT>)>
628 "Build a node for a LIST, VECTOR or UVECTOR."
638 #DECL ((VALUE) NODE (TT) NODE)
639 <PUT .TT ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>>
641 <COND (<GASSIGNED? PCOPY>
642 <PUTPROP VECTOR PTHIS-TYPE ,PCOPY>
643 <PUTPROP UVECTOR PTHIS-TYPE ,PCOPY>
644 <PUTPROP LIST PTHIS-TYPE ,PCOPY>)>
646 "Build a node for unknown things."
648 <DEFINE PDEFAULT (OBJ)
650 <NODE1 ,QUOTE-CODE .PARENT <TYPE .OBJ> .OBJ ()>>
652 "Further analyze a FORM and build appropriate node."
655 #DECL ((OBJ) <FORM ANY> (VALUE) NODE)
656 <PROG APPLICATION ((APPLY <1 .OBJ>))
657 #DECL ((APPLICATION) <SPECIAL ANY> (APPLY) <SPECIAL ANY>)
658 <APPLY <OR <GETPROP .APPLY PAPPLY-OBJECT>
659 <AND <GETPROP .APPLY ANALYSIS> ,PSUBR-C>
660 <GETPROP <TYPE .APPLY> PAPPLY-TYPE>
665 <COND (<GASSIGNED? PFORM> <PUTPROP FORM PTHIS-TYPE ,PFORM>)>
667 "Build a SEGMENT node."
669 <DEFINE SEG-FCN (OBJ "AUX" (TT <NODE1 ,SEGMENT-CODE .PARENT <> <> ()>))
670 #DECL ((TT VALUE PARENT) NODE)
671 <PROG ((PARENT .TT)) #DECL ((PARENT) <SPECIAL NODE>)
672 <PUT .TT ,KIDS (<PFORM <CHTYPE .OBJ FORM>>)>>>
674 <COND (<GASSIGNED? SEG-FCN> <PUTPROP SEGMENT PTHIS-TYPE ,SEG-FCN>)>
676 "Analyze a form or the form <ATM .....>"
678 <DEFINE ATOM-FCN (OB AP:ATOM "AUX" L:<PRIMTYPE LIST>)
679 #DECL ((AP) ATOM (VALUE) NODE)
680 <COND (<GASSIGNED? .AP> <SET APPLY ,.AP> <AGAIN .APPLICATION>)
682 <COND (<NOT <GASSIGNED? REFERENCED>>
683 <SETG REFERENCED (.AP 1)>)
684 (<NOT <SET L <MEMQ .AP ,REFERENCED:LIST>>>
685 <SETG REFERENCED (.AP 1 !,REFERENCED)>)
687 <2 .L <+ <2 .L>:FIX 1>>)>
690 <COMPILE-WARNING "No value for: " .AP " using EVAL">
693 <COND (<GASSIGNED? ATOM-FCN> <PUTPROP ATOM PAPPLY-TYPE ,ATOM-FCN>)>
695 "Expand MACRO and process result."
697 <NEWTYPE FUNNY VECTOR>
699 <DEFINE PMACRO (OBJ AP "AUX" ERR TEM)
700 <ON <SET ERR <HANDLER "ERROR" ,MACROERR 100>>> ;"Turn On new Error"
703 #DECL ((MACACT) <SPECIAL ANY>)
705 <SETG MACACT .MACACT>
707 <OFF .ERR> ;"Turn OFF new Error"
708 <COND (<TYPE? .TEM FUNNY>
709 <COMPILE-ERROR "ERROR during macro expansion" ,CR !.TEM>)
710 (ELSE <PCOMP .TEM .PARENT>)>>
712 <COND (<GASSIGNED? PMACRO> <PUTPROP MACRO PAPPLY-TYPE ,PMACRO>)>
714 <DEFINE MACROERR (IGN FR "TUPLE" T)
716 <COND (<AND <NOT <EMPTY? .T>> <==? <1 .T> CONTROL-G!-ERRORS>>
722 (<AND <GASSIGNED? MACACT> <LEGAL? ,MACACT>>
723 <DISMISS <CHTYPE [!.T] FUNNY> ,MACACT>)
726 <ERROR INTERNAL-COMPILER-LOSSAGE!-ERRORS>)>>
728 "Build a node for a form whose 1st element is a form (could be NTH)."
730 <DEFINE PFORM-FORM (OBJ AP "AUX" TT)
731 #DECL ((TT) NODE (VALUE) NODE (OBJ) FORM)
732 <COND (<AND <==? <LENGTH .OBJ> 2> <NOT <SEG? .OBJ>>>
733 <SET TT <NODEFM ,FORM-F-CODE .PARENT <> .OBJ () .AP>>
734 <PUT .TT ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>)
735 (ELSE <PAPDEF .OBJ .AP>)>>
737 <COND (<GASSIGNED? PFORM-FORM> <PUTPROP FORM PAPPLY-TYPE ,PFORM-FORM>)>
739 "Build a node for strange forms."
741 <DEFINE PAPDEF (OBJ AP)
743 <COMPILE-WARNING "Form not being compiled: " .OBJ>
745 <NODEFM ,FORM-CODE .PARENT <> .OBJ () .AP>>
747 "For objects that require EVAL, make sure all atoms used are special."
749 <DEFINE SPECIALIZE (OBJ "AUX" T1 T2 SYM OB)
750 #DECL ((T1) FIX (OB) FORM (T2) <OR FALSE SYMTAB>)
751 <COND (<AND <TYPE? .OBJ FORM SEGMENT>
752 <SET OB <CHTYPE .OBJ FORM>>
753 <OR <AND <==? <SET T1 <LENGTH .OB>> 2>
755 <TYPE? <SET SYM <2 .OB>> ATOM>>
758 <TYPE? <SET SYM <2 .OB>> ATOM>>>
759 <SET T2 <SRCH-SYM .SYM>>>
760 <COND (<NOT <SPEC-SYM .T2>>
761 <COMPILE-NOTE "Redclared special: " .SYM>
762 <PUT .T2 ,SPEC-SYM T>)>)>
763 <COND (<MEMQ <PRIMTYPE .OBJ> '[FORM LIST UVECTOR VECTOR]>
764 <MAPF <> ,SPECIALIZE .OBJ>)>>
766 "Build a MSUBR call node."
768 <DEFINE PSUBR-C (OBJ AP
773 <COND (<TYPE? .AP MSUBR> <2 .AP>)
777 #DECL ((TT) NODE (VALUE) NODE (OBJ) FORM)
778 <PUT .TT ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> <REST .OBJ>>>>
780 <DEFINE LVAL-FCN (OBJ "AUX" (TT <NODEFM ,SUBR-CODE .PARENT <> LVAL () ,LVAL>))
781 #DECL ((TT VALUE) NODE)
782 <PUT .TT ,KIDS (<PCOMP <CHTYPE .OBJ ATOM> .TT>)>>
784 <DEFINE GVAL-FCN (OBJ "AUX" (TT <NODEFM ,SUBR-CODE .PARENT <> GVAL () ,GVAL>))
785 #DECL ((TT VALUE) NODE)
786 <PUT .TT ,KIDS (<PCOMP <CHTYPE .OBJ ATOM> .TT>)>>
788 <COND (<GASSIGNED? LVAL-FCN>
789 <PUTPROP LVAL PTHIS-TYPE ,LVAL-FCN>
790 <PUTPROP GVAL PTHIS-TYPE ,GVAL-FCN>)>
792 <DEFINE FIX-FCN (OBJ AP "AUX" TT (LN <LENGTH .OBJ>))
793 #DECL ((TT VALUE) NODE (OBJ) FORM)
794 <COND (<NOT <OR <==? .LN 2> <==? .LN 3>>>
796 "Number (FIX) applied to other than 2 or 3 args: "
802 <COND (<==? .LN 2> INTH) (ELSE IPUT)>
804 <COND (<==? .LN 2> ,NTH) (ELSE ,PUT)>>>
807 (<PCOMP <2 .OBJ> .TT>
809 !<COND (<==? .LN 2> ()) (ELSE (<PCOMP <3 .OBJ> .TT>))>)>>
811 <COND (<GASSIGNED? FIX-FCN>
812 <PUTPROP FIX PAPPLY-TYPE ,FIX-FCN>
813 <PUTPROP OFFSET PAPPLY-TYPE ,FIX-FCN>)>
817 <DEFINE PPROG-REPEAT (OBJ AP
818 "AUX" (NAME <1 .OBJ>) TT (DCL #DECL ()) (HATOM <>) ARGL
820 (IN-IFSYS <COND (<ASSIGNED? IN-IFSYS> .IN-IFSYS)>))
821 #DECL ((OBJ) <PRIMTYPE LIST> (TT) NODE (VALUE) NODE (DCL) DECL
822 (ARGL) LIST (VARTBL) <SPECIAL SYMTAB> (IN-IFSYS) <SPECIAL ANY>)
823 <COND (<EMPTY? <SET OBJ <REST .OBJ>>>
824 <COMPILE-ERROR "Empty " .NAME " " .OBJ>)>
825 <COND (<TYPE? <1 .OBJ> ATOM ADECL>
827 <SET OBJ <REST .OBJ>>)>
829 <SET OBJ <REST .OBJ>>
830 <COND (<AND <NOT <EMPTY? .OBJ>> <TYPE? <1 .OBJ> DECL>>
832 <SET OBJ <REST .OBJ>>)>
833 <COND (<EMPTY? .OBJ> <COMPILE-ERROR "Empty body for " .NAME .OBJ>)>
837 <FIND_DECL VALUE .DCL>
844 <GEN-D <COND (<AND <NOT <EMPTY? .ARGL>> <TYPE? <1 .ARGL> STRING>>
846 (ELSE ("AUX" !.ARGL))>
850 <ACT-FIX .TT <BINDING-STRUCTURE .TT>>
851 <PUT .TT ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>
854 <COND (<GASSIGNED? PPROG-REPEAT>
855 <PUTPROP ,PROG PAPPLY-OBJECT ,PPROG-REPEAT>
856 <PUTPROP ,REPEAT PAPPLY-OBJECT ,PPROG-REPEAT>
857 <PUTPROP ,BIND PAPPLY-OBJECT ,PPROG-REPEAT>)>
861 <DEFINE UNWIND-FCN (OBJ AP
863 <NODEFM ,UNWIND-CODE .PARENT <> <1 .OBJ> () .AP>))
864 #DECL ((PARENT VALUE TT) NODE (OBJ) FORM)
865 <COND (<==? <LENGTH .OBJ> 3>
866 <PUT .TT ,KIDS (<PCOMP <2 .OBJ> .TT> <PCOMP <3 .OBJ> .TT>)>)
867 (ELSE <COMPILE-ERROR "Wrong number of args to UNIWND: " .OBJ>)>>
869 <COND (<AND <GASSIGNED? UNWIND-FCN> <GASSIGNED? UNWIND>>
870 <PUTPROP ,UNWIND PAPPLY-OBJECT ,UNWIND-FCN>)>
872 "Build a node for a COND."
874 <DEFINE COND-FCN (OBJ AP
875 "AUX" (PARENT <NODECOND ,COND-CODE .PARENT <> COND ()>))
876 #DECL ((PARENT) <SPECIAL NODE> (OBJ) <FORM ANY> (VALUE) NODE)
880 <FUNCTION (CLA "AUX" (TT <NODEB ,BRANCH-CODE .PARENT <> <> ()>))
882 <COND (<AND <TYPE? .CLA LIST> <NOT <EMPTY? .CLA>>>
883 <PUT .TT ,PREDIC <PCOMP <1 .CLA> .TT>>
887 <FUNCTION (O) <PCOMP .O .TT>>
891 "COND clause not a LIST or empty: "
895 <COND (<GASSIGNED? COND-FCN>
896 <PUTPROP ,COND PAPPLY-OBJECT ,COND-FCN>
897 <PUTPROP ,AND PAPPLY-OBJECT ,PSUBR-C>
898 <PUTPROP ,OR PAPPLY-OBJECT ,PSUBR-C>)>
900 "Build a node for '<
\b-object>
\b-."
902 <DEFINE QUOTE-FCN (OBJ AP "AUX" (TT <NODE1 ,QUOTE-CODE .PARENT <> () ()>))
903 #DECL ((TT VALUE) NODE (OBJ) FORM)
904 <COND (<NOT <EMPTY? <REST .OBJ>>>
905 <PUT .TT ,RESULT-TYPE <COND (<==? <2 .OBJ> #FALSE()>
907 (ELSE <TYPE <2 .OBJ>>)>>
908 <PUT .TT ,NODE-NAME <2 .OBJ>>)>>
910 <COND (<GASSIGNED? QUOTE-FCN> <PUTPROP ,QUOTE PAPPLY-OBJECT ,QUOTE-FCN>)>
912 "Build a node for a call to an RSUBR."
914 <DEFINE RSUBR-FCN (OBJ AP
916 <NODEFM ,RSUBR-CODE .PARENT <> <1 .OBJ> () .AP>))
917 #DECL ((OBJ) FORM (AP) MSUBR (PARENT) <SPECIAL NODE>
919 <COND (<AND <G? <LENGTH .AP> 2> <TYPE? <3 .AP> DECL LIST>>
920 <PUT .PARENT ,KIDS <PRSUBR-C <1 .OBJ> .OBJ <3 .AP>>>
921 <PUT .PARENT ,TYPE-INFO <SANITIZE-DECL <3 .AP>>>)
922 (ELSE <PSUBR-C .OBJ .AP>)>>
924 <COND (<GASSIGNED? RSUBR-FCN> <PUTPROP MSUBR PAPPLY-TYPE ,RSUBR-FCN>)>
926 <DEFINE SANITIZE-DECL (DCL:LIST "AUX" (OPT <>) (TUPF <>))
927 <COND (<=? <1 .DCL> "VALUE"> <SET DCL <REST .DCL 2>>)>
928 <MAPF ,LIST <FUNCTION (EL)
929 <COND (<OR <=? .EL "QUOTE"> <=? .EL "ARGS">> <MAPRET>)
930 (<OR <=? .EL "OPT"> <=? .EL "OPTIONAL">>
933 (<=? .EL "TUPLE"> <SET TUPF T> <MAPRET>)>
934 <COND (.TUPF (TUPLE .EL))
935 (.OPT (OPTIONAL .EL))
936 (ELSE (NORMAL .EL))>>
939 "Predicate: any segments in this object?"
942 #DECL ((OB) <PRIMTYPE LIST>)
944 <COND (<EMPTY? .OB> <RETURN <>>)>
945 <COND (<TYPE? <1 .OB> SEGMENT> <RETURN T>)>
946 <SET OB <REST .OB>>>>
948 "Analyze a call to an MSUBR with decls checking number of args and types wherever
953 "AUX" (DOIT ,INIT-R) (SEGSW <>) (SGD '<>) (SGP '(1)) SGN
954 (IX 0) DC (RM ,RMODES) (ARG-NUMBER 0) (KDS (()))
955 (TKDS .KDS) RMT (OB <REST .OBJ>) (ST <>) (ODC "FOO"))
956 #DECL ((TKDS KDS) <SPECIAL LIST> (OB) LIST (OBJ) <SPECIAL <PRIMTYPE LIST>>
957 (RM) <SPECIAL <VECTOR [REST STRING]>> (ARG-NUMBER) FIX
958 (RDCL) <SPECIAL <PRIMTYPE LIST>> (DOIT SEGSW) <SPECIAL ANY> (IX) FIX
959 (RSB NAME) <SPECIAL ANY> (SGD) FORM (SGP) <LIST ANY> (SGN) NODE)
962 (<NOT <EMPTY? .RDCL>>
963 <COND (<NOT <EMPTY? .RM>> <SET DC <1 .RDCL>> <SET RDCL <REST .RDCL>>)>
966 <COND (<=? .DC "OPT"> <SET DC "OPTIONAL">)>
967 <COND (<NOT <SET RMT <MEMBER .DC .RM>>>
968 <COMPILE-ERROR "Unknown string in MSUBR decl: "
973 <SET DOIT <NTH ,RDOIT <SET IX <LENGTH .RM>>>>
974 <SET ST <APPLY <NTH ,SDOIT .IX> .ST .DC .ODC>>
976 <COND (<EMPTY? .RM> ;"TUPLE seen."
977 <SET DC <GET-ELE-TYPE <1 .RDCL> ALL>>)>)
980 <AND <L? <LENGTH .RM> 4> <RETURN <REST .TKDS>>>
981 <COMPILE-ERROR "Too few arguments to: " .NAME " " .OBJ>)
985 <PUTREST .SGP ([REST .DC])>
986 <PUT .SGN ,RESULT-TYPE <TYPE-AND <RESULT-TYPE .SGN> .SGD>>
987 <RETURN <REST .TKDS>>)
988 (ELSE <SET SGP <REST <PUTREST .SGP (.DC)>>>)>)
989 (<TYPE? <1 .OB> SEGMENT>
990 <SET KDS <REST <PUTREST .KDS (<SET SGN <SEGCHK <1 .OB>>>)>>>
996 <SEGCH1 .DC <RESULT-TYPE .SGN> <1 .OB>>>
997 <RETURN <REST .TKDS>>)
998 (ELSE <SET SEGSW T>)>)
1003 <FUNCTION (O "AUX" TT)
1004 <SET TT <PCOMP .O .PARENT>>
1008 (<==? <NODE-TYPE .TT> ,SEGMENT-CODE>
1010 (<NOT <TYPE-OK? <RESULT-TYPE <1 <KIDS .TT>>>
1011 <FORM '<OR MULTI STRUCTURED> [REST .DC]>>>
1012 <COMPILE-ERROR "Argument wrong type to: "
1016 <COND (<NOT <TYPE-OK? <RESULT-TYPE .TT> .DC>>
1017 <COMPILE-ERROR "Argument wrong type to: "
1020 <COND (<NOT <RESULT-TYPE .TT>>
1021 <PUT .TT ,RESULT-TYPE .DC>)>)>)>
1024 <RETURN <REST .TKDS>>)>
1025 <SET SGP <REST <CHTYPE <SET SGD <FORM STRUCTURED .DC>> LIST>>>
1028 (<SET KDS <REST <PUTREST .KDS (<APPLY .DOIT .DC .OB>)>>>
1030 <SET ARG-NUMBER <+ .ARG-NUMBER 1>>
1032 (<EMPTY? .OB> <RETURN <REST .TKDS>>)
1036 <COND (<RESULT-TYPE .SGN> <TYPE-AND <RESULT-TYPE .SGN> .SGD>)
1038 <RETURN <REST .TKDS>>)
1040 <FUNCTION (X) <COND (<NOT <TYPE? .X SEGMENT>> <MAPLEAVE <>>)> T>
1042 <SET KDS <REST <PUTREST .KDS (<SET SGN <SEGCHK <1 .OB>>>)>>>
1043 <RETURN <REST .TKDS>>)
1044 (ELSE <COMPILE-ERROR "Too many arguments too: " .NAME " " .OBJ>)>>>
1046 <DEFINE SQUOT (F S1 S2) T>
1048 "Flush one possible decl away."
1050 <DEFINE CHOPPER (F S1 S2)
1051 #DECL ((RM) <VECTOR [REST STRING]>)
1053 <COMPILE-ERROR "Two DECL strings in a row in: " .S1 " " .S2>)>
1057 "Handle Normal arg when \"VALUE\" still possible."
1059 <DEFINE INIT-R (DC OB)
1060 #DECL ((RM) <VECTOR [REST STRING]>)
1061 <SET RM <REST .RM 2>>
1065 "Handle Normal arg when \"CALL\" still possible."
1067 <DEFINE INIT2-R (DC OB)
1068 #DECL ((RM) <VECTOR [REST STRING]>)
1073 "Handle normal arg."
1075 <DEFINE INIT1-R (DC OB "AUX" TT)
1076 #DECL ((TT) NODE (OB) LIST)
1077 <COND (<NOT <TYPE-OK? <RESULT-TYPE <SET TT <PCOMP <1 .OB> .PARENT>>>
1079 <COMPILE-ERROR "Argument wrong type to: " .NAME " " <1 .OB>>)>
1080 <COND (<NOT <RESULT-TYPE .TT>> <PUT .TT ,RESULT-TYPE .DC>)>
1083 "Handle \"QUOTE\" arg."
1085 <DEFINE QINIT-R (DC OB "AUX" TT)
1086 #DECL ((TT) NODE (OB) LIST)
1087 <COND (<NOT <TYPE-OK?
1088 <RESULT-TYPE <SET TT
1095 <COMPILE-ERROR "Argument wrong type to: " .NAME " " <1 .OB>>)>
1099 "Handle \"CALL\" decl."
1101 <DEFINE CAL-R (DC OB "AUX" TT)
1102 #DECL ((TKDS KDS) LIST (TT) NODE)
1103 <COND (<NOT <TYPE-OK?
1104 <RESULT-TYPE <SET TT
1111 <COMPILE-ERROR "Argument wrong type to: " .NAME " " <1 .OB>>)>
1112 <PUTREST .KDS (.TT)>
1113 <RETURN <REST .TKDS> .RSB>>
1115 "Handle \"ARGS\" decl."
1117 <DEFINE ARGS-R (DC OB "AUX" TT)
1118 #DECL ((TT) NODE (KDS TKDS) LIST)
1119 <COND (<NOT <TYPE-OK?
1120 <RESULT-TYPE <SET TT
1127 <COMPILE-ERROR "Argument wrong type to: " .NAME " " <1 .OB>>)>
1128 <PUTREST .KDS (.TT)>
1129 <RETURN <REST .TKDS> .RSB>>
1131 "Handle \"TUPLE\" decl."
1133 <DEFINE TUPL-R (DC OB "AUX" TT)
1134 #DECL ((OB) LIST (TT) NODE)
1135 <COND (<NOT <TYPE-OK? <RESULT-TYPE <SET TT <PCOMP <1 .OB> .PARENT>>>
1137 <COMPILE-ERROR "Argument wrong type to: " .NAME " " <1 .OB>>)>
1138 <COND (<NOT <RESULT-TYPE .TT>> <PUT .TT ,RESULT-TYPE .DC>)>
1141 "Handle stuff with segments in arguments."
1143 <DEFINE SEGCHK (OB "AUX" TT)
1145 <COND (<NOT <TYPE-OK? <RESULT-TYPE <SET TT <PCOMP .OB .PARENT>>>
1146 '<OR MULTI STRUCTURED>>>
1147 <COMPILE-ERROR "Non-structured segment? " .OB>)>
1150 <DEFINE SEGCH1 (DC RT OB)
1151 <COND (<NOT <TYPE-AND .RT <FORM '<OR MULTI STRUCTURED> [REST .DC]>>>
1152 <COMPILE-ERROR "Argument wrong type to: " .NAME " " .OB>)>>
1154 "Handle \"VALUE\" chop decl and do the rest."
1156 <DEFINE VAL-R (F S1 S2)
1157 #DECL ((RDCL) <PRIMTYPE LIST> (PARENT) NODE)
1158 <CHOPPER .F .S1 .S2>
1159 <PUT .PARENT ,RESULT-TYPE <1 .RDCL>>
1161 <SET F <TYPE? <1 .RDCL> STRING>>
1162 <SET RDCL <REST .RDCL>>
1165 <DEFINE ERR-R (DC OB)
1166 <COMPILE-LOSSAGE "Entered MSUBR application illegal state" .DC .OB>>
1168 <SETG RMODES ["VALUE" "CALL" "QUOTE" "OPTIONAL" "QUOTE" "ARGS" "TUPLE"]>
1170 <COND (<GASSIGNED? TUPL-R>
1171 <SETG RDOIT [,TUPL-R ,ARGS-R ,QINIT-R ,INIT1-R ,QINIT-R ,CAL-R ,ERR-R]>
1173 [,CHOPPER ,CHOPPER ,SQUOT ,CHOPPER ,SQUOT ,CHOPPER ,VAL-R]>)>
1175 <GDECL (RMODES) <VECTOR [REST STRING]> (RDOIT SDOIT) VECTOR>
1177 "Create a node for a call to a function."
1179 <DEFINE PFUNC (OB AP "AUX" TEM NAME)
1180 #DECL ((OB) <PRIMTYPE LIST> (VALUE) NODE)
1181 <COND (<TYPE? <1 .OB> ATOM>
1182 <COND (<==? <1 .OB> .FNAME> <RSUBR-CALL2 ,<1 .OB> <1 .OB> .OB>)
1183 (<SET TEM <GETPROP <1 .OB> RSUB-DEC>>
1184 <RSUBR-CALL3 .TEM <1 .OB> .OB>)
1185 (.REASONABLE <PSUBR-C .OB DUMMY>)
1187 <COMPILE-WARNING "Uncompiled function called: "
1189 <PAPDEF .OB ,<1 .OB>>)>)
1190 (<TYPE? <1 .OB> FUNCTION>
1191 <SET NAME <MAKE-TAG <STRING "ANONF" <SPNAME .FNAME>>>>
1192 <ANONF .NAME <1 .OB>>
1193 <RSUBR-CALL1 ,.NAME .NAME .OB>)>>
1195 "Call compiler recursively to compile anonymous function."
1197 <DEFINE ANONF (NAME BODY "AUX" (INT? <>) T GROUP-NAME)
1198 #DECL ((EXTRA-CODE) <LIST ANY> (VALUE) NODE)
1199 <COMPILE-NOTE "Compiling anonymous function">
1201 <PUTREST .EXTRA-CODE <APPLY ,COMPILE .NAME>>
1202 <SET EXTRA-CODE <REST .EXTRA-CODE <- <LENGTH .EXTRA-CODE> 1>>>
1204 <COMPILE-NOTE "Finished anonymous function">
1205 <PCOMP <FORM GVAL .NAME> .PARENT>>
1207 "#FUNCTION (....) compiler -- call ANONF."
1209 <DEFINE FCN-FCN (OB "AUX" (NAME <MAKE-TAG <STRING "ANONF" <SPNAME .FNAME>>>))
1212 <COND (<GASSIGNED? FCN-FCN>
1213 <PUTPROP FUNCTION PTHIS-TYPE ,FCN-FCN>
1214 <PUTPROP FUNCTION PAPPLY-TYPE ,PFUNC>)>
1216 "<FUNCTION (..) ....> compiler -- call ANONF."
1218 <DEFINE FCN-FCN1 (OB AP "AUX"
1219 (NAME <MAKE-TAG <STRING "ANONF" <SPNAME .FNAME>>>))
1220 #DECL ((OB) <PRIMTYPE LIST>)
1221 <ANONF .NAME <CHTYPE <REST .OB> FUNCTION>>>
1223 <COND (<GASSIGNED? FCN-FCN1> <PUTPROP ,FUNCTION PAPPLY-OBJECT ,FCN-FCN1>)>
1225 "Handle RSUBR that is really a function."
1227 <DEFINE RSUBR-CALL2 (BODY NAME OBJ
1230 <NODEFM ,RSUBR-CODE .PARENT <> .NAME () .BODY>))
1231 #DECL ((PARENT) <SPECIAL NODE> (VALUE) NODE)
1236 <SET DCL <RSUBR-DECLS <SET ACF <GETPROP .NAME .IND>>>>>>
1237 <PUT .PARENT ,TYPE-INFO <SANITIZE-DECL .DCL>>>
1239 "Handle an RSUBR that is already an RSUBR."
1241 <DEFINE RSUBR-CALL1 (BODY NAME OBJ
1243 <NODEFM ,RSUBR-CODE .PARENT <> .NAME () .BODY>))
1244 #DECL ((BODY) <PRIMTYPE LIST> (PARENT) <SPECIAL NODE> (VALUE) NODE)
1245 <PUT .PARENT ,KIDS <PRSUBR-C .NAME .OBJ <3 .BODY>>>
1246 <PUT .PARENT ,TYPE-INFO <SANITIZE-DECL <2 .BODY>>>>
1248 <DEFINE RSUBR-CALL3 (DC NAME OBJ
1250 <NODEFM ,RSUBR-CODE .PARENT <> .NAME () FOO>))
1251 #DECL ((PARENT) <SPECIAL NODE> (VALUE) NODE)
1252 <PUT .PARENT ,KIDS <PRSUBR-C .NAME .OBJ .DC>>
1253 <PUT .PARENT ,TYPE-INFO <SANITIZE-DECL .DC>>>
1255 ;"ILIST, ISTRING, IVECTOR AND IUVECTOR"
1257 <DEFINE PLIST (O A) <PSTRUC .O .A ILIST LIST>>
1259 <DEFINE PIVECTOR (O A) <PSTRUC .O .A IVECTOR VECTOR>>
1261 <DEFINE PISTRING (O A) <PSTRUC .O .A ISTRING STRING>>
1263 <DEFINE PIUVECTOR (O A) <PSTRUC .O .A IUVECTOR UVECTOR>>
1265 <DEFINE PIFORM (O A) <PSTRUC .O .A IFORM FORM>>
1267 <DEFINE PIBYTES (O A) <PSTRUC .O .A IBYTES BYTES>>
1269 <COND (<GASSIGNED? PLIST>
1270 <PUTPROP ,ILIST PAPPLY-OBJECT ,PLIST>
1271 <PUTPROP ,IUVECTOR PAPPLY-OBJECT ,PIUVECTOR>
1272 <COND (<NOT ,MIM> <PUTPROP ,IFORM PAPPLY-OBJECT ,PIFORM>)>
1273 <PUTPROP ,IBYTES PAPPLY-OBJECT ,PIBYTES>
1274 <PUTPROP ,IVECTOR PAPPLY-OBJECT ,PIVECTOR>
1275 <PUTPROP ,ISTRING PAPPLY-OBJECT ,PISTRING>)>
1277 <DEFINE PSTRUC (OBJ AP NAME TYP
1278 "AUX" (TT <NODEFM ,ISTRUC-CODE .PARENT .TYP .NAME () ,.NAME>)
1279 (LN <LENGTH .OBJ>) N EV SIZ)
1280 #DECL ((VALUE N EV TT) NODE (LN) FIX (OBJ) <PRIMTYPE LIST>)
1281 <COND (<SEG? .OBJ> <RSUBR-FCN .OBJ .AP>)
1284 <COMPILE-ERROR "Too few args: " <1 .OBJ>>)
1285 (<G? .LN 3> <COMPILE-ERROR "Too many args: "
1287 <SET N <PCOMP <2 .OBJ> .TT>>
1289 <SET EV <PCOMP <3 .OBJ> .PARENT>>
1290 <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
1291 <SET EV <PCOMP <NODE-NAME .EV> .TT>>
1292 <PUT .TT ,NODE-TYPE ,ISTRUC2-CODE>)>)
1293 (ELSE <PUT .TT ,NODE-TYPE ,ISTRUC2-CODE>)>
1294 <PUT .TT ,RESULT-TYPE .TYP>
1295 <COND (<ASSIGNED? EV> <PUT .TT ,KIDS (.N .EV)>)
1296 (ELSE <PUT .TT ,KIDS (.N)>)>)>>
1298 "READ, READCHR, READSTRING, NEXTCHR, READB, GET, GETL, GETPROP, GETPL"
1300 <PUTPROP ,READ PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A READ 2 ANY>>>
1302 <COND (<NOT <GASSIGNED? READ-INTERNAL>> <SETG READ-INTERNAL (1)>)>
1304 <PUTPROP ,READ-INTERNAL
1306 <FUNCTION (O A) <CHANFCNS .O .A READ-INTERNAL 2 ANY>>>
1308 <COND (<GASSIGNED? GC-READ>
1311 <FUNCTION (O A) <CHANFCNS .O .A GC-READ 2 ANY>>>)>
1315 <FUNCTION (O A) <CHANFCNS .O .A READCHR 2 ANY>>>
1319 <FUNCTION (O A) <CHANFCNS .O .A NEXTCHR 2 ANY>>>
1321 <PUTPROP ,READB PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A READB 4 ANY>>>
1323 <PUTPROP ,READSTRING
1325 <FUNCTION (O A) <CHANFCNS .O .A READSTRING 4 ANY>>>
1327 <DEFINE CHANFCNS (OBJ AP NAME ARGN TYP "AUX" TT (LN <LENGTH .OBJ>) N (TEM 0))
1328 #DECL ((VALUE) NODE (TT) NODE (N) <LIST [REST NODE]> (LN) FIX (TEM ARGN) FIX
1329 (OBJ) <PRIMTYPE LIST>)
1331 (<OR <SEG? .OBJ> <L? <- .LN 1> .ARGN>> <RSUBR-FCN .OBJ .AP>)
1333 <SET TT <NODEFM ,READ-EOF-CODE .PARENT .TYP .NAME () ,.NAME>>
1336 <FUNCTION (OB "AUX" (EV <PCOMP .OB .TT>))
1338 <COND (<==? <SET TEM <+ .TEM 1>> .ARGN>
1339 <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
1340 <SET EV <PCOMP <NODE-NAME .EV> .TT>>
1341 <PUT .TT ,NODE-TYPE ,READ-EOF2-CODE>)>
1350 <PUT .TT ,KIDS .N>)>>
1352 <PUTPROP ,GETPROP PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GETPROP>>>
1354 '<PUTPROP ,GETPL PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GETPL>>>
1356 <DEFINE GETFCNS (OBJ AP NAME "AUX" EV TEM T2 (LN <LENGTH .OBJ>) TT)
1357 #DECL ((OBJ) FORM (LN) FIX (TT VALUE TEM T2 EV) NODE)
1358 <COND (<OR <AND <N==? .LN 4> <N==? .LN 3>> <SEG? .OBJ>>
1359 <RSUBR-FCN .OBJ .AP>)
1361 <SET TT <NODEFM ,GET-CODE .PARENT ANY .NAME () ,.NAME>>
1362 <SET TEM <PCOMP <2 .OBJ> .TT>>
1363 <SET T2 <PCOMP <3 .OBJ> .TT>>
1365 <PUT .TT ,NODE-TYPE ,GET2-CODE>
1366 <PUT .TT ,KIDS (.TEM .T2)>)
1368 <SET EV <PCOMP <4 .OBJ> .TT>>
1369 <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
1370 <SET EV <PCOMP <NODE-NAME .EV> .TT>>
1371 <PUT .TT ,NODE-TYPE ,GET2-CODE>)>
1372 <PUT .TT ,KIDS (.TEM .T2 .EV)>)>
1375 <DEFINE ARGCHK (GIV REQ NAME OBJ "AUX" (HI .REQ) (LO .REQ))
1376 #DECL ((GIV) FIX (REQ HI LO) <OR <LIST FIX FIX> FIX>)
1377 <COND (<TYPE? .REQ LIST> <SET HI <2 .REQ>> <SET LO <1 .REQ>>)>
1378 <COND (<L? .GIV .LO>
1379 <COMPILE-ERROR "Too few arguments to: " .NAME .OBJ>)
1381 <COMPILE-ERROR "Too many arguments to: " .NAME .OBJ>)>
1386 <DEFINE PMAPF-R (OB AP
1387 "AUX" (NAME <1 .OB>) TT ITRF OBJ (RQRG 0)
1388 (LN <LENGTH <SET OBJ <REST .OB>>>) FINALF TAPL (APL ())
1389 (DCL #DECL ()) (ARGL ()) (HATOM <>) (NN 0) TEM L2 L3
1391 #DECL ((OBJ OB) <PRIMTYPE LIST> (LN NN) FIX (DCL) DECL (ARGL APL) LIST
1392 (ITRF FINALF TT) NODE (TRG RQRG) <SPECIAL FIX>)
1394 <COND (<L? .LN 2> <COMPILE-ERROR "Too few arguments: " .NAME .OBJ>)>
1395 <SET TT <NODEFM ,MAP-CODE .PARENT <> .NAME () .AP>>
1396 <SET FINALF <PCOMP <1 .OBJ> .TT>>
1398 (<OR <TYPE? <SET TAPL <2 .OBJ>> FUNCTION>
1399 <AND <TYPE? .TAPL FORM>
1400 <NOT <EMPTY? <SET APL <CHTYPE .TAPL LIST>>>>
1401 <TYPE? <SET TEM <1 .APL>> ATOM>
1403 <==? ,.TEM ,FUNCTION>
1404 <SET TAPL <REST .APL>>>>
1405 <COND (<EMPTY? <SET APL <CHTYPE .TAPL LIST>>>
1406 <COMPILE-ERROR "MAPF/R function is empty: " .OBJ>)>
1407 <COND (<TYPE? <1 .APL> ATOM ADECL>
1408 <SET HATOM <1 .APL>>
1409 <SET APL <REST .APL>>)>
1410 <COND (<OR <EMPTY? .APL> <NOT <TYPE? <1 .APL> LIST>>>
1411 <COMPILE-ERROR "MAPF/R function lacks arg list: " .OBJ>)>
1413 <SET APL <REST .APL>>
1414 <COND (<AND <NOT <EMPTY? .APL>> <TYPE? <1 .APL> DECL>>
1416 <SET APL <REST .APL>>)>
1417 <COND (<EMPTY? .APL>
1418 <COMPILE-ERROR "MAPF/R function has no body: " .OBJ>)>
1419 <PROG ((VARTBL .VARTBL))
1420 #DECL ((VARTBL) <SPECIAL SYMTAB>)
1424 <OR <FIND_DECL VALUE .DCL> ANY>
1431 <GEN-D .ARGL .DCL .HATOM .ITRF>
1433 (<ACT-FIX .ITRF <BINDING-STRUCTURE .ITRF>>
1434 <SET L3 <SET L2 ()>>
1438 <REPEAT ((L <BINDING-STRUCTURE .ITRF>) (LL .L) (L1 .L) SYM)
1439 #DECL ((L L1 LL) <LIST [REST SYMTAB]>)
1440 <AND <EMPTY? .L> <RETURN .L1>>
1442 (<==? <CODE-SYM <SET SYM <1 .L>>> 1>
1443 <SET L2 ("ACT" <NAME-SYM .SYM> !.L2)>
1446 <COND (<SPEC-SYM .SYM>
1447 <FORM SPECIAL <DECL-SYM .SYM>>)
1448 (ELSE <FORM UNSPECIAL <DECL-SYM .SYM>>)>
1450 <COND (<==? .L .L1> <SET L1 <REST .L1>>)
1451 (ELSE <PUTREST .LL <REST .L>>)>)>
1452 <SET L <REST <SET LL .L>>>>>
1453 <SET APL (<FORM PROG .L2 <CHTYPE .L3 DECL> !.APL>)>)>
1454 <PUT .ITRF ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .ITRF>> .APL>>>)
1455 (<OR <AND <TYPE? .TAPL FIX> <==? .LN 3>>
1456 <AND <OR <AND <TYPE? .TAPL FORM>
1457 <==? <LENGTH <SET APL <CHTYPE .TAPL LIST>>> 2>
1458 <TYPE? <SET TEM <1 .APL>> ATOM>
1461 <TYPE? <SET TEM <2 .APL>> ATOM>>
1462 <AND <TYPE? .TAPL GVAL>
1463 <SET TEM <CHTYPE .TAPL ATOM>>>>
1465 <AND <GASSIGNED? .TEM>
1466 <OR <NOT <TYPE? ,.TEM FUNCTION>>
1467 <==? .TEM .FNAME>>>>>>
1468 <PUTPROP .IND PTHIS-OBJECT ,PMARGS>
1470 <COND (<TYPE? .TAPL FIX> <PCOMP <FORM NTH .IND .TAPL> .TT>)
1474 <FUNCTION () <COND (<==? .LN 2> <MAPSTOP>)
1478 <PUTPROP .IND PTHIS-OBJECT>
1482 <AND <==? <NODE-TYPE .N> ,MARGS-CODE>
1483 <PUT .N ,NODE-NAME <SET NN <+ .NN 1>>>>>
1485 <SET ITRF <NODEFM ,MPSBR-CODE .TT <> <> (.ITRF) <>>>)
1486 (ELSE <SET ITRF <PCOMP .TAPL .TT>>)>
1491 !<MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> <REST .OBJ 2>>)>
1497 #DECL ((VALUE) NODE)
1498 <NODEFM ,MARGS-CODE .PARENT <> <> () <>>>
1500 <COND (<GASSIGNED? PMAPF-R>
1501 <PUTPROP ,MAPF PAPPLY-OBJECT ,PMAPF-R>
1502 <PUTPROP ,MAPR PAPPLY-OBJECT ,PMAPF-R>)>
1504 <DEFINE ADECL-FCN (OBJ "AUX" (TT <NODEFM ,ADECL-CODE .PARENT <> ADECL () <>>)
1506 #DECL ((TT VALUE) NODE (OBJ) ADECL)
1507 <COND (<==? <LENGTH .OBJ> 2>
1508 <COND (<TYPE? <SET OBJ1 <1 .OBJ>> SEGMENT>
1509 <PUT .TT ,NODE-TYPE ,SEGMENT-CODE>
1510 <PUT .TT ,NODE-NAME <>>
1511 <PUT .TT ,KIDS (<ADECL-FCN <CHTYPE [<CHTYPE .OBJ1 FORM>
1512 <2 .OBJ>] ADECL>>)>)
1514 <PUT .TT ,NODE-NAME <2 .OBJ>>
1515 <PUT .TT ,KIDS (<PCOMP <1 .OBJ> .TT>)>)>)
1517 <COMPILE-ERROR "ADECL has an incorrect number of elements: "
1520 <COND (<GASSIGNED? ADECL-FCN> <PUTPROP ADECL PTHIS-TYPE ,ADECL-FCN>)>
1522 <DEFINE CASE-FCN (OBJ AP
1523 "AUX" (OP .PARENT) (PARENT .PARENT) (FLG T) (WIN T) TYP
1525 #DECL ((PARENT) <SPECIAL NODE> (OBJ) <FORM ANY> (VALUE) NODE)
1528 <G? <LENGTH .OBJ> 3>
1530 <COND (<OR <AND <==? <TYPE <SET X <2 .OBJ>>> GVAL>
1531 <==? <SET P <CHTYPE .X ATOM>> ==?>>
1532 <AND <TYPE? <SET X <2 .OBJ>> FORM>
1535 <==? <SET P <2 .X>> ==?>
1536 ;<MEMQ <SET P <2 .X>> '[==? TYPE? PRIMTYPE?]>>>)
1537 (ELSE <SET WIN <>>)>
1542 (<AND .FLG <==? .O DEFAULT>> <SET DF T>)
1543 (<AND .DF <TYPE? .O LIST>> <SET DF <>> <SET FLG <>>)
1544 (<AND <NOT .DF> <TYPE? .O LIST> <NOT <EMPTY? .O>>>
1546 (<SET TEM <VAL-CHK <1 .O>>>
1547 <COND (<ASSIGNED? TYP> <OR <==? .TYP <TYPE .TEM>> <SET WIN <>>>)
1548 (ELSE <SET TYP <TYPE .TEM>>)>)
1549 (<AND <TYPE? <SET TEM <1 .O>> SEGMENT>
1550 <==? <LENGTH .TEM> 2>
1551 <==? <1 .TEM> QUOTE>
1552 <NOT <MONAD? <SET TEM <2 .TEM>>>>>
1555 <COND (<NOT <SET TY <VAL-CHK .TY>>> <SET WIN <>>)
1557 <COND (<ASSIGNED? TYP>
1558 <OR <==? .TYP <TYPE .TY>>
1560 (ELSE <SET TYP <TYPE .TY>>)>)>>
1562 (ELSE <SET WIN <>>)>)
1563 (ELSE <MAPLEAVE <>>)>
1568 <NOT <OR <AND <MEMQ <TYPEPRIM .TYP> '[WORD FIX]>
1570 <AND <N==? .P ==?> <==? .TYP ATOM>>>>>
1574 <SET PARENT <NODECOND ,CASE-CODE .OP <> CASE ()>>
1578 (<PCOMP <2 .OBJ> .PARENT>
1579 <PCOMP <3 .OBJ> .PARENT>
1581 <FUNCTION (CLA "AUX" TT)
1582 #DECL ((CLA) <OR ATOM LIST> (TT) NODE)
1583 <COND (.DF <SET CLA (ELSE !.CLA)>)>
1585 (<NOT <TYPE? .CLA ATOM>>
1586 <PUT <SET TT <NODEB ,BRANCH-CODE .PARENT <> <> ()>>
1588 <PCOMP <COND (<TYPE? <SET TEM <1 .CLA>> SEGMENT>
1590 <MAPF ,LIST ,VAL-CHK <2 .TEM>>>)
1593 <MAPF ,LIST ,VAL-CHK .TEM>>)
1594 (ELSE <VAL-CHK .TEM>)>
1599 <FUNCTION (O) <PCOMP .O .TT>>
1603 (ELSE <SET DF T> <PCOMP .CLA .PARENT>)>>
1605 (ELSE <PMACRO .OBJ .OP>)>)
1606 (ELSE <COMPILE-ERROR "CASE in incorrect format " .OBJ>)>>
1608 <DEFINE VAL-CHK (TEM "AUX" TT)
1609 <OR <AND <OR <TYPE? .TEM ATOM>
1610 <==? <PRIMTYPE .TEM> WORD>
1611 <==? <PRIMTYPE .TEM> FIX>> .TEM>
1612 <AND <==? <TYPE .TEM> GVAL>
1613 <MANIFESTQ <SET TEM <CHTYPE .TEM ATOM>>>
1615 <AND <TYPE? .TEM FORM>
1616 <==? <LENGTH .TEM> 2>
1617 <OR <AND <==? <1 .TEM> QUOTE> <2 .TEM>>
1618 <AND <==? <1 .TEM> GVAL> <MANIFESTQ <2 .TEM>> ,<2 .TEM>>
1619 <AND <==? <1 .TEM> ASCII>
1620 <TYPE? <2 .TEM> CHARACTER FIX>
1622 <AND <TYPE? .TEM FORM>
1623 <==? <LENGTH .TEM> 3>
1624 <==? <1 .TEM> CHTYPE>
1625 <TYPE? <3 .TEM> ATOM>
1626 <NOT <TYPE? <2 .TEM> FORM LIST VECTOR UVECTOR SEGMENT>>
1628 <AND <TYPE? .TEM FORM>
1630 <TYPE? <SET TT <1 .TEM>> ATOM>
1633 <VAL-CHK <EMACRO .TEM>>>>>
1635 <DEFINE MANIFESTQ (ATM)
1637 <AND <MANIFEST? .ATM>
1639 <NOT <TYPE? ,.ATM MSUBR>>>>
1641 <DEFINE EMACRO (OBJ "AUX" (ERR <HANDLER ,MACROERR 100>) TEM)
1643 <COND (<TYPE? <SET TEM
1645 #DECL ((MACACT) <SPECIAL ANY>)
1647 <SETG MACACT .MACACT>
1651 <COMPILE-ERROR "Macro expansion lossage " ,CR !.TEM>)
1652 (ELSE <OFF .ERR> .TEM)>>
1654 <COND (<AND <GASSIGNED? CASE> <GASSIGNED? CASE-FCN>>
1655 <PUTPROP ,CASE PAPPLY-OBJECT ,CASE-FCN>)>
1657 <DEFINE P-CALL (OBJ AP
1665 #DECL ((TT) NODE (VALUE) NODE (OBJ) FORM)
1666 <COND (<AND <NOT <EMPTY? <REST .OBJ>>>
1667 <TYPE? <SET CALLED <2 .OBJ>> ATOM>>
1668 <COND (<==? .CALLED IFSYS>
1669 <SET IN-IFSYS <3 .OBJ>>)
1670 (<==? .CALLED ENDIF>
1671 <SET IN-IFSYS <>>)>)>
1672 <PUT .TT ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> <REST .OBJ>>>>
1674 <DEFINE P-APPLY PAP (OBJ AP "AUX" TT ITM TEM V)
1675 #DECL ((TT) NODE (VALUE) NODE (OBJ) FORM)
1676 <COND (<AND <NOT <EMPTY? <REST .OBJ>>>
1677 <TYPE? <SET ITM <2 .OBJ>> SEGMENT>>
1678 <COND (<AND <==? <LENGTH .ITM> 2>
1679 <OR <==? <SET TEM <1 .ITM>> GVAL> <==? .TEM LVAL>>>
1680 <SET OBJ <CHTYPE (<FORM 1 .ITM>
1681 <CHTYPE (REST .ITM) SEGMENT>
1682 !<REST .OBJ 2>) FORM>>)
1684 <RETURN <PCOMP <FORM BIND ((<SET V <MAKE-TAG "A">> .ITM))
1685 <CHTYPE (APPLY <FORM 1
1687 <CHTYPE (REST <FORM LVAL .V>)
1689 !<REST .OBJ 2>) FORM>>
1691 (ELSE <SET OBJ <CHTYPE <REST .OBJ> FORM>>)>
1692 <SET TT <NODEFM ,APPLY-CODE .PARENT <> APPLY () .AP>>
1693 <PUT .TT ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>>
1695 <COND (<GASSIGNED? P-CALL> <PUTPROP `CALL PAPPLY-OBJECT ,P-CALL>)>
1697 <DEFINE PRINT-HACKERS (OBJ AP "AUX" (LEN <COND (<==? <1 .OBJ> CRLF> 1)
1699 #DECL ((OBJ) FORM (LEN) FIX)
1700 <COND (<==? <LENGTH .OBJ> .LEN>
1702 <SET OBJ <CHTYPE (<1 .OBJ> '.OUTCHAN) FORM>>)
1703 (ELSE <SET OBJ <CHTYPE (<1 .OBJ> <2 .OBJ> '.OUTCHAN)
1705 <RSUBR-FCN .OBJ .AP>>
1707 <COND (<GASSIGNED? PRINT-HACKERS>
1708 <PUTPROP ,PRINT PAPPLY-OBJECT ,PRINT-HACKERS>
1709 <PUTPROP ,PRIN1 PAPPLY-OBJECT ,PRINT-HACKERS>
1710 <PUTPROP ,PRINC PAPPLY-OBJECT ,PRINT-HACKERS>
1711 <PUTPROP ,CRLF PAPPLY-OBJECT ,PRINT-HACKERS>)>
1713 <DEFINE P-MULTI-SET (OBJ:FORM AP
1714 "AUX" (TT <NODEFM ,MULTI-SET-CODE .PARENT <> MULTI-SET
1716 <COND (<L? <LENGTH .OBJ> 2>
1717 <COMPILE-ERROR "Too few args to MULTI-SET: " .OBJ>)>
1718 <COND (<OR <NOT <TYPE? <SET L <2 .OBJ>> LIST>>
1722 <COND (<NOT <OR <TYPE? .X ATOM>
1723 <AND <TYPE? .X ADECL>
1724 <TYPE? <1 .X> ATOM>>>>
1728 <COMPILE-ERROR "Arg wrong type to MULTI-SET: " .OBJ>)>
1729 <PUT .TT ,KIDS (<PCOMP <FORM QUOTE .L> .TT>
1731 <FUNCTION (O) <PCOMP .O .TT>>
1734 <COND (<AND <GASSIGNED? MULTI-SET> <GASSIGNED? P-MULTI-SET>>
1735 <PUTPROP ,MULTI-SET PAPPLY-OBJECT ,P-MULTI-SET>)>
1737 <DEFINE PIFSYS (OBJ AP "AUX" L SYS) #DECL ((OBJ) <OR FORM LIST>)
1738 <COND (<AND <ASSIGNED? IN-IFSYS> .IN-IFSYS>
1739 <REPEAT ((STUFF ()))
1740 <COND (<EMPTY? <SET OBJ <REST .OBJ>>>
1741 <RETURN <COND (<EMPTY? .STUFF>
1744 <CHTYPE (BIND () !.STUFF) FORM>
1746 <COND (<OR <NOT <TYPE? <SET L <1 .OBJ>> LIST>>
1748 <NOT <TYPE? <SET SYS <1 .L>> STRING ATOM>>>
1749 <ERROR ARG-WRONG-TYPE <1 .OBJ> IFSYS>)
1751 <COND (<TYPE? .SYS ATOM> <SET SYS <SPNAME .SYS>>)>
1752 <COND (<OR <=? .SYS .IN-IFSYS>
1753 <AND <=? .SYS "UNIX">
1754 <OR <=? .IN-IFSYS "VAX">
1755 <=? .IN-IFSYS "MAC">>>
1756 <AND <OR <=? .SYS "VAX">
1758 <=? .IN-IFSYS "UNIX">>>
1759 ; "Allow for UNIX/VAX/MAC..."
1760 <SET STUFF (!<REST .L> !.STUFF)>)>)>>)
1762 <PMACRO <CHTYPE (IFSYS-MIMC !<REST .OBJ>) FORM>
1765 <COND (<AND <GASSIGNED? IFSYS> <GASSIGNED? PIFSYS>>
1766 <PUTPROP ,IFSYS PAPPLY-OBJECT ,PIFSYS>)>
1768 <DEFMAC IFSYS-MIMC ("ARGS" ARGS "AUX" (STUFF ()))
1771 <COND (<EMPTY? .ARGS> <RETURN .STUFF>)>
1772 <COND (<OR <NOT <TYPE? <SET L <1 .ARGS>> LIST>>
1774 <NOT <TYPE? <1 .L> STRING ATOM>>>
1775 <ERROR ARG-WRONG-TYPE <1 .ARGS> IFSYS>)
1777 <COND (<TYPE? <1 .L> ATOM>
1778 <1 .L <SPNAME <1 .L>>>)>
1779 <SET STUFF (<FORM CALL!- IFSYS <1 .L>> !<REST .L>
1780 <FORM CALL!- ENDIF <1 .L>> !.STUFF)>)>
1781 <SET ARGS <REST .ARGS>>>
1782 <CHTYPE (BIND () !.STUFF) FORM>>