3 <ENTRY PASS1 PCOMP PMACRO PAPPLY-OBJECT PAPPLY-TYPE PTHIS-OBJECT PTHIS-TYPE
4 GEN-D ACT-FIX FIND:DECL SEG? PSUBR-C>
6 <USE "CHKDCL" "COMPDEC" "CDRIVE">
9 " This file contains the first pass of the MUDDLE compiler.
10 The functions therein take a MUDDLE function and build a more detailed
11 model of it. Each entity in the function is represented by an object
12 of type NODE. The entire function is represented by the functions node
13 and it points to the rest of the nodes for the function."
15 " Nodes vary in complexity and size depending on what they represent.
16 A function or prog/repeat node is contains more information than a node
17 for a quoted object. All nodes have some fields in common to allow
18 general programs to traverse the model."
20 " The model built by PASS1 is used by the analyzer (SYMANA), the
21 variable allocator (VARANA) and the code generator (CODGEN). In some
22 cases the analyzers and generators for certain classes of SUBRs are
23 together in their own files (e.g. CARITH, STRUCT, ISTRUC)."
25 " This the top level program for PASS1. It takes a function as
26 input and returns the data structure representing the model."
29 "OPTIONAL" (NAME <>) (JUSTDCL <>) (RNAME .NAME)
30 "AUX" RESULT (VARTBL ,LVARTBL) (DCL #DECL ()) (ARGL ())
31 (HATOM <>) (TT ()) (FCN .FUNC) TEM (RQRG 0) (TRG 0) INAME)
32 #DECL ((FUNC) FUNCTION (VARTBL) <SPECIAL SYMTAB>
33 (RQRG TRG) <SPECIAL FIX> (FCN) <PRIMTYPE LIST> (ARGL TT) LIST
34 (RESULT) <SPECIAL NODE> (INAME) <UVECTOR [REST ATOM]>)
35 <AND <EMPTY? .FCN> <MESSAGE ERROR " EMPTY FUNCTION ">>
36 <AND <TYPE? <1 .FCN> ATOM>
38 <SET FCN <REST .FCN>>>
39 <AND <EMPTY? .FCN> <MESSAGE ERROR " NO ARG LIST ">>
42 <COND (<AND <NOT <EMPTY? .FCN>> <TYPE? <1 .FCN> DECL>>
44 <SET FCN <REST .FCN>>)>
45 <AND <EMPTY? .FCN> <MESSAGE ERROR " NO BODY ">>
46 <COND (<SET TEM <GET .RNAME .IND>>
48 <SET VARTBL <SYMTAB .RESULT>>)
50 <SET TT <GEN-D .ARGL .DCL .HATOM>>
52 <IUVECTOR <- .TRG .RQRG -1> '<MAKE:TAG <PNAME .NAME>>>>
56 <FIND:DECL VALUE .DCL>
63 <COND (<==? <LENGTH .TT> 3> <3 .TT>)>
66 <ACT-FIX .RESULT <2 .TT>>
67 <PUT .RNAME .IND .RESULT>
70 ("VALUE" <RESULT-TYPE .RESULT> !<RSUBR-DECLS .RESULT>)>)>
74 <MAPF ,LIST <FUNCTION (O) <PCOMP .O .RESULT>> .FCN>>>
77 " This function (and others on this page) take an arg list and
78 decls and parses them producing 3 things.
80 1) An RSUBR decl list.
82 2) A machine readable binding specification.
84 3) Possibly an AC call spec.
86 Atoms are also entered into the symbol table."
88 <DEFINE GEN-D (ARGL DCL HATOM "OPTIONAL" (ACS:TOP <COND (.GLUE '(() STACK)) (T (()))>)
89 "AUX" (SVTBL .VARTBL) (ACS:BOT <CHTYPE .ACS:TOP LIST>) (NACS 1)
90 (RES:TOP (())) (RES:BOT .RES:TOP) (ARGN 1) (BNDL:TOP (()))
91 (BNDL:BOT .BNDL:TOP) (MODE ,TOT-MODES) (DOIT ,INIT-D)
92 (ST <>) T T1 SVT (IX 0) TIX VIX)
93 #DECL ((ACS:BOT RES:BOT BNDL:TOP BNDL:BOT) <SPECIAL LIST> (RES:TOP) LIST
94 (ACS:TOP) <SPECIAL <PRIMTYPE LIST>> (NACS ARGN) <SPECIAL FIX>
95 (VIX) <VECTOR [REST STRING]> (MODE) <SPECIAL <VECTOR [REST STRING]>>
96 (IX) FIX (DOIT) <SPECIAL ANY> (ARGL) LIST (SVTBL SVT) SYMTAB
97 (DCL) <SPECIAL <PRIMTYPE LIST>>)
99 <AND <EMPTY? .ARGL> <RETURN>>
100 <COND (<SET T1 <TYPE? <SET T <1 .ARGL>> ATOM FORM LIST>>
102 <APPLY .DOIT .T .T1>)
104 <AND .ST <MESSAGE ERROR " TWO DECL STRINGS IN A ROW ">>
106 <OR <SET TIX <MEMBER .T .MODE>>
107 <MESSAGE ERROR " UNRECOGNIZED STRING IN DECL " .T>>
109 <SET MODE <REST .MODE <NTH ,RESTS <SET IX <LENGTH .VIX>>>>>
110 <SET DOIT <NTH ,DOITS .IX>>
111 <COND (<OR <L? .IX 5> <G? .IX 8>>)
112 (ELSE <PUT-RES (<COND (<=? <1 .ARGL> "OPT">
114 (ELSE <1 .ARGL>)>)>)>)
115 (ELSE <MESSAGE ERROR " BAD THING IN DECL " .T>)>
116 <SET ARGL <REST .ARGL>>>
117 <AND .HATOM <ACT-D .HATOM <TYPE .HATOM>>>
119 #DECL ((DC1) FORM (DC) ANY (VARTBL) <SPECIAL SYMTAB>)
120 <COND (<EMPTY? .DCL> <RETURN>)
121 (<EMPTY? <REST .DCL>> <MESSAGE ERROR "DECL LIST AT END OF DECL">)>
123 <COND (<AND <TYPE? .DC FORM>
125 <==? <LENGTH .DC1> 2>
126 <OR <==? <1 .DC1> SPECIAL> <==? <1 .DC1> UNSPECIAL>>>
132 <ADDVAR .ATM T -1 0 T (.DC) <> <>>>>
133 <CHTYPE <1 .DCL> LIST>>
134 <SET DCL <REST .DCL 2>>>
137 <COND (<N==? .SVTBL .SVT>
140 <COND (<==? <NEXT-SYM .SV> .SVTBL>
141 <PUT .SV ,NEXT-SYM .VARTBL>
144 (ELSE <SET SV <NEXT-SYM .SV>>)>>)>
145 <AND <L? <SET TRG <- .ARGN 1>> 0> <SET RQRG -1>>
146 <COND (<OR <NOT .ACS:TOP> <=? .ACS:TOP '(() STACK)>>
147 <REPEAT ((BB ()) B (CHNG T) (N1 0) (N2 0) TEM)
148 #DECL ((BB B) <LIST [REST SYMTAB]> (N1 N2) FIX (TEM) SYMTAB)
156 <COND (<NOT <0? <SET N2 <ARGNUM-SYM <SET TEM <1 .BB>>>>>>
161 (ELSE <SET N1 .N2>)>)
162 (ELSE <SET BB ()> <AGAIN>)>
164 <SET BB <REST .BB>>>)>
167 !<COND (.ACS:TOP (<REST .ACS:TOP>)) (ELSE ())!>)>
170 <DEFINE SRCH-SYM (ATM "AUX" (TB .VARTBL))
171 #DECL ((ATM) ATOM (TB) <PRIMTYPE VECTOR>)
173 <AND <EMPTY? .TB> <RETURN <>>>
174 <AND <==? .ATM <NAME-SYM .TB>> <RETURN .TB>>
175 <SET TB <NEXT-SYM .TB>>>>
177 "Vector of legal strings in decl list."
191 "Amount to rest off decl vector after each encounter."
193 <SETG RESTS ![1 2 1 2 1 2 1 2 1 1!]>
195 "This function used for normal args when \"BIND\" and \"CALL\" still possible."
197 <DEFINE INIT-D (OBJ TYP) #DECL ((MODE) <VECTOR STRING>)
198 <SET MODE <REST .MODE>> <INIT1-D .OBJ .TYP>>
200 "This function for normal args when \"CALL\" still possible."
202 <DEFINE INIT1-D (OBJ TYP)
203 #DECL ((MODE) <VECTOR STRING>)
204 <SET MODE <REST .MODE>>
208 "Handle a normal argument or quoted normal argument."
210 <DEFINE NORM-D (OBJ TYP) #DECL ((TYP) ATOM (RQRG ARGN) FIX (DCL) DECL)
212 <MESSAGE ERROR " LIST NOT IN OPT OR AUX " .OBJ>>
213 <SET RQRG <+ .RQRG 1>>
214 <COND (<==? .TYP ATOM>
215 <PUT-RES (<PUT-DCL 13 .OBJ <><FIND:DECL .OBJ .DCL> T>)>)
216 (<SET OBJ <QUOTCH .OBJ>>
217 <PUT-RES ("QUOTE" <PUT-DCL 12 .OBJ <> <FIND:DECL .OBJ .DCL> T>)>)>
218 <SET ARGN <+ .ARGN 1>>>
220 "Handle \"BIND\" decl."
222 <DEFINE BIND-D (OBJ TYP "AUX" DC) #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
224 <OR <==? .TYP ATOM> <MESSAGE ERROR " BAD BIND " .OBJ>>
225 <SET DC <PUT-DCL 11 .OBJ <> <FIND:DECL .OBJ .DCL> T>>
226 <TYPE-ATOM-OK? .DC ENVIRONMENT .OBJ>
229 "Handle \"CALL\" decl."
231 <DEFINE CALL-D (OBJ TYP "AUX" DC) #DECL ((TYP) ATOM (RQRG ARGN) FIX (DCL) DECL)
232 <SET RQRG <+ .RQRG 1>>
233 <OR <==? .TYP ATOM> <MESSAGE ERROR " BAD CALL " .OBJ>>
234 <PUT-RES (<SET DC <PUT-DCL 10 .OBJ <> <FIND:DECL .OBJ .DCL> T>>)>
235 <TYPE-ATOM-OK? .DC FORM .OBJ>
236 <SET ARGN <+ .ARGN 1>>
239 "Flush on extra atoms after \"CALL\", \"ARGS\" etc."
241 <DEFINE ERR-D (OBJ TYPE) <MESSAGE ERROR " BAD SYNTAX ARGLIST " .OBJ>>
243 "Handle \"OPTIONAL\" decl."
245 <DEFINE OPT-D (OBJ TYP "AUX" DC OBJ1)
246 #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
247 <COND (.ACS:TOP <SET ACS:TOP '(() STACK)>)> ;"Temporary until know how to win."
248 <COND (<==? .TYP ATOM>
249 <PUT-RES (<PUT-DCL 9 .OBJ <><FIND:DECL .OBJ .DCL> <>>)>)
251 <SET OBJ <QUOTCH .OBJ>>
252 <PUT-RES ("QUOTE" <PUT-DCL 8 .OBJ <> <FIND:DECL .OBJ .DCL> <>>)>)
253 (<TYPE? <SET OBJ1 <LISTCH .OBJ>> ATOM>
254 <PUT-RES (<PAUX .OBJ1 <2 <CHTYPE .OBJ LIST>> <FIND:DECL .OBJ1 .DCL> 7>)>)
256 <SET OBJ1 <QUOTCH .OBJ1>>
258 <PAUX .OBJ1 <2 <CHTYPE .OBJ LIST>> <FIND:DECL .OBJ1 .DCL> 6>)>)
259 (ELSE <MESSAGE ERROR "BAD USE OF OPTIONAL " .OBJ>)>
260 <SET ARGN <+ .ARGN 1>>>
262 "Handle \"ARGS\" decl."
264 <DEFINE ARGS-D (OBJ TYP "AUX" DC)
265 #DECL ((TYP) ATOM (RQRG ARGN) FIX (DCL) DECL (BNDL:BOT) <LIST SYMTAB>)
266 <COND (.ACS:TOP <SET ACS:TOP '(() STACK)>)> ;"Temporary until know how to win."
267 <OR <==? .TYP ATOM> <MESSAGE ERROR " BAD ARGS " .OBJ>>
268 <PUT-RES (<SET DC <PUT-DCL 5 .OBJ <> <FIND:DECL .OBJ .DCL> <>>>)>
269 <TYPE-ATOM-OK? .DC LIST .OBJ>
271 <SET ARGN <+ .ARGN 1>>>
273 "Handle \"TUPLE\" decl."
275 <DEFINE TUP-D (OBJ TYP "AUX" DC)
276 #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
277 <OR <==? .TYP ATOM> <MESSAGE ERROR " BAD TUPLE " .OBJ>>
278 <COND (<1? .ARGN> <SET ARGN 0> <SET ACS:TOP '(() STACK)>)
279 (ELSE <SET ACS:TOP <>>)>
280 <PUT-RES (<SET DC <PUT-DCL 4 .OBJ <> <FIND:DECL .OBJ .DCL> <>>>)>
281 <TYPE-ATOM-OK? .DC TUPLE .OBJ>
285 "Handle \"AUX\" decl."
287 <DEFINE AUX-D (OBJ TYP "AUX" DC OBJ1)
288 #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
289 <AND <==? .TYP FORM> <MESSAGE ERROR " QUOTED AUX " .OBJ>>
290 <COND (<==? .TYP ATOM>
291 <PUT-DCL 3 .OBJ <> <FIND:DECL .OBJ .DCL> <>>)
292 (<TYPE? <SET OBJ1 <LISTCH .OBJ>> ATOM>
293 <PAUX .OBJ1 <2 .OBJ> <FIND:DECL .OBJ1 .DCL> 2>)
294 (ELSE <MESSAGE ERROR " QUOTED AUX " .OBJ>)>>
296 "Handle \"NAME\" and \"ACT\" decl."
298 <DEFINE ACT-D (OBJ TYP "AUX" DC)
299 #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
301 <MESSAGE ERROR " BAD ACTIVATION " .OBJ>>
302 <SET DC <PUT-DCL 1 .OBJ <> <FIND:DECL .OBJ .DCL> <>>>
303 <TYPE-ATOM-OK? .DC ACTIVATION .OBJ>>
305 "Fixup activation atoms after node generated."
307 <DEFINE ACT-FIX (N L "AUX" (FLG <>)) #DECL ((N) NODE (L) <LIST [REST SYMTAB]>)
308 <REPEAT (SYM) #DECL ((SYM) SYMTAB)
309 <AND <EMPTY? .L> <RETURN .FLG>>
310 <COND (<AND <==? <CODE-SYM <SET SYM <1 .L>>> 1>
312 <NOT <SPEC-SYM .SYM>>>
313 <PUT .SYM ,RET-AGAIN-ONLY .N>)>
316 "Table of varius decl handlers."
319 ![,ACT-D ,ACT-D ,AUX-D ,AUX-D ,TUP-D ,ARGS-D ,OPT-D ,OPT-D ,CALL-D
322 <GDECL (DOITS) UVECTOR (TOT-MODES) <VECTOR [REST STRING]> (RESTS) <UVECTOR [REST FIX]>>
324 "Check for quoted arguments."
326 <DEFINE QUOTCH (OB) #DECL ((OB) FORM (VALUE) ATOM)
327 <COND (<AND <==? <LENGTH .OB> 2>
329 <TYPE? <2 .OB> ATOM>>
331 (ELSE <MESSAGE ERROR " BAD FORM IN ARGLIST " .OB> T)>>
333 "Chech for (arg init) or ('arg init)."
335 <DEFINE LISTCH (OB) #DECL ((OB) LIST)
336 <COND (<AND <==? <LENGTH .OB> 2>
337 <OR <TYPE? <1 .OB> ATOM>
338 <AND <TYPE? <1 .OB> FORM> <QUOTCH <1 .OB>>>>>
340 (ELSE <MESSAGE ERROR " BAD LIST IN ARGLIST " .OB> T)>>
342 "Add a decl to RSUBR decls and update AC call spec."
344 <DEFINE PUT-RES (L "AUX" TY)
345 #DECL ((L) LIST (NACS) FIX (ACS:BOT RES:BOT) LIST)
347 <SET RES:BOT <REST <PUTREST .RES:BOT .L> <LENGTH .L>>>
348 <COND (<AND .ACS:TOP <OR <G? .NACS 5> <=? .ACS:TOP '(() STACK)>>>
349 <SET ACS:TOP '(() STACK)> <RETURN>)>
352 <COND (<EMPTY? .L><RETURN <>>)
353 (<TYPE? <SET TY <1 .L>> STRING>
356 <COND (<SET TY <ISTYPE-GOOD? .TY>>
357 <SET ACS:BOT <REST <PUTREST .ACS:BOT
358 ((.TY <NTH ,ALLACS .NACS>))>>>
359 <SET NACS <+ .NACS 1>>)
360 (<L? <SET NACS <+ .NACS 2>> 7>
361 <SET ACS:BOT <REST <PUTREST .ACS:BOT
362 ((<NTH ,ALLACS <- .NACS 2>>
363 <NTH ,ALLACS <- .NACS 1>>))>>>)
364 (ELSE <SET ACS:TOP '(() STACK)>)>)>
367 "Add code to set up a certain kind of argument."
369 <DEFINE PUT-DCL (COD ATM VAL DC COM "AUX" SPC DC1 TT SYM)
370 #DECL ((DC1) FORM (ATM) ATOM (BNDL:BOT BNDL:TOP TT) LIST (COD) FIX
372 <COND (<AND <TYPE? .DC FORM>
374 <==? <LENGTH .DC1> 2>
375 <OR <SET SPC <==? <1 .DC1> SPECIAL>>
376 <==? <1 .DC1> UNSPECIAL>>>
378 (ELSE <SET SPC .GLOSP>)>
379 <SET SYM <ADDVAR .ATM .SPC .COD .ARGN T (.DC) <> .VAL>>
380 <COND (<AND .COM <NOT <SPEC-SYM .SYM>>> ;"Can specials commute?"
381 <SET TT <REST .BNDL:TOP>>
382 <PUTREST .BNDL:TOP (.SYM !.TT)>
383 <AND <EMPTY? .TT> <SET BNDL:BOT <REST .BNDL:TOP>>>)
384 (ELSE <SET BNDL:BOT <REST <PUTREST .BNDL:BOT (.SYM)>>>)>
387 "Find decl associated with a variable, if none, use ANY."
389 <DEFINE FIND:DECL (ATM "OPTIONAL" (DC .DECLS))
390 #DECL ((DC) <PRIMTYPE LIST> (ATM) ATOM)
393 <AND <OR <EMPTY? .DC> <EMPTY? <SET TT <REST .DC>>>>
395 <COND (<NOT <TYPE? <1 .DC> LIST>>
396 <MESSAGE ERROR " BAD DECL LIST " .DC>)>
397 <AND <MEMQ .ATM <CHTYPE <1 .DC> LIST>> <RETURN <1 .TT>>>
398 <SET DC <REST .TT>>>>
400 "Add an AUX variable spec to structure."
402 <DEFINE PAUX (ATM OBJ DC NTUP "AUX" EV TT)
403 #DECL ((EV TT) NODE (TUP NTUP) FIX (ATM) ATOM)
404 <COND (<AND <TYPE? .OBJ FORM>
406 <OR <==? <1 .OBJ> TUPLE> <==? <1 .OBJ> ITUPLE>>>
408 <NODEFM <COND (<==? <1 .OBJ> TUPLE> ,COPY-CODE)
415 <COND (<==? <NODE-TYPE .TT> ,ISTRUC-CODE>
417 <PCOMP <COND (<==? <LENGTH .OBJ> 3> <3 .OBJ>)
418 (ELSE #LOSE *000000000000*)>
420 <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
421 <SET EV <PCOMP <NODE-NAME .EV> .TT>>
423 <PUT .TT ,NODE-TYPE ,ISTRUC2-CODE>)>
424 <PUT .TT ,KIDS (<PCOMP <2 .OBJ> .TT> .EV)>)
429 <FUNCTION (O) <PCOMP .O .TT>>
431 (ELSE <SET TT <PCOMP .OBJ ()>>)>
432 <PUT-DCL .NTUP .ATM .TT .DC <>>>
434 "Main dispatch function during pass1."
436 <DEFINE PCOMP (OBJ PARENT)
437 #DECL ((PARENT) <SPECIAL ANY> (VALUE) NODE)
438 <APPLY <OR <GET .OBJ PTHIS-OBJECT>
439 <GET <TYPE .OBJ> PTHIS-TYPE>
443 "Build a node for <> or #FALSE ()."
447 <NODE1 ,QUOTE-CODE .PARENT FALSE <> ()>>
449 <PUT '<> PTHIS-OBJECT ,FALSE-QT>
451 "Build a node for ()."
453 <DEFINE NIL-QT (O) #DECL ((VALUE) NODE)
454 <NODE1 ,QUOTE-CODE .PARENT LIST () ()>>
456 <PUT () PTHIS-OBJECT ,NIL-QT>
458 "Build a node for a LIST, VECTOR or UVECTOR."
460 <DEFINE PCOPY (OBJ "AUX" (TT <NODEFM ,COPY-CODE .PARENT <TYPE .OBJ> <TYPE .OBJ> () <>>))
461 #DECL ((VALUE) NODE (TT) NODE)
463 <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>>
465 <PUT VECTOR PTHIS-TYPE ,PCOPY>
467 <PUT UVECTOR PTHIS-TYPE ,PCOPY>
469 <PUT LIST PTHIS-TYPE ,PCOPY>
471 "Build a node for unknown things."
473 <DEFINE PDEFAULT (OBJ) #DECL ((VALUE) NODE)
474 <NODE1 ,QUOTE-CODE .PARENT <TYPE .OBJ> .OBJ ()>>
476 "Further analyze a FORM and build appropriate node."
478 <DEFINE PFORM (OBJ) #DECL ((OBJ) <FORM ANY> (VALUE) NODE)
479 <PROG APPLICATION ((APPLY <1 .OBJ>))
480 #DECL ((APPLICATION) <SPECIAL ACTIVATION>
481 (APPLY) <SPECIAL ANY>)
482 <APPLY <OR <GET .APPLY PAPPLY-OBJECT>
483 <GET <TYPE .APPLY> PAPPLY-TYPE>
487 <PUT FORM PTHIS-TYPE ,PFORM>
489 "Build a SEGMENT node."
491 <DEFINE SEG-FCN (OBJ "AUX" (TT <NODE1 ,SEGMENT-CODE .PARENT <> <> ()>))
492 #DECL ((TT VALUE PARENT) NODE)
493 <PUT .TT ,KIDS (<PFORM <CHTYPE .OBJ FORM>>)>>
495 <PUT SEGMENT PTHIS-TYPE ,SEG-FCN>
497 "Analyze a form or the form <ATM .....>"
499 <DEFINE ATOM-FCN (OB AP) #DECL ((AP) ATOM (VALUE) NODE)
500 <COND (<GASSIGNED? .AP>
502 <AGAIN .APPLICATION>)
504 <MESSAGE WARNING " LOCAL VALUE USED FOR " .AP>
506 <AGAIN .APPLICATION>)
509 (ELSE <MESSAGE WARNING " NO VALUE FOR " .AP>
512 <PUT ATOM PAPPLY-TYPE ,ATOM-FCN>
514 "Expand MACRO and process result."
516 <DEFINE PMACRO (OBJ AP "AUX" ERR TEM)
517 <SET ERR <ON "ERROR" ,MACROERR 100>> ;"Turn On new Error"
518 <SET TEM <PROG MACACT ()
519 #DECL ((MACACT) <SPECIAL ACTIVATION>)
520 <SETG MACACT .MACACT>
522 <OFF .ERR> ;"Turn OFF new Error"
523 <COND (<TYPE? .TEM FUNNY>
524 <MESSAGE ERROR " MACRO EXPANSION LOSSAGE " !.TEM>)
526 <PCOMP .TEM .PARENT>)>>
528 <NEWTYPE FUNNY VECTOR>
529 <PROG (X) ;"Find the real Valret Subr"
530 <COND (<TYPE? ,VALRET SUBR> <SETG REAL-VALRET ,VALRET>)
531 (<AND <GASSIGNED? <SET X <PARSE "OVALRET!-COMBAT!-">>>
533 <SETG REAL-VALRET ,.X>)
534 (<NOT <GASSIGNED? REAL-VALRET>> <ERROR ',VALRET COMPILE>)>>
535 <PUT MACRO PAPPLY-TYPE ,PMACRO>
537 <DEFINE MACROERR (FR "TUPLE" T)
539 <COND (<AND <GASSIGNED? MACACT> <LEGAL? ,MACACT>>
540 <DISMISS <CHTYPE [!.T] FUNNY> ,MACACT>)
541 (ELSE <REAL-VALRET " ">)>>
543 "Build a node for a form whose 1st element is a form (could be NTH)."
545 <DEFINE PFORM-FORM (OBJ AP "AUX" TT)
546 #DECL ((TT) NODE (VALUE) NODE (OBJ) FORM)
547 <COND (<AND <==? <LENGTH .OBJ> 2> <NOT <SEG? .OBJ>>>
548 <SET TT <NODEFM ,FORM-F-CODE .PARENT <> .OBJ () .AP>>
550 <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>)
551 (ELSE <PAPDEF .OBJ .AP>)>>
553 <PUT FORM PAPPLY-TYPE ,PFORM-FORM>
555 "Build a node for strange forms."
557 <DEFINE PAPDEF (OBJ AP) #DECL ((VALUE) NODE)
558 <MESSAGE WARNING " FORM NOT BEING COMPILED " .OBJ>
560 <NODEFM ,FORM-CODE .PARENT <> .OBJ () .AP>>
562 "For objects that require EVAL, make sure all atoms used are special."
564 <DEFINE SPECIALIZE (OBJ "AUX" T1 T2 SYM OB)
565 #DECL ((T1) FIX (OB) FORM (T2) <OR FALSE SYMTAB>)
566 <COND (<AND <TYPE? .OBJ FORM SEGMENT>
567 <SET OB <CHTYPE .OBJ FORM>>
568 <OR <AND <==? <SET T1 <LENGTH .OB>> 2>
570 <TYPE? <SET SYM <2 .OB>> ATOM>>
573 <TYPE? <SET SYM <2 .OB>> ATOM>>>
574 <SET T2 <SRCH-SYM .SYM>>>
575 <COND (<NOT <SPEC-SYM .T2>>
576 <MESSAGE NOTE " REDCLARED SPECIAL " .SYM>
577 <PUT .T2 ,SPEC-SYM T>)>)>
578 <COND (<MEMQ <PRIMTYPE .OBJ> '![FORM LIST UVECTOR VECTOR!]>
579 <MAPF <> ,SPECIALIZE .OBJ>)>>
581 "Build a SUBR call node."
583 <DEFINE PSUBR-C (OBJ AP "AUX" (TT <NODEFM ,SUBR-CODE .PARENT <>
584 <SUBR-NAME .AP <1 .OBJ>> () .AP>))
585 #DECL ((TT) NODE (VALUE) NODE (OBJ) FORM)
587 <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> <REST .OBJ>>>>
589 <PUT SUBR PAPPLY-TYPE ,PSUBR-C>
591 <FLOAD "SBRNAM" "NBIN">
593 <DEFINE SUBR-NAME (THING DEFAULT)
594 <COND (<TYPE? .THING SUBR> <HACK-NAME .THING>)
595 (<TYPE? .THING RSUBR RSUBR-ENTRY> <2 .THING>)
598 <DEFINE FIX-FCN (OBJ AP "AUX" TT (LN <LENGTH .OBJ>))
599 #DECL ((TT VALUE) NODE (OBJ) FORM)
600 <OR <==? .LN 2> <==? .LN 3>
601 <MESSAGE ERROR " BAD APPLICATION OF A NUMBER ">>
602 <SET TT <NODEFM ,SUBR-CODE .PARENT <> <COND (<==? .LN 2> INTH)(ELSE IPUT)>
603 () <COND (<==? .LN 2> ,NTH) (ELSE ,PUT)>>>
604 <PUT .TT ,KIDS (<PCOMP <2 .OBJ> .TT><PCOMP .AP .TT>
605 !<COND (<==? .LN 2> ()) (ELSE (<PCOMP <3 .OBJ> .TT>))>)>>
607 <PUT FIX PAPPLY-TYPE ,FIX-FCN>
609 <PUT OFFSET PAPPLY-TYPE ,FIX-FCN>
613 <DEFINE PPROG-REPEAT (OBJ AP
614 "AUX" (NAME <1 .OBJ>) TT (DCL #DECL ()) (HATOM <>) ARGL
616 #DECL ((OBJ) <PRIMTYPE LIST> (TT) NODE (VALUE) NODE (DCL) DECL
617 (ARGL) LIST (VARTBL) <SPECIAL SYMTAB>)
618 <AND <EMPTY? <SET OBJ <REST .OBJ>>>
619 <MESSAGE ERROR " EMPTY " .NAME>>
620 <AND <TYPE? <1 .OBJ> ATOM>
622 <SET OBJ <REST .OBJ>>>
624 <SET OBJ <REST .OBJ>>
625 <AND <NOT <EMPTY? .OBJ>>
626 <TYPE? <1 .OBJ> DECL>
628 <SET OBJ <REST .OBJ>>>
629 <AND <EMPTY? .OBJ> <MESSAGE ERROR " NO DODY FOR " .NAME>>
633 <FIND:DECL VALUE .DCL>
637 <2 <GEN-D <COND (<AND <NOT <EMPTY? .ARGL>>
638 <TYPE? <1 .ARGL> STRING>>
640 (ELSE ("AUX" !.ARGL))>
645 <ACT-FIX .TT <BINDING-STRUCTURE .TT>>
648 <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>
651 <PUT ,PROG PAPPLY-OBJECT ,PPROG-REPEAT>
653 <PUT ,REPEAT PAPPLY-OBJECT ,PPROG-REPEAT>
655 <PUT ,BIND PAPPLY-OBJECT ,PPROG-REPEAT>
659 <DEFINE UNWIND-FCN (OBJ AP "AUX" (TT <NODEFM ,UNWIND-CODE .PARENT <>
661 #DECL ((PARENT VALUE TT) NODE (OBJ) FORM)
662 <COND (<==? <LENGTH .OBJ> 3>
663 <PUT .TT ,KIDS (<PCOMP <2 .OBJ> .TT> <PCOMP <3 .OBJ> .TT>)>)
664 (ELSE <MESSAGE ERROR "WRONG # OF ARGS TO UNWIND " .OBJ>)>>
666 <PUT ,UNWIND PAPPLY-OBJECT ,UNWIND-FCN>
668 "Build a node for a COND."
670 <DEFINE COND-FCN (OBJ AP "AUX" (PARENT <NODECOND ,COND-CODE .PARENT <> COND ()>))
671 #DECL ((PARENT) <SPECIAL NODE> (OBJ) <FORM ANY> (VALUE) NODE)
674 <FUNCTION (CLA "AUX" (TT <NODEB ,BRANCH-CODE .PARENT <> <> ()>))
676 <COND (<AND <TYPE? .CLA LIST> <NOT <EMPTY? .CLA>>>
677 <PUT .TT ,PREDIC <PCOMP <1 .CLA> .TT>>
680 <FUNCTION (O) <PCOMP .O .TT>>
682 (ELSE <MESSAGE ERROR "BAD COND" .OBJ>)>>
685 <PUT ,COND PAPPLY-OBJECT ,COND-FCN>
687 <PUT ,AND PAPPLY-OBJECT <GET SUBR PAPPLY-TYPE>>
689 <PUT ,OR PAPPLY-OBJECT <GET SUBR PAPPLY-TYPE>>
691 <PUT ,STACKFORM PAPPLY-OBJECT <GET SUBR PAPPLY-TYPE>>
693 "Build a node for '<
\b-object>
\b-."
695 <DEFINE QUOTE-FCN (OBJ AP "AUX" (TT <NODE1 ,QUOTE-CODE .PARENT <> () ()>))
696 #DECL ((TT VALUE) NODE (OBJ) FORM)
697 <COND (<NOT <EMPTY? <REST .OBJ>>>
698 <PUT .TT ,RESULT-TYPE <TYPE <2 .OBJ>>>
699 <PUT .TT ,NODE-NAME <2 .OBJ>>)>>
701 <PUT ,QUOTE PAPPLY-OBJECT ,QUOTE-FCN>
703 "Build a node for a call to an RSUBR."
705 <DEFINE RSUBR-FCN (OBJ AP "AUX" (PARENT <NODEFM ,RSUBR-CODE .PARENT <><1 .OBJ> () .AP>))
706 #DECL ((OBJ) FORM (AP) <OR RSUBR-ENTRY RSUBR> (PARENT) <SPECIAL NODE>
708 <COND (<AND <G? <LENGTH .AP> 2>
709 <TYPE? <3 .AP> DECL>>
710 <PUT .PARENT ,KIDS <PRSUBR-C <1 .OBJ> .OBJ <3 .AP>>>
711 <PUT .PARENT ,TYPE-INFO
713 <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>)
714 (ELSE <PSUBR-C .OBJ .AP>)>>
716 <PUT RSUBR PAPPLY-TYPE ,RSUBR-FCN>
718 <PUT RSUBR-ENTRY PAPPLY-TYPE <GET RSUBR PAPPLY-TYPE>>
720 <DEFINE INTERNAL-RSUBR-FCN (OBJ AP
721 "AUX" (PARENT <NODEFM ,IRSUBR-CODE .PARENT <>
723 #DECL ((OBJ) FORM (AP) IRSUBR (PARENT) <SPECIAL NODE>)
724 <PUT .PARENT ,KIDS <PRSUBR-C <1 .OBJ> .OBJ <1 .AP>>>
725 <PUT .PARENT ,TYPE-INFO
727 <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>>
729 <PUT IRSUBR PAPPLY-TYPE ,INTERNAL-RSUBR-FCN>
731 "Predicate: any segments in this object?"
733 <DEFINE SEG? (OB) #DECL ((OB) <PRIMTYPE LIST>)
735 <AND <EMPTY? .OB> <RETURN <>>>
736 <AND <TYPE? <1 .OB> SEGMENT> <RETURN T>>
737 <SET OB <REST .OB>>>>
740 "Analyze a call to an RSUBR with decls checking number of args and types wherever
743 <DEFINE PRSUBR-C (NAME OBJ RDCL
744 "AUX" (DOIT ,INIT-R) (SEGSW <>) (SGD '<>) (SGP '(1)) SGN
745 (IX 0) DC (RM ,RMODES) (ARG-NUMBER 0) (KDS (()))
746 (TKDS .KDS) RMT (OB <REST .OBJ>) (ST <>))
747 #DECL ((TKDS KDS) <SPECIAL LIST> (OB) LIST (OBJ) <SPECIAL <PRIMTYPE LIST>>
748 (RM) <SPECIAL <VECTOR [REST STRING]>> (ARG-NUMBER) FIX
749 (RDCL) <SPECIAL <PRIMTYPE LIST>> (DOIT SEGSW) <SPECIAL ANY> (IX) FIX
750 (NAME) <SPECIAL ANY> (SGD) FORM (SGP) <LIST ANY> (SGN) NODE)
752 #DECL ((RSB) <SPECIAL ACTIVATION>)
754 (<NOT <EMPTY? .RDCL>>
755 <COND (<NOT <EMPTY? .RM>>
757 <SET RDCL <REST .RDCL>>)>
760 <COND (<=? .DC "OPT"> <SET DC "OPTIONAL">)>
761 <OR <SET RMT <MEMBER .DC .RM>>
762 <MESSAGE ERROR "BAD STRING IN RSUBR DECL " .NAME>>
764 <SET DOIT <NTH ,RDOIT <SET IX <LENGTH .RM>>>>
765 <SET ST <APPLY <NTH ,SDOIT .IX> .ST>>
766 <COND (<EMPTY? .RM> ;"TUPLE seen."
767 <SET DC <GET-ELE-TYPE <1 .RDCL> ALL>>)>)
770 <AND <L? <LENGTH .RM> 4> <RETURN <REST .TKDS>>>
771 <MESSAGE ERROR " TOO FEW ARGS TO " .NAME>)
775 <PUTREST .SGP ([REST .DC])>
776 <PUT .SGN ,RESULT-TYPE <TYPE-AND <RESULT-TYPE .SGN> .SGD>>
777 <RETURN <REST .TKDS>>)
778 (ELSE <SET SGP <REST <PUTREST .SGP (.DC)>>>)>)
779 (<TYPE? <1 .OB> SEGMENT>
781 <REST <PUTREST .KDS (<SET SGN <SEGCHK <1 .OB>>>)>>>
787 <SEGCH1 .DC <RESULT-TYPE .SGN> <1 .OB>>>
788 <RETURN <REST .TKDS>>)
789 (ELSE <SET SEGSW T>)>)
794 <FUNCTION (O "AUX" TT)
795 <SET TT <PCOMP .O .PARENT>>
799 (<==? <NODE-TYPE .TT> ,SEGMENT-CODE>
800 <OR <TYPE-OK? <RESULT-TYPE <1 <KIDS .TT>>>
801 <FORM STRUCTURED [REST .DC]>>
802 <MESSAGE ERROR "BAD ARG TO " .NAME .OB>>)
804 <OR <TYPE-OK? <RESULT-TYPE .TT> .DC>
805 <MESSAGE ERROR "BAD ARG TO " .NAME .OB>>
806 <OR <RESULT-TYPE .TT> <PUT .TT ,RESULT-TYPE .DC>>)>)>
809 <RETURN <REST .TKDS>>)>
811 <REST <CHTYPE <SET SGD <FORM STRUCTURED .DC>> LIST>>>
814 (<SET KDS <REST <PUTREST .KDS (<APPLY .DOIT .DC .OB>)>>>
816 <SET ARG-NUMBER <+ .ARG-NUMBER 1>>
818 (<EMPTY? .OB> <RETURN <REST .TKDS>>)
822 <COND (<RESULT-TYPE .SGN> <TYPE-AND <RESULT-TYPE .SGN> .SGD>)
824 <RETURN <REST .TKDS>>)
825 (ELSE <MESSAGE ERROR " TOO MANY ARGS TO " .NAME>)>>>
830 "Flush one possible decl away."
832 <DEFINE CHOPPER (F) #DECL ((RM) <VECTOR [REST STRING]>)
833 <AND .F <MESSAGE ERROR " 2 STRINGS IN ROW IN DCL ">>
837 "Handle Normal arg when \"VALUE\" still possible."
839 <DEFINE INIT-R (DC OB)
840 #DECL ((RM) <VECTOR [REST STRING]>)
841 <SET RM <REST .RM 2>> <SET DOIT ,INIT1-R> <INIT1-R .DC .OB>>
843 "Handle Normal arg when \"CALL\" still possible."
845 <DEFINE INIT2-R (DC OB)
846 #DECL ((RM) <VECTOR [REST STRING]>)
847 <SET RM <REST .RM>> <SET DOIT ,INIT1-R> <INIT1-R .DC .OB>>
851 <DEFINE INIT1-R (DC OB "AUX" TT) #DECL ((TT) NODE (OB) LIST)
854 <SET TT <PCOMP <1 .OB> .PARENT>>> .DC>
855 <MESSAGE ERROR "BAD ARG TO " .NAME>>
856 <OR <RESULT-TYPE .TT><PUT .TT ,RESULT-TYPE .DC>>
859 "Handle \"QUOTE\" arg."
861 <DEFINE QINIT-R (DC OB "AUX" TT) #DECL ((TT) NODE (OB) LIST)
865 <NODE1 ,QUOTE-CODE .PARENT <TYPE <1 .OB>>
867 <MESSAGE ERROR "BAD ARG TO " .NAME>>
871 "Handle \"CALL\" decl."
873 <DEFINE CAL-R (DC OB "AUX" TT) #DECL ((TKDS KDS) LIST (TT) NODE)
877 <NODE1 ,QUOTE-CODE .PARENT FORM .OBJ ()>>> .DC>
878 <MESSAGE ERROR "BAD ARG TO " .NAME>>
880 <RETURN <REST .TKDS> .RSB>>
882 "Handle \"ARGS\" decl."
884 <DEFINE ARGS-R (DC OB "AUX" TT) #DECL ((TT) NODE (KDS TKDS) LIST)
888 <NODE1 ,QUOTE-CODE .PARENT LIST .OB ()>>> .DC>
889 <MESSAGE "BAD CALL TO " .NAME>>
891 <RETURN <REST .TKDS> .RSB>>
893 "Handle \"TUPLE\" decl."
895 <DEFINE TUPL-R (DC OB "AUX" TT) #DECL ((OB) LIST (TT) NODE)
896 <OR <TYPE-OK? <RESULT-TYPE <SET TT <PCOMP <1 .OB> .PARENT>>> .DC>
897 <MESSAGE ERROR "BAD ARG TO " .NAME>>
898 <OR <RESULT-TYPE .TT> <PUT .TT ,RESULT-TYPE .DC>>
901 "Handle stuff with segments in arguments."
903 <DEFINE SEGCHK (OB "AUX" TT) #DECL ((TT) NODE)
904 <OR <TYPE-OK? <RESULT-TYPE <SET TT <PCOMP .OB .PARENT>>> STRUCTURED>
905 <MESSAGE ERROR "BAD SEGMENT GOODIE. " .OB>>
909 <DEFINE SEGCH1 (DC RT OB)
910 <OR <TYPE-AND .RT <FORM STRUCTURED [REST .DC]>>
911 <MESSAGE ERROR "BAD ARG TO " .NAME .OB>>>
913 "Handle \"VALUE\" chop decl and do the rest."
915 <DEFINE VAL-R (F) #DECL ((RDCL) <PRIMTYPE LIST> (PARENT) NODE)
917 <PUT .PARENT ,RESULT-TYPE <1 .RDCL>>
919 <SET F <TYPE? <1 .RDCL> STRING>>
920 <SET RDCL <REST .RDCL>> .F>
922 <DEFINE ERR-R (DC OB)
923 <MESSAGE INCONISTANCY "SHOULDN'T GET HERE ">>
925 <SETG RMODES ["VALUE" "CALL" "QUOTE" "OPTIONAL" "QUOTE" "ARGS" "TUPLE"]>
927 <SETG RDOIT ![,TUPL-R ,ARGS-R ,QINIT-R ,INIT1-R ,QINIT-R ,CAL-R ,ERR-R!]>
929 <SETG SDOIT ![,CHOPPER ,CHOPPER ,SQUOT ,CHOPPER ,SQUOT ,CHOPPER ,VAL-R!]>
931 <GDECL (RMODES) <VECTOR [REST STRING]> (RDOIT SDOIT) UVECTOR>
933 "Create a node for a call to a function."
935 <DEFINE PFUNC (OB AP "AUX" TEM NAME)
936 #DECL ((OB) <PRIMTYPE LIST> (VALUE) NODE)
937 <COND (<TYPE? <1 .OB> ATOM>
938 <COND (<OR <==? <1 .OB> .FCNS>
939 <AND <TYPE? .FCNS LIST> <MEMQ <1 .OB> <CHTYPE .FCNS LIST>>>>
940 <RSUBR-CALL2 ,<1 .OB> <1 .OB> .OB>)
941 (<SET TEM <GET <1 .OB> RSUB-DEC>>
942 <RSUBR-CALL3 .TEM <1 .OB> .OB>)
943 (.REASONABLE <PSUBR-C .OB DUMMY>)
945 <MESSAGE WARNING "UNCOMPILED FUNCTION CALLED " <1 .OB>>
946 <PAPDEF .OB ,<1 .OB>>)>)
947 (<TYPE? <1 .OB> FUNCTION>
948 <SET NAME <MAKE:TAG "ANONF">>
949 <ANONF .NAME <1 .OB>>
950 <RSUBR-CALL1 ,.NAME .NAME .OB>)>>
952 "Call compiler recursively to compile anonymous function."
954 <DEFINE ANONF (NAME BODY "AUX" (INT? <>) T GROUP-NAME)
955 #DECL ((INT? GROUP-NAME) <SPECIAL <OR FALSE ATOM>> (VALUE) NODE)
956 <MESSAGE NOTE " COMPILING ANONYMOUS FUNCTION ">
958 <APPLY ,COMP2 .NAME T> ; "Use APPLY to avoid compilation probs."
960 <MESSAGE NOTE " FINISHED ANONYMOUS FUNCTION ">
962 <NODE1 ,QUOTE-CODE .PARENT RSUBR .T ()>>
964 "#FUNCTION (....) compiler -- call ANONF."
966 <DEFINE FCN-FCN (OB "AUX" (NAME <MAKE:TAG "ANONF">)) <ANONF .NAME .OB>>
968 <PUT FUNCTION PTHIS-TYPE ,FCN-FCN>
970 <PUT FUNCTION PAPPLY-TYPE ,PFUNC>
972 "<FUNCTION (..) ....> compiler -- call ANONF."
974 <DEFINE FCN-FCN1 (OB AP "AUX" (NAME <MAKE:TAG "ANONF">))
975 #DECL ((OB) <PRIMTYPE LIST>)
976 <ANONF .NAME <CHTYPE <REST .OB> FUNCTION>>>
978 <PUT ,FUNCTION PAPPLY-OBJECT ,FCN-FCN1>
980 "Handle RSUBR that is really a function."
982 <DEFINE RSUBR-CALL2 (BODY NAME OBJ "AUX" ACF
983 (PARENT <NODEFM ,RSUBR-CODE .PARENT <> .NAME () .BODY>))
984 #DECL ((PARENT) <SPECIAL NODE> (VALUE) NODE)
987 <PRSUBR-C .NAME .OBJ <RSUBR-DECLS <SET ACF <PASS1 .BODY .NAME T .NAME>>>>>
988 <PUT .PARENT ,TYPE-INFO
990 <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>>
992 "Handle an RSUBR that is already an RSUBR."
994 <DEFINE RSUBR-CALL1 (BODY NAME OBJ "AUX"
995 (PARENT <NODEFM ,RSUBR-CODE .PARENT <> .NAME () .BODY>))
996 #DECL ((BODY) <PRIMTYPE LIST> (PARENT) <SPECIAL NODE>
998 <PUT .PARENT ,KIDS <PRSUBR-C .NAME .OBJ <3 .BODY>>>
999 <PUT .PARENT ,TYPE-INFO
1001 <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>>
1003 <DEFINE RSUBR-CALL3 (DC NAME OBJ "AUX"
1004 (PARENT <NODEFM ,RSUBR-CODE .PARENT <> .NAME () FOO>))
1005 #DECL ((PARENT) <SPECIAL NODE>
1007 <PUT .PARENT ,KIDS <PRSUBR-C .NAME .OBJ .DC>>
1008 <PUT .PARENT ,TYPE-INFO
1010 <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>>
1013 ;"ILIST, ISTRING, IVECTOR AND IUVECTOR"
1015 <DEFINE PLIST (O A) <PSTRUC .O .A ILIST LIST>>
1017 <PUT ,ILIST PAPPLY-OBJECT ,PLIST>
1019 <DEFINE PIVECTOR (O A) <PSTRUC .O .A IVECTOR VECTOR>>
1021 <PUT ,IVECTOR PAPPLY-OBJECT ,PIVECTOR>
1023 <DEFINE PISTRING (O A) <PSTRUC .O .A ISTRING STRING>>
1025 <PUT ,ISTRING PAPPLY-OBJECT ,PISTRING>
1027 <DEFINE PIUVECTOR (O A) <PSTRUC .O .A IUVECTOR UVECTOR>>
1029 <PUT ,IUVECTOR PAPPLY-OBJECT ,PIUVECTOR>
1031 <DEFINE PIFORM (O A) <PSTRUC .O .A IFORM FORM>>
1033 <PUT ,IFORM PAPPLY-OBJECT ,PIFORM>
1035 <DEFINE PIBYTES (O A) <PSTRUC .O .A IBYTES BYTES>>
1037 <PUT ,IBYTES PAPPLY-OBJECT ,PIBYTES>
1039 <DEFINE PSTRUC (OBJ AP NAME TYP "AUX" (TT <NODEFM ,ISTRUC-CODE .PARENT .TYP .NAME
1041 (LN <LENGTH .OBJ>) N EV SIZ)
1042 #DECL ((VALUE N EV TT) NODE (LN) FIX (OBJ) <PRIMTYPE LIST>)
1043 <COND (<SEG? .OBJ><PSUBR-C .OBJ .AP>)
1045 <COND (<==? .NAME IBYTES>
1046 <COND (<L=? .LN 2> <ARGCHK 2 3 .NAME>)
1047 (<G? .LN 4> <ARGCHK .LN 4 .NAME>)>)
1048 (<1? .LN><ARGCHK 1 2 .NAME>)
1049 (<G? .LN 3><ARGCHK .LN 3 .NAME>)>
1050 <COND (<==? .NAME IBYTES>
1051 <SET SIZ <PCOMP <2 .OBJ> .TT>>
1052 <SET OBJ <REST .OBJ>>
1053 <SET LN <- .LN 1>>)>
1054 <SET N <PCOMP <2 .OBJ> .TT>>
1055 <SET EV <PCOMP <COND (<==? .LN 3> <3 .OBJ>)
1056 (<==? .TYP STRING> <ASCII 0>)
1057 (<==? .TYP BYTES> 0)
1058 (ELSE #LOSE 0)> .TT>>
1059 <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
1060 <SET EV <PCOMP <NODE-NAME .EV> .TT>> ;"Reanalyze it."
1061 <PUT .TT ,NODE-TYPE ,ISTRUC2-CODE>)>
1062 <PUT .TT ,RESULT-TYPE .TYP>
1063 <COND (<ASSIGNED? SIZ> <PUT .TT ,KIDS (.SIZ .N .EV)>)
1064 (ELSE <PUT .TT ,KIDS (.N .EV)>)>)>>
1068 "READ, READCHR, READSTRING, NEXTCHR, READB, GET, GETL, GETPROP, GETPL"
1070 <PUT ,READ PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A READ 2 ANY>>>
1072 <PUT ,GC-READ PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A GC-READ 2 ANY>>>
1074 <PUT ,READCHR PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A READCHR 2 ANY>>>
1076 <PUT ,NEXTCHR PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A NEXTCHR 2 ANY>>>
1078 <PUT ,READB PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A READB 3 ANY>>>
1082 <FUNCTION (O A) <CHANFCNS .O .A READSTRING 4 ANY>>>
1084 <DEFINE CHANFCNS (OBJ AP NAME ARGN TYP "AUX" TT (LN <LENGTH .OBJ>) N (TEM 0))
1085 #DECL ((VALUE) NODE (TT) NODE (N) <LIST [REST NODE]>
1086 (LN) FIX (TEM ARGN) FIX (OBJ) <PRIMTYPE LIST>)
1087 <COND (<OR <SEG? .OBJ> <L? <- .LN 1> .ARGN>>
1090 <SET TT <NODEFM ,READ-EOF-CODE .PARENT .TYP .NAME () ,.NAME>>
1093 <FUNCTION (OB "AUX" (EV <PCOMP .OB .TT>))
1095 <COND (<==? <SET TEM <+ .TEM 1>> .ARGN>
1096 <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
1097 <SET EV <PCOMP <NODE-NAME .EV> .TT>>
1098 <PUT .TT ,NODE-TYPE ,READ-EOF2-CODE>)>
1100 <NODE1 ,EOF-CODE .TT
1101 <RESULT-TYPE .EV> <> (.EV)>>)>
1104 <PUT .TT ,KIDS .N>)>>
1106 <PUT ,GET PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GET>>>
1108 <PUT ,GETL PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GETL>>>
1110 <PUT ,GETPROP PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GETPROP>>>
1112 <PUT ,GETPL PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GETPL>>>
1114 <DEFINE GETFCNS (OBJ AP NAME "AUX" EV TEM T2 (LN <LENGTH .OBJ>) TT)
1115 #DECL ((OBJ) FORM (LN) FIX (TT VALUE TEM T2 EV) NODE)
1116 <COND (<OR <AND <N==? .LN 4>
1117 <N==? .LN 3>> <SEG? .OBJ>>
1120 <SET TT <NODEFM ,GET-CODE .PARENT ANY .NAME () ,.NAME>>
1121 <SET TEM <PCOMP <2 .OBJ> .TT>>
1122 <SET T2 <PCOMP <3 .OBJ> .TT>>
1124 <PUT .TT ,NODE-TYPE ,GET2-CODE>
1125 <PUT .TT ,KIDS (.TEM .T2)>)
1127 <SET EV <PCOMP <4 .OBJ> .TT>>
1128 <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
1129 <SET EV <PCOMP <NODE-NAME .EV> .TT>>
1130 <PUT .TT ,NODE-TYPE ,GET2-CODE>)>
1131 <PUT .TT ,KIDS (.TEM .T2 .EV)>)>
1134 <DEFINE ARGCHK (GIV REQ NAME "AUX" (HI .REQ) (LO .REQ))
1135 #DECL ((GIV) FIX (REQ HI LO) <OR <LIST FIX FIX> FIX>)
1136 <COND (<TYPE? .REQ LIST>
1139 <COND (<L? .GIV .LO>
1140 <MESSAGE ERROR "TOO FEW ARGS TO " .NAME>)
1142 <MESSAGE ERROR "TOO MANY ARGS TO " .NAME>)> T>