26 INTERPRETER-IMPLEMENTOR?
33 <PUT-DECL BOOLEAN '<OR ATOM !<FALSE>>>
35 <PUT-DECL BOOL-TRUE ATOM>
37 <PUT-DECL BOOL-FALSE '!<FALSE>>
39 <USE "COMPDEC" "ADVMESS">
41 <SETG INTERPRETER-IMPLEMENTOR? T>
47 <SETG DECL-ITEM-COUNT 3>
51 <SETG DECL-IN-COUNT-VEC 5>
53 <SETG DECL-REST-VEC 6>
66 <MANIFEST HIGHBOUND LOWBOUND>
68 <SETG ALLWORDS '<PRIMTYPE WORD>>
70 <DEFINE TASTEFUL-DECL (D "AUX" TEM TT)
71 <COND (<OR <NOT .D> <==? .D NO-RETURN>> ANY)
72 (<AND <TYPE? .D ATOM> <VALID-TYPE? .D>> .D)
73 (<AND <OR <TYPE? <SET TEM .D> ATOM> <SET TEM <ISTYPE? .D>>>
74 <SET TT <DECL-GET .TEM>>>
75 <COND (<OR <==? .TEM BOOLEAN>
80 (<TYPE? .D FORM SEGMENT>
82 <OR <AND <EMPTY? .D> ANY> <TASTEFUL-DECL <1 .D>>>)
83 (<==? <1 .D> FIX> FIX)
84 (<AND <==? <LENGTH .D> 2> <==? <1 .D> NOT>> ANY)
86 <CHTYPE <MAPF ,LIST ,TASTEFUL-DECL .D> SEGMENT>)
87 (ELSE <CHTYPE <MAPF ,LIST ,TASTEFUL-DECL .D> FORM>)>)
89 [<COND (<==? <1 .D> OPT> OPTIONAL) (ELSE <1 .D>)>
90 !<MAPF ,LIST ,TASTEFUL-DECL <REST .D>>])
93 <DEFINE TMERGE (P1 P2 "AUX" TEM)
94 <COND (<OR <==? .P1 ANY> <==? .P2 ANY>> ANY)
96 (<AND <TYPE? .P1 FORM>
99 <OR <AND <==? <2 .P1> ANY> .P2> ANY>>)
100 (<AND <TYPE? .P2 FORM>
103 <OR <AND <==? <2 .P2> ANY> .P1> ANY>>)
104 (<AND <TYPE? .P1 ATOM>
106 <OR <==? .P1 BOOL-TRUE>
109 <OR <==? .P2 BOOL-TRUE>
113 (<OR <AND <TYPE? .P1 FORM SEGMENT>
115 <TYPE? <2 .P1> LIST>>
116 <AND <TYPE? .P2 FORM SEGMENT>
118 <TYPE? <2 .P2> LIST>>
119 <CTMATCH .P1 .P2 <> <> T>>
120 <CTMATCH .P1 .P2 T T <>>)
121 (ELSE <CHTYPE (OR !<PUT-IN <PUT-IN () .P1> .P2>) FORM>)>>
123 <DEFINE TYPE-AND (P1 P2)
124 <COND (<NOT .P1> <SET P1 ANY>)>
125 <COND (<NOT .P2> <SET P2 ANY>)>
126 <COND (<==? .P1 ANY> .P2)
129 (ELSE <CTMATCH .P1 .P2 T <> <>>)>>
131 <DEFINE TMATCH (P1 P2)
132 <COND (<==? .P1 ANY> .P2)
135 (ELSE <CTMATCH .P1 .P2 <> <> <>>)>>
137 <DEFINE CTMATCH (P1 P2 ANDF ORF MAYBEF "AUX" X)
138 #DECL ((ANDF ORF MAYBEF) <SPECIAL <OR FALSE ATOM>>)
141 <DEFINE DTMATCH (PAT1 PAT2 "AUX" (ORF .ORF) FP1 FP2)
142 <OR .PAT1 <SET PAT1 ANY>>
143 <OR .PAT2 <SET PAT2 ANY>>
144 <COND (<==? .PAT2 BOOLEAN> <SET PAT2 .PAT1> <SET PAT1 BOOLEAN>)
145 (<==? .PAT2 BOOL-TRUE> <SET PAT2 .PAT1> <SET PAT1 BOOL-TRUE>)
146 (<==? .PAT2 BOOL-FALSE> <SET PAT2 .PAT1> <SET PAT1 BOOL-FALSE>)>
147 <COND (<OR <==? .PAT1 .PAT2>
148 <AND <OR <AND <TYPE? .PAT1 FORM> <TYPE? .PAT2 FORM>>
149 <AND <TYPE? .PAT1 SEGMENT> <TYPE? .PAT2 SEGMENT>>>
150 <==? <LENGTH <CHTYPE .PAT1 LIST>>
151 <LENGTH <CHTYPE .PAT2 LIST>>>
152 <==? <CALL TYPE <SET FP1 <1 <CHTYPE .PAT1 LIST>>>>
153 <CALL TYPE <SET FP2 <1 <CHTYPE .PAT2 LIST>>>>>
154 <COND (<TYPE? .FP1 ATOM> <==? .FP1 .FP2>) (ELSE T)>
157 (<AND <==? .PAT1 BOOLEAN>
159 <OR <==? .PAT2 BOOL-TRUE> <==? .PAT2 BOOL-FALSE>>
162 <OR <AND <==? .PAT1 BOOL-TRUE> BOOL-TRUE>
163 <AND <==? .PAT2 BOOL-FALSE> BOOL-FALSE>>>>>)
164 (<AND <NOT .ORF> <==? .PAT1 BOOL-FALSE>>
165 <COND (<TEXP1 '!<FALSE> .PAT2> BOOL-FALSE)>)
166 (<AND <NOT .ORF> <==? .PAT1 BOOL-TRUE>>
167 <COND (<TYPMAT ATOM .PAT2> BOOL-TRUE)>)
168 (<AND <NOT .ORF> <==? .PAT1 BOOLEAN>>
169 <COND (<TYPMAT ATOM .PAT2>
170 <COND (<TEXP1 '!<FALSE> .PAT2> BOOLEAN)
172 (<TEXP1 '!<FALSE> .PAT2> BOOL-FALSE)>)
173 (<TYPE? <SET PAT1 <VTS .PAT1>> ATOM> <TYPMAT .PAT1 <VTS .PAT2>>)
174 (<TYPE? <SET PAT2 <VTS .PAT2>> ATOM> <TYPMAT .PAT2 .PAT1>)
175 (<AND <TYPE? .PAT1 FORM SEGMENT> <TYPE? .PAT2 FORM SEGMENT>>
177 (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
180 <OR <AND <TYPE? .X ATOM>
187 <AND <TYPE? .X ATOM> <DECL-GET .X>>
191 #DECL ((OBJ) <PRIMTYPE LIST>)
192 <AND <NOT <EMPTY? .OBJ>> <NOT <EMPTY? <REST .OBJ>>>>>
194 <DEFINE TYPMAT (TYP PAT "AUX" TEM TT (ORF .ORF))
197 <COND (<TYPE? .PAT ATOM>
198 <OR <AND <==? .PAT ANY> <COND (.ORF ANY) (ELSE .TYP)>>
199 <AND <==? .TYP ANY> <COND (.ORF ANY) (ELSE .PAT)>>
200 <AND <==? .PAT .TYP> .TYP>
201 <AND <==? <GETPROP .PAT ALT-DECL '.PAT>
202 <SET TT <GETPROP .TYP ALT-DECL '.TYP>>>
204 <COND (<==? .TT .TYP> .PAT)
208 <STRUC .PAT .TYP <>>>)
209 (<TYPE? .PAT FORM SEGMENT> <TEXP1 .PAT .TYP>)
210 (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
212 <OR <AND <N==? <SET TEM <VTS .TYP>> .TYP> <DTMATCH .TEM .PAT>>
213 <AND <N==? <SET TEM <VTS .PAT>> .PAT>
214 <TYPMAT .TYP .TEM>>>>>>
218 <DEFINE TEXP1 (FORT PAT "AUX" FST)
219 #DECL ((FORT) <OR FORM SEGMENT>)
220 <COND (<EMPTY? .FORT> #FALSE (EMPTY-TYPE-FORM!-ERRORS))
221 (<OR <==? <SET FST <1 .FORT>> OR>
226 (<AND <==? .FST QUOTE>
227 <==? <LENGTH .FORT> 2>>
228 <DTMATCH <GEN-DECL <2 .FORT>> .PAT>)
229 (ELSE <FORMATCH .FORT .PAT>)>>
231 <DEFINE ACTORT (FORT PAT "AUX" (ACTOR <1 .FORT>) TEM1 (ORF .ORF) (ANDF .ANDF))
232 #DECL ((FORT) <PRIMTYPE LIST>)
236 (<EMPTY? <SET FORT <REST .FORT>>> #FALSE (EMPTY-OR-MATCH!-ERRORS))
238 <REPEAT (TEM (AL ()))
241 (<OR <AND <TYPE? <SET TEM <1 .FORT>> ATOM>
243 <COND (<VALID-TYPE? .TEM>)
244 (<SET TEM1 <DECL-GET .TEM>>
246 <AND <TYPE? .TEM ATOM> <AGAIN>>)
248 <SET TEM <TYPMAT .TEM .PAT>>>
249 <AND <TYPE? .TEM FORM SEGMENT> <SET TEM <TEXP1 .TEM .PAT>>>>
252 <COND (<==? .TEM ANY> <RETURN ANY>)>
253 <COND (.ORF <SET AL <PUT-IN .AL .TEM>>)
255 <OR <MEMBER .TEM .AL>
256 <SET AL (.TEM !.AL)>>)>)>)
258 (<NOT <EMPTY? .TEM>> <RETURN .TEM>)>
259 <COND (<EMPTY? <SET FORT <REST .FORT>>>
260 <RETURN <AND <NOT <EMPTY? .AL>>
261 <COND (<EMPTY? <REST .AL>> <1 .AL>)
263 <ORSORT <CHTYPE (.ACTOR !.AL)
265 (<==? .ACTOR NOT> <NOT-IT .FORT .PAT>)
266 (ELSE <PTACT .FORT .PAT>)>>
268 <DEFINE PTACT (FORTYP PAT)
269 <COND (<TYPE? .FORTYP FORM SEGMENT>
270 <COND (<AND <==? <LENGTH .FORTYP> 2> <==? <1 .FORTYP> PRIMTYPE>>
271 <PRIMATCH .FORTYP .PAT>)
272 (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
273 (<TYPE? .FORTYP ATOM> <TYPMAT .FORTYP .PAT>)
274 (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
277 <DEFINE STRUC (WRD TYP ACTAND "AUX" TC)
280 <COND (<COND (<==? .WRD STRUCTURED>
281 <COND (<==? .TYP APPLICABLE>
282 <RETURN <COND (.ORF '<OR APPLICABLE STRUCTURED>)
290 (<AND <SET TC <VALID-TYPE? .TYP>>
291 <OR <==? <SET TC <ANDB .TC 7>> 1>
293 <AND ,INTERPRETER-IMPLEMENTOR?
295 <SET MT <GC-PRIMTYPE <TYPE-C .TYP>>>
299 <==? .MT FRAME>>>>>)>)
300 (<==? .WRD APPLICABLE>
301 <COND (<==? .TYP STRUCTURED>
302 <RETURN <STRUC .TYP .WRD .ACTAND>>)
304 '[MSUBR T$MSUBR FUNCTION T$FUNCTION MACRO
305 T$MACRO OFFSET T$OFFSET FIX]>)>)>
306 <COND (.ORF .WRD) (ELSE .TYP)>)
308 <COND (<AND .ORF <NOT .ACTAND>> <ORSORT <FORM OR .WRD .TYP>>)
311 <DEFINE PRIMATCH (PTYP PAT "AUX" PAT1 ACTOR TEM (ORF .ORF) (ANDF .ANDF))
312 #DECL ((PAT1) <PRIMTYPE LIST>
313 (PTYP) <OR <FORM ANY ANY> <SEGMENT ANY ANY>>)
314 <COND (<AND <TYPE? .PAT FORM SEGMENT>
316 <==? <LENGTH .PAT1> 2>
317 <==? <1 .PAT1> PRIMTYPE>>
318 <COND (<OR <==? <2 .PAT1> <2 .PTYP>>
319 <==? <GC-PRIMTYPE <TYPE-C <2 .PAT1>>>
320 <GC-PRIMTYPE <TYPE-C <2 .PTYP>>>>>
322 (ELSE <COND (.ORF <ORSORT <FORM OR .PAT1 .PTYP>>)>)>)
324 <COND (<==? .PAT ANY> <COND (.ORF ANY) (.ANDF .PTYP) (ELSE T)>)
325 (<OR <==? .PAT STRUCTURED> <==? .PAT APPLICABLE>>
326 <COND (<STRUC .PAT <2 .PTYP> T>
327 <COND (.ORF .PAT) (ELSE .PTYP)>)
329 <COND (.ORF <ORSORT <FORM OR .PAT .PTYP>>)>)>)
330 (<COND (<VALID-TYPE? .PAT>
331 <COND (<==? <GC-PRIMTYPE <TYPE-C .PAT>>
332 <GC-PRIMTYPE <TYPE-C <2 .PTYP>>>>
333 <COND (.ORF .PTYP) (ELSE .PAT)>)>)
334 (<N==? <SET TEM <DECL-GET .PAT>> .PAT>
335 <PRIMATCH .PTYP .TEM>)>)
336 (ELSE <COND (.ORF <ORSORT <FORM OR .PTYP .PAT>>)>)>)
337 (<AND <TYPE? .PAT FORM SEGMENT>
339 <NOT <EMPTY? .PAT1>>>
340 <COND (<==? <SET ACTOR <1 .PAT1>> OR> <ACTORT .PAT .PTYP>)
342 <COND (.ORF <NOT-IT .PAT .PTYP>)
344 <SET TEM <PRIMATCH .PTYP <2 .PAT1>>>
345 <COND (<AND <NOT .TEM> <EMPTY? .TEM>> .PTYP)
347 (<NOT <AND <TYPE? .TEM FORM SEGMENT>
348 <==? <LENGTH .TEM> 2>
349 <==? <1 .TEM> PRIMTYPE>
350 <==? <2 .TEM> <2 .PTYP>>>>
352 (<SET TEM <PRIMATCH .PTYP <1 .PAT1>>>
355 <COND (<TYPE? .PAT FORM>
356 <FORM .TEM !<REST .PAT1>>)
358 <CHTYPE (.TEM !<REST .PAT1>) SEGMENT>)>)
363 <DEFINE NOT-IT (NF PAT "AUX" T1)
364 #DECL ((NF) <OR FORM SEGMENT>)
365 <COND (<AND <TYPE? .PAT FORM SEGMENT>
367 <OR <==? <1 .PAT> OR> <==? <1 .PAT> AND>>>
370 <COND (<==? <LENGTH .NF> 2>
371 <COND (<NOT <SET T1 <TYPE-AND <2 .NF> .PAT>>>
372 <COND (.ORF .NF) (.ANDF .PAT) (ELSE T)>)
373 (<==? <2 .NF> ANY> <COND (.ORF .PAT)>)
374 (<==? <SET T1 <VTS .T1>>
375 <SET PAT <VTS .PAT>>>
377 (<OR <AND <TYPE? .PAT ATOM> <TYPE? .T1 ATOM>>
378 <AND <OR <N==? <CALL TYPE .T1> <CALL TYPE .PAT>>
380 <N=? <CANONICAL-DECL .PAT>
381 <CANONICAL-DECL .T1>>>>
383 (.ORF ANY) (ELSE T)>)
385 (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)>>
388 <COND (<AND <TYPE? .D FORM SEGMENT>
392 (ELSE <FORM NOT .D>)>>
396 <DEFINE FORMATCH (FRM RPAT "AUX" TEM (PAT .RPAT) EX (ORF .ORF) (ANDF .ANDF))
397 #DECL ((FRM) <OR <FORM ANY> <SEGMENT ANY>>
398 (RPAT) <OR ATOM FORM LIST SEGMENT VECTOR FIX>)
400 (<AND <TYPE? .RPAT ATOM> <TYPE? <1 .FRM> ATOM> <==? <1 .FRM> .RPAT>>
401 <COND (.ORF .RPAT) (ELSE .FRM)>)
403 <COND (<TYPE? .RPAT ATOM> <SET PAT <SET EX <DECL-GET .RPAT .RPAT>>>)
404 (ELSE <SET RPAT <1 .PAT>>)>
408 <COND (<AND .ORF <NOT <CTMATCH .PAT <1 .FRM> <> <> T>>>
409 <ORSORT <FORM OR .RPAT .FRM>>)
411 <COND (<TYPE? <1 .FRM> ATOM> <TYPMAT <1 .FRM> .PAT>)
412 (<TYPE? <1 .FRM> FORM> <ACTORT <1 .FRM> .PAT>)>)>>
413 <COND (<AND .ANDF <NOT .ORF> .TEM>
414 <COND (<TYPE? .FRM FORM> <CHTYPE (.TEM !<REST .FRM>) FORM>)
415 (ELSE <CHTYPE (.TEM !<REST .FRM>) SEGMENT>)>)
417 (<TYPE? .PAT FORM SEGMENT>
418 <COND (<OR <==? <SET TEM <1 .PAT>> OR>
424 <COND (<AND <==? <LENGTH .PAT> 2> <TYPE? <2 .PAT> LIST>>
425 <WRDFX .PAT .FRM .RPAT>)
428 <NOT <CTMATCH .RPAT .FRM <> <> T>>>
429 <ORSORT <FORM OR .RPAT .FRM>>)
430 (<AND .ORF <NOT <CTMATCH .PAT .FRM <> <> T>>>
431 <ORSORT <FORM OR .PAT .FRM>>)
433 <SET TEM <ELETYPE .PAT .FRM .RPAT>>
435 <TYPE? .TEM FORM SEGMENT>
440 <AND <=? <1 .EL> .EX>
448 <DEFINE FOSE ("TUPLE" TUP "AUX" (FLG <1 .TUP>))
449 <COND (.FLG <CHTYPE (!<REST .TUP>) SEGMENT>)
450 (ELSE <CHTYPE (!<REST .TUP>) FORM>)>>
452 <DEFINE SEGANDOR (F1 F2 ORF)
453 <SET F1 <REAL-SEG? .F1>>
454 <SET F2 <REAL-SEG? .F2>>
455 <COND (.ORF <AND <TYPE? .F1 SEGMENT> <TYPE? .F2 SEGMENT>>)
456 (ELSE <OR <TYPE? .F1 SEGMENT> <TYPE? .F2 SEGMENT>>)>>
458 <DEFINE REAL-SEG? (F "AUX" LAST)
459 <COND (<AND <TYPE? .F SEGMENT>
461 <TYPE? <SET LAST <NTH .F <LENGTH .F>>> VECTOR>
462 <==? <1 .LAST> REST>>
466 <DEFINE WRDFX (F11 F22 RPAT
467 "AUX" (F1 <CHTYPE .F11 FORM>) (F2 <CHTYPE .F22 FORM>) FST TL)
468 #DECL ((F11 F22) <OR FORM SEGMENT> (F1 F2) FORM)
469 <COND (<OR <EMPTY? .F1> <EMPTY? .F2>> #FALSE (EMPTY-FORM-IN-DECL!-ERRORS))>
471 <COND (<TYPE? .RPAT ATOM>
472 <COND (<TYPE? <1 .F2> ATOM> <TYPMAT <1 .F2> .RPAT>)
473 (<TYPE? <1 .F2> FORM> <ACTORT <1 .F2> .RPAT>)
474 (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
475 (<TYPE? .RPAT FORM> <ACTORT .RPAT <1 .F2>>)
476 (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
480 <COND (<CTMATCH .RPAT ,ALLWORDS <> <> <>>
481 <COND (<AND <==? <LENGTH .F2> 2> <TYPE? <2 .F2> LIST>>
482 <COND (<CTMATCH <1 .F2> ,ALLWORDS <> <> <>>
484 <SET TL <MAP-MERGE !<2 .F1> !<2 .F2>>>
485 <COND (<EMPTY? .TL> .FST)
486 (ELSE <FORM .FST .TL>)>)
487 (<SET TL <AND-MERGE <2 .F1> <2 .F2>>>
489 (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
490 (ELSE <COND (.ORF <ORSORT <FORM OR .F11 .F22>>) (ELSE <>)>)>)
491 (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)>>
493 <DEFINE MAP-MERGE ("TUPLE" PAIRS "AUX" (HIGH <2 .PAIRS>) (LOW <1 .PAIRS>))
494 #DECL ((PAIRS) <<PRIMTYPE VECTOR> [REST FIX]> (HIGH LOW) FIX)
496 <COND (<EMPTY? <SET PAIRS <REST .PAIRS 2>>> <RETURN>)>
497 <SET HIGH <MAX .HIGH <2 .PAIRS>>>
498 <SET LOW <MIN .LOW <1 .PAIRS>>>>
499 <COND (<AND <==? .HIGH <CHTYPE <MIN> FIX>>
500 <==? .LOW <CHTYPE <MAX> FIX>>>
502 (ELSE (.LOW .HIGH))>>
504 <DEFINE AND-MERGE (L1 L2 "AUX" (FLG <>) HIGH LOW TEM (L (0)) (LL .L))
505 #DECL ((L LL L1 L2) <LIST [REST FIX]> (HIGH LOW) FIX)
506 <COND (<G? <LENGTH .L1> <LENGTH .L2>>
513 <REPEAT ((L1 .L1) LO HI)
514 #DECL ((L1) <LIST [REST FIX]> (LO HI) FIX)
515 <COND (<EMPTY? .L1> <RETURN>)>
517 <COND (<OR <AND <G=? <SET LO <1 .L1>> .LOW>
519 <AND <L=? .HI .HIGH> <G=? .HI .LOW>>
520 <AND <G=? .LOW .LO> <L=? .LOW .HI>>
521 <AND <L=? .HIGH .HI> <G=? .HIGH .LO>>>
522 <SET LOW <MAX .LOW .LO>>
523 <SET HIGH <MIN .HIGH .HI>>
524 <SET L <REST <PUTREST .L (.LOW .HIGH)> 2>>
527 <SET L1 <REST .L1 2>>>
528 <COND (<EMPTY? <SET L2 <REST .L2 2>>>
529 <RETURN <COND (.FLG <REST .LL>) (ELSE <>)>>)>>>
533 <DEFINE GET-RANGE (L1 "AUX" TT)
534 <COND (<AND <TYPE? .L1 FORM>
535 <TMATCH .L1 ,ALLWORDS>
536 <TYPE? <2 .L1> LIST>>
537 <COND (<NOT <EMPTY? <SET TT <MAP-MERGE !<2 .L1>>>>> .TT)>)>>
541 <DEFINE ELETYPE (F1 F2 RTYP
542 "AUX" (S1 <STACK <VECTOR .F1 <> 0 <> <> '[]>>) (FAIL <>)
543 (S2 <STACK <VECTOR .F2 <> 0 <> <> '[]>>) (FL ()) (FP '<>)
544 (INOPT <>) FSTL SEGF RTEM (ORF .ORF) (ANDF .ANDF))
545 #DECL ((S1 S2) <VECTOR <PRIMTYPE LIST> ANY FIX ANY ANY ANY>
546 (F1 F2) <PRIMTYPE LIST> (FP) <OR FORM SEGMENT> (FL) LIST)
547 <SET SEGF <SEGANDOR .F1 .F2 .ORF>>
549 (<OR <EMPTY? .F1> <EMPTY? .F2>> #FALSE (EMPTY-FORM-IN-DECL!-ERRORS))
550 (<AND .ANDF .ORF <NOT <TMATCH <1 .F2> .RTYP>>> <ORSORT <FORM OR .F1 .F2>>)
554 <COND (<TYPE? .RTYP ATOM>
555 <COND (<TYPE? <1 .F2> ATOM> <TYPMAT .RTYP <1 .F2>>)
556 (<TYPE? <1 .F2> FORM> <ACTORT <1 .F2> .RTYP>)
557 (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
558 (<TYPE? .RTYP FORM> <ACTORT .RTYP <1 .F2>>)
559 (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
563 <COND (.SEGF <CHTYPE (.FSTL) SEGMENT>)
564 (ELSE <FORM .FSTL>)>>
566 <PUT .S1 ,DECL-RESTED <REST .F1>>
567 <PUT .S2 ,DECL-RESTED <REST .F2>>
568 <REPEAT ((TEM1 <>) (TEM2 <>) T1 T2 TEM TT)
569 #DECL ((TT) <VECTOR FIX ANY>)
572 (<AND <OR <AND <SET TEM1 <NEXTP .S1>> <SET T1 <DECL-ELEMENT .S1>>>
573 <AND <EMPTY? .TEM1> <SET T1 ANY>>>
574 <OR <AND <SET TEM2 <NEXTP .S2>> <SET T2 <DECL-ELEMENT .S2>>>
575 <AND .TEM1 <EMPTY? .TEM2> <SET T2 ANY>>>>
576 <COND (<AND .ORF <OR <NOT .TEM1> <NOT .TEM2>>>
577 <RETURN <ONE-CHECK .FP .SEGF>>)>
581 <COND (<OR <TYPE? .F1 FORM>
583 <DECL-IN-COUNT-VEC .S2>>
585 (ELSE <SET FAIL T> <>)>)
587 <COND (<OR <TYPE? .F2 FORM>
589 <DECL-IN-COUNT-VEC .S1>>
591 (ELSE <SET FAIL T> <>)>)
592 (ELSE <DTMATCH .T1 .T2>)>>>
593 <COND (.ORF <SET TEM <ORSORT <FORM OR .T1 .T2>>>)
594 (.MAYBEF <COND (.FAIL <RETURN <>>) (ELSE <SET FAIL T>)>)
596 <COND (<AND <NOT .INOPT>
598 <OR <DECL-IN-COUNT-VEC .S1>
599 <DECL-IN-COUNT-VEC .S2>>>
602 <DECL-IN-COUNT-VEC .S1>
603 <DECL-IN-COUNT-VEC .S2>>>>
604 <SET INOPT <COND (.ANDF (OPTIONAL .TEM)) (ELSE ())>>)
606 <PUTREST <REST .INOPT <- <LENGTH .INOPT> 1>> (.TEM)>)>
609 <OR <0? <DECL-ITEM-COUNT .S1>>
610 <0? <DECL-ITEM-COUNT .S2>>>>
612 <0? <DECL-ITEM-COUNT .S1>>
613 <0? <DECL-ITEM-COUNT .S2>>>>>
614 <AND .ANDF <SET TEM [!.INOPT]>>
618 <OR <DECL-IN-REST .S1> <DECL-IN-REST .S2>>>
619 <AND <OR <DECL-IN-REST .S1>
620 <AND .ANDF <OR <NOT .TEM1> <DECL-IN-COUNT-VEC .S1>>>>
621 <OR <DECL-IN-REST .S2>
623 <OR <NOT .TEM2> <DECL-IN-COUNT-VEC .S2>>>>>>
632 <TYPE? .F2 SEGMENT>>>>
634 <RETURN <ONE-CHECK .FP .SEGF>>)
636 <RETURN <COND (<AND <TYPE? .T1 FORM SEGMENT>
646 <TYPE? .F1 SEGMENT>>>>
648 <RETURN <ONE-CHECK .FP .SEGF>>)
650 <RETURN <COND (<TYPE? .T1 FORM SEGMENT>
651 <ONE-CHECK .T1 .SEGF>)
655 <OR <DECL-IN-REST .S1> <NOT .TEM1>>
656 <OR <DECL-IN-REST .S2> <NOT .TEM2>>>
658 <COND (<AND <NOT .INOPT>
661 <NOT <OR <DECL-IN-REST .S1> <DECL-IN-REST .S2>>>>>
662 <COND (<AND <TYPE? <1 .FL> VECTOR>
663 <=? <2 <SET TT <1 .FL>>> .TEM>>
664 <PUT .TT 1 <+ <1 .TT> 1>>)
665 (<AND <N==? <CHTYPE .FP LIST> .FL> <=? .TEM <1 .FL>>>
666 <PUT .FL 1 [2 .TEM]>)
667 (ELSE <SET FL <REST <PUTREST .FL (.TEM)>>>)>)>)
669 <COND (<AND <EMPTY? .TEM1> <EMPTY? <SET TEM1 .TEM2>>>
671 <RETURN <ONE-CHECK .FP .SEGF>>)
673 (ELSE <RETURN .TEM1>)>)>>)>)>>
675 <DEFINE ONE-CHECK (FP:<OR FORM SEGMENT> SEGF)
676 <COND (<AND <NOT .SEGF> <EMPTY? <REST .FP>>> <1 .FP>)
680 <DEFINE RESTER? (S1 S2 FL FST SEGF
681 "AUX" (TT <DECL-REST-VEC .S1>) (TEM1 T) (TEM2 T) (OPTIT <>))
682 #DECL ((S1 S2) <VECTOR ANY ANY ANY ANY ANY VECTOR> (FL) <LIST ANY>
684 <COND (<AND <OR .ORF <DECL-IN-COUNT-VEC .S2>>
685 <EMPTY? <DECL-RESTED .S2>>
686 <NOT <DECL-IN-REST .S2>>>
691 <OR <NOT <DECL-IN-REST .S1>> <NOT <DECL-IN-REST .S2>>>>
693 (<AND <NOT <EMPTY? .TT>>
694 <OR <NOT <DECL-IN-REST .S2>>
695 <G=? <LENGTH .TT> <LENGTH <REST <TOP <DECL-REST-VEC .S2>>>>>>>
696 <SET TT <REST <TOP .TT>>>
698 <FUNCTION (SO "AUX" T1)
699 #DECL ((SO) <VECTOR ANY>)
701 <OR <AND <SET TEM1 <NEXTP .S2>> <DECL-ELEMENT .S2>>
703 <COND (.ORF <MAPLEAVE>) (ELSE ANY)>>>>
704 <AND <OR .ORF <DECL-IN-COUNT-VEC .S2>>
705 <EMPTY? <DECL-RESTED .S2>>
706 <NOT <DECL-IN-REST .S2>>
708 <COND (<NOT .TEM1> <AND <EMPTY? .TEM1> <SET TEM1 T>>)>
713 <DTMATCH <AND <NEXTP .S1> <DECL-ELEMENT .S1>>
715 <AND <OR <NOT .T1> <NOT .TEM2>> <MAPLEAVE>>>
716 <REST <SET TT [REST .FST !<REST .TT>]> 2>>
717 <COND (.OPTIT <PUT .TT 1 OPTIONAL>)
718 (ELSE <SET TT <UNIQUE-VECTOR-CHECK .TT>>)>
719 <COND (<AND .TEM1 .TEM2> <PUTREST .FL (.TT)> T)
720 (<AND <NOT .TEM1> <NOT <EMPTY? .TEM1>>> .TEM1)
724 <DEFINE UNIQUE-VECTOR-CHECK (V "AUX" (FRST <2 .V>))
725 #DECL ((V) <VECTOR [2 ANY]>)
727 <FUNCTION (X) <COND (<N=? .X .FRST> <MAPLEAVE .V>)>>
729 (ELSE [REST .FRST])>>
731 <DEFINE NEXTP (S "AUX" TEM TT N)
732 #DECL ((S) <VECTOR <PRIMTYPE LIST> ANY FIX ANY ANY ANY> (N) FIX
734 <COND (<0? <DECL-ITEM-COUNT .S>> <PUT .S ,DECL-IN-COUNT-VEC <>>)>
735 <COND (<DECL-IN-REST .S> <NTHREST .S>)
736 (<NOT <0? <DECL-ITEM-COUNT .S>>>
737 <PUT .S ,DECL-ITEM-COUNT <- <DECL-ITEM-COUNT .S> 1>>
739 (<EMPTY? <SET TEM <DECL-RESTED .S>>> <>)
740 (<TYPE? <1 .TEM> ATOM FORM SEGMENT>
742 <PUT .S ,DECL-RESTED <REST <DECL-RESTED .S>>>
743 <PUT .S ,DECL-ELEMENT .TEM>)
744 (<TYPE? <1 .TEM> VECTOR>
746 <PUT .S ,DECL-RESTED <REST <DECL-RESTED .S>>>
747 <PUT .S ,DECL-REST-VEC <REST .TT>>
748 <COND (<G? <LENGTH .TT> 1>
749 <COND (<==? <1 .TT> REST>
750 <COND (<AND <==? <LENGTH .TT> 2>
754 <PUT .S ,DECL-IN-REST T>
757 <DECL-ELEMENT .TT>>)>)
758 (<OR <AND <TYPE? <1 .TT> FIX> <SET N <1 .TT>>>
759 <AND <OR <==? <1 .TT> OPT>
760 <==? <1 .TT> OPTIONAL>>
762 <OR <TYPE? <1 .TT> FIX>
763 <PUT .S ,DECL-IN-COUNT-VEC T>>
766 <- <* .N <- <LENGTH .TT> 1>> 1>>
767 <PUT .S ,DECL-ELEMENT <2 .TT>>
768 <COND (<L=? .N 0> <>) (ELSE .S)>)
769 (#FALSE (BAD-VECTOR-SYNTAX!-ERRORS))>)
770 (ELSE #FALSE (BAD-FORM-SYNTAX!-ERRORS))>)
771 (ELSE #FALSE (BAD-FORM-SYNTAX!-ERRORS))>>
775 <DEFINE NTHREST (S "AUX" (TEM <REST <DECL-REST-VEC .S>>))
776 #DECL ((S) <VECTOR ANY ANY ANY ANY ANY VECTOR> (TEM) VECTOR)
777 <COND (<EMPTY? .TEM> <SET TEM <REST <TOP .TEM>>>)>
778 <PUT .S ,DECL-REST-VEC .TEM>
779 <PUT .S ,DECL-ELEMENT <1 .TEM>>>
783 <DEFINE GET-ELE-TYPE (DCL2 NN
784 "OPTIONAL" (RST <>) (PT <>)
785 "AUX" PTY NN1 TYP VT (ET FIX))
787 <OR <AND <SET TYP <ISTYPE? .DCL2>>
788 <SET VT <VALID-TYPE? .TYP>>>
789 <AND <SET PTY <STRUCTYP .DCL2>>
790 <SET VT <VALID-TYPE? .PTY>>
791 <SET TYP <FORM PRIMTYPE .PTY>>>>
792 <OR <==? <SET VT <ANDB .VT 7>> 4>
793 <AND <==? .VT 5> <SET ET CHARACTER>>
796 <COND (<OR <==? .NN ALL>
798 <L=? .NN <MINL .DCL2>>>>
800 (<AND <TYPE? .NN FIX> <G? .NN 0>>
801 <FORM .TYP [.NN .ET] [REST .ET]>)>>)
804 <COND (<==? .VT 5> STRING)
807 <COND (<==? .NN ALL> .TYP)
808 (<AND <TYPE? .NN FIX>
809 <G? <SET NN1 <- <MINL .DCL2> .NN>> 0>>
810 <FORM .TYP [.NN1 .ET] [REST .ET]>)
811 (<AND <TYPE? .NN FIX> <G=? .NN 0>> .TYP)>>)
812 (<OR <==? .NN ALL> <AND <TYPE? .NN FIX> <G? .NN 0>>> .ET)
814 <ERROR BAD-CALL-TO-GET-ELE-TYPE .DCL2 .NN .RST .PT>)>)
815 (ELSE <REAL-GET-ELE-TYPE .DCL2 .NN .RST .PT>)>>
817 <DEFINE REAL-GET-ELE-TYPE (DCL2 NN RST PT
818 "AUX" (LN 0) (CNT 0) ITYP DC SDC DCL (N 0) DC1
819 (QOK <>) (FMOK <>) STRU (GD '<>) (GP ()) (K 0)
820 (DCL1 .DCL2) (SEGF <>) TEM)
821 #DECL ((LN CNT K N) FIX (DCL) <PRIMTYPE LIST> (SDC DC) VECTOR
822 (GD) <OR FORM SEGMENT> (GP) LIST)
824 <COND (<AND .PT <SET TEM <ISTYPE? .DCL1>>>
825 <SET PT <TYPE-AND <GET-ELE-TYPE .TEM .NN> .PT>>)>
826 <AND <TYPE? .DCL1 ATOM> <SET DCL1 <DECL-GET .DCL1 .DCL1>>>
827 <COND (<TYPE? .DCL1 SEGMENT> <SET SEGF T>)>
828 <COND (.RST <SET STRU <COND (<STRUCTYP .DCL1>) (ELSE STRUCTURED)>>)
831 <COND (<ISTYPE? .DCL2>)
832 (<SET STRU <STRUCTYP .DCL1>> <FORM PRIMTYPE .STRU>)
833 (ELSE STRUCTURED)>>)>
835 (<AND <TYPE? .DCL1 FORM SEGMENT>
837 <G? <SET LN <LENGTH .DCL>> 1>
838 <NOT <SET FMOK <MEMQ <1 .DCL> '[OR AND NOT]>>>
839 <NOT <SET QOK <==? <1 .DCL> QUOTE>>>
840 <NOT <==? <1 .DCL> PRIMTYPE>>>
843 <AND .PT <SET GP <CHTYPE <SET GD <FOSE .SEGF .STRU>> LIST>>>
845 <AND <TYPE? <SET DC1 <2 .DCL>> VECTOR>
849 <COND (<==? <LENGTH .DC> 2>
850 <COND (.RST <FORM .STRU [REST <2 .DC>]>)
851 (.PT <FORM .STRU [REST <TYPE-MERGE <2 .DC> .PT>]>)
853 (.RST <FORM .STRU [REST <TYPE-MERGE !<REST .DC>>]>)
858 <FUNCTION (D) <TYPE-MERGE .D .PT>>
860 (ELSE <TYPE-MERGE !<REST .DC>>)>>
861 <REPEAT (TT (CK <DCX <SET TT <2 .DCL>>>) (D .DCL) TEM)
862 #DECL ((D) <PRIMTYPE LIST>)
863 <COND (<EMPTY? <SET D <REST .D>>>
866 <AND <TYPE? .TT VECTOR> <==? <1 .TT> REST>>>>
868 <COND (.RST <FORM .STRU [REST .CK]>)
874 <SET CK <TYPE-MERGE .CK <DCX <SET TT <1 .D>>>>>
880 (<COND (<TYPE? .TT VECTOR>
883 <FUNCTION (X) <TYPE-MERGE .X .PT>>
885 (ELSE <TYPE-MERGE .PT .TT>)>)>>>>>>)
888 <AND .PT <SET GP <CHTYPE <SET GD <FOSE .SEGF .STRU>> LIST>>>
889 <AND .RST <SET N <+ .N 1>>>
890 <COND (<EMPTY? <SET DCL <REST .DCL>>>
891 <RETURN <COND (.RST .STRU)
892 (.PT <FOSE .SEGF .STRU !<ANY-PAT <- .N 1>> .PT>)
898 (<EMPTY? <SET SDC <REST .SDC>>>
901 <0? <SET CNT <- .CNT 1>>>
902 <COND (<EMPTY? <SET DCL <REST .DCL>>>
903 <RETURN <COND (.RST .STRU)
905 <PUTREST .GP (!<ANY-PAT <- .N 1>> .PT)>
910 (<TYPE? <1 .DCL> ATOM FORM SEGMENT>
912 <SET DCL <REST .DCL>>)
913 (<TYPE? <SET DC1 <1 .DCL>> VECTOR>
917 <AND <OR <AND .RST <NOT <1? .N>>> .PT>
919 <=? <2 .DC> '<NOT ANY>>
921 <SET K <MOD <- .N 1> <- <LENGTH .DC> 1>>>
922 <SET N </ <- .N 1> <- <LENGTH .DC> 1>>>
929 (ELSE [REST <TYPE-MERGE !<REST .DC>>])>>)
933 (!<COND (<L=? .N 0> ())
934 (<1? .N> (!<REST .DC>))
935 (ELSE ([.N !<REST .DC>]))>
938 <COND (<==? <SET K <- .K 1>> -1> .PT)
943 (ELSE <NTH .DC <+ .K 2>>)>>)
944 (<OR <TYPE? <1 .DC> FIX>
946 <==? <1 .DC> OPTIONAL>>
947 <SET CNT <COND (<TYPE? <1 .DC> FIX> <1 .DC>) (ELSE 1)>>
951 <0? <SET N <- .N 1>>>
955 <COND (<AND <EMPTY? .DCL> <0? .CNT>> .STRU)
958 !<COND (<0? .CNT> (.ITYP !.DCL))
959 (<N==? .SDC <REST .DC>>
960 <COND (<0? <SET CNT <- .CNT 1>>>
961 (!.SDC !<REST .DCL>))
966 (ELSE ([.CNT !.SDC] !<REST .DCL>))>>)>)
968 <SET GP <REST <PUTREST .GP (.PT)>>>
969 <AND <ASSIGNED? SDC> <SET SDC <REST .SDC>>>
970 <COND (<AND <EMPTY? .DCL> <0? .CNT>> .GD)
974 <==? .SDC <REST .DC>>>>
976 (<==? .SDC <REST .DC>>
977 ([.CNT !<REST .DC>] !<REST .DCL>))
978 (<L=? <SET CNT <- .CNT 1>> 0>
979 (!.SDC !<REST .DCL>))
986 <AND <OR .PT .RST> <=? .ITYP '<NOT ANY>> <RETURN <>>>
987 <AND .PT <SET GP <REST <PUTREST .GP (.ITYP)>>>>
989 <RETURN <COND (.RST .STRU)
991 <PUTREST .GP (!<ANY-PAT <- .N 1>> .PT)>
994 (.QOK <SET DCL1 <GEN-DECL <2 .DCL>>> <SET QOK <>> <AGAIN>)
995 (<AND .FMOK <==? <1 .FMOK> OR>>
997 <FUNCTION (D "AUX" IT)
998 <COND (<SET IT <GET-ELE-TYPE .D .NN .RST .PT>>
999 <AND <==? .IT ANY> <MAPLEAVE ANY>>
1003 (<AND .FMOK <==? <1 .FMOK> AND>>
1007 <SET ITYP <TYPE-OK? .ITYP <GET-ELE-TYPE .D .NN .RST>>>>
1010 (.RST <COND (<STRUCTYP .DCL1>) (ELSE STRUCTURED)>)
1012 <COND (<==? .NN ALL> .DCL1)
1013 (ELSE <FOSE .SEGF .DCL1 !<ANY-PAT <- .NN 1>> .PT>)>)
1018 <DEFINE MINL (DCL) <MIN-MAX-L .DCL <>>>
1020 <DEFINE MAXL (DCL) <MIN-MAX-L .DCL T>>
1022 <DEFINE MIN-MAX-L (DCL MAXF
1023 "AUX" (N 0) DD D DC (LN 0) (QOK <>) (ANDOK <>) TT (OROK <>)
1024 (IVAL <COND (.MAXF 0)(ELSE ,MAX-LENGTH)>))
1025 #DECL ((N VALUE LN) FIX (DC) <PRIMTYPE LIST> (D) VECTOR)
1026 <COND (<TYPE? .DCL ATOM> <SET DCL <DECL-GET .DCL .DCL>>)>
1028 (<AND <TYPE? .DCL FORM SEGMENT>
1031 <N==? <SET TT <1 .DC>> PRIMTYPE>
1032 <NOT <SET OROK <==? .TT OR>>>
1033 <NOT <SET QOK <==? .TT QUOTE>>>
1034 <NOT <SET ANDOK <==? .TT AND>>>
1037 <COND (<AND .MAXF <TYPE? .DCL FORM>> ,MAX-LENGTH)
1041 <COND (<AND <TYPE? <SET DD <1 .DC>> VECTOR>
1044 <COND (<OR <==? <SET FST <1 .D>> REST>
1046 <==? .FST OPTIONAL>>
1048 <COND (<==? .FST REST>
1049 <RETURN ,MAX-LENGTH>)
1051 <SET N <+ .N <- <LENGTH .D> 1>>>)>)
1056 <SET N <+ .N <* .LN <- <LENGTH .D> 1>>>>)
1058 <COMPILE-ERROR "Bad DECL syntax" .DCL>)>)
1059 (<TYPE? .DD ATOM FORM SEGMENT> <SET N <+ .N 1>>)
1060 (ELSE <COMPILE-ERROR "Bad DECL syntax" .DCL>)>
1061 <COND (<EMPTY? <SET DC <REST .DC>>> <RETURN .N>)>>)>)
1065 <COND (.OROK <COND (.MAXF
1066 <SET IVAL <MAX .IVAL <MIN-MAX-L .EL .MAXF>>>)
1068 <SET IVAL <MIN .IVAL <MIN-MAX-L .EL .MAXF>>>)>)
1069 (.MAXF <SET IVAL <MIN .IVAL <MIN-MAX-L .EL .MAXF>>>)
1070 (ELSE <SET IVAL <MAX .IVAL <MIN-MAX-L .EL .MAXF>>>)>>
1073 (.QOK <COND (<STRUCTURED? <2 .DC>> <LENGTH <2 .DC>>) (ELSE 0)>)
1074 (<TYPE? .DCL ATOM FALSE FORM SEGMENT>
1075 <COND (.MAXF ,MAX-LENGTH) (ELSE 0)>)
1076 (ELSE <COMPILE-ERROR "Bad DECL syntax" .DCL>)>>
1078 <DEFINE STRUCTYP-SEG (DCL)
1080 <AND <==? .DCL MULTI> MULTI>
1081 <AND <TYPE? .DCL FORM SEGMENT>
1083 <==? <1 .DCL> MULTI> MULTI>>>
1085 <DEFINE STRUCTYP (DCL "AUX" VT)
1086 <SET DCL <TYPE-AND .DCL STRUCTURED>>
1087 <COND (<TYPE? .DCL ATOM>
1088 <AND <SET VT <VALID-TYPE? .DCL>> <GC-PRIMTYPE .VT>>)
1089 (<TYPE? .DCL FORM SEGMENT>
1090 <COND (<PRIMHK .DCL T>)
1091 (<TYPE? <1 .DCL> FORM> <PRIMHK <1 .DCL> <>>)>)>>
1093 <DEFINE PRIMHK (FRM FLG "AUX" TEM (LN <LENGTH .FRM>))
1094 #DECL ((FRM) <OR FORM SEGMENT> (LN) FIX)
1095 <COND (<AND <==? .LN 2>
1096 <COND (<==? <SET TEM <1 .FRM>> PRIMTYPE>
1097 <AND <TYPE? <SET TEM <2 .FRM>> ATOM>
1099 <STRUCTYP <2 .FRM>>>)
1100 (<==? .TEM QUOTE> <PRIMTYPE <2 .FRM>>)
1101 (<==? .TEM NOT> <>)>>)
1103 <COND (<==? <SET TEM <1 .FRM>> OR>
1106 <FUNCTION (D) <SET TEM <TYPE-MERGE <STRUCTYP .D> .TEM>>>
1108 <COND (<AND <TYPE? .TEM ATOM> <VALID-TYPE? .TEM>> .TEM)>)
1112 <COND (<SET TEM <STRUCTYP .D>> <MAPLEAVE>)>>
1115 (<AND <TYPE? .TEM ATOM> <VALID-TYPE? .TEM>> <MTYPR .TEM>)>)>>
1119 <DEFINE TYPESAME (T1 T2)
1120 <OR <AND <SET T1 <ISTYPE? .T1>> <==? .T1 <SET T2 <ISTYPE? .T2>>>>
1123 <==? <GETPROP .T1 ALT-DECL '.T1>
1124 <GETPROP .T2 ALT-DECL '.T2>>>>>
1126 <DEFINE ISTYPE-GOOD? (TYP "OPTIONAL" (STRICT <>))
1127 <AND <SET TYP <ISTYPE? .TYP .STRICT>>
1128 <NOT <MEMQ <MTYPR .TYP> '[BYTES STRING LOCD TUPLE FRAME]>>
1131 <DEFINE TOP-TYPE (TYP "AUX" TT)
1132 <COND (<AND <TYPE? .TYP ATOM>
1133 <NOT <VALID-TYPE? .TYP>>
1134 <NOT <MEMQ .TYP '[STRUCTURED APPLICABLE ANY LOCATIVE]>>>
1135 <SET TYP <DECL-GET .TYP .TYP>>)>
1136 <COND (<TYPE? .TYP ATOM> .TYP)
1137 (<AND <TYPE? .TYP FORM SEGMENT> <NOT <LENGTH? .TYP 1>>>
1138 <COND (<==? <SET TT <1 .TYP>> OR>
1139 <MAPF ,TYPE-MERGE ,TOP-TYPE <REST .TYP>>)
1141 (<==? .TT QUOTE> <TYPE <2 .TYP>>)
1142 (<==? .TT PRIMTYPE> .TYP)
1145 <DEFINE PRIMITIVE-TYPE (TYP "AUX" TT RES VT)
1146 <COND (<AND <TYPE? .TYP ATOM>
1147 <NOT <VALID-TYPE? .TYP>>
1148 <NOT <MEMQ .TYP '[STRUCTURED APPLICABLE ANY]>>>
1149 <SET TYP <DECL-GET .TYP .TYP>>)>
1150 <COND (<TYPE? .TYP ATOM>
1151 <COND (<SET VT<VALID-TYPE? .TYP>>
1154 (<AND <TYPE? .TYP FORM SEGMENT> <NOT <LENGTH? .TYP 1>>>
1155 <COND (<==? <SET TT <1 .TYP>> OR>
1156 <SET RES <MAPF ,TYPE-MERGE ,PRIMITIVE-TYPE <REST .TYP>>>
1157 <COND (<TYPE? .RES ATOM> .RES) (ELSE ANY)>)
1159 (<==? .TT QUOTE> <PRIMTYPE <2 .TYP>>)
1160 (<==? .TT PRIMTYPE> <2 .TYP>)
1161 (ELSE <PRIMITIVE-TYPE <1 .TYP>>)>)>>
1163 <DEFINE ISTYPE? (TYP "OPTIONAL" (STRICT <>) "AUX" TY)
1165 <COND (<AND <NOT .STRICT>
1166 <TYPE? .TYP FORM SEGMENT>
1169 <MEMQ UNBOUND <REST .TYP>>>
1170 <SET TYP <TYPE-AND .TYP '<NOT UNBOUND>>>)>
1171 <COND (<TYPE? .TYP FORM SEGMENT>
1172 <COND (<AND <==? <LENGTH .TYP> 2> <==? <1 .TYP> QUOTE>>
1173 <SET TYP <TYPE <2 .TYP>>>)
1175 <SET TYP <ISTYPE? <2 <SET TY .TYP>>>>
1178 <COND (<N==? .TYP <ISTYPE? .Z>>
1179 <MAPLEAVE <SET TYP <>>>)>>
1181 (ELSE <SET TYP <1 .TYP>>)>)>
1182 <AND <TYPE? .TYP ATOM>
1183 <COND (<VALID-TYPE? .TYP> .TYP)
1184 (<SET TYP <DECL-GET .TYP>> <AGAIN>)>>>>
1186 <DEFINE DCX (IT "AUX" TT LN)
1187 #DECL ((TT) VECTOR (LN) FIX)
1188 <COND (<AND <TYPE? .IT VECTOR>
1189 <G=? <SET LN <LENGTH <SET TT .IT>>> 2>
1190 <COND (<==? .LN 2> <2 .TT>)
1191 (ELSE <TYPE-MERGE !<REST .TT>>)>>)
1194 " Define a decl for a given quoted object for maximum winnage."
1198 <DEFINE GEN-DECL (OBJ)
1200 (<==? .OBJ %<>> BOOL-FALSE)
1201 (<OR <MONAD? .OBJ> <APPLICABLE? .OBJ> <TYPE? .OBJ STRING BYTES>>
1204 <REPEAT ((DC <GEN-DECL <1 .OBJ>>) (CNT 1)
1205 (FRM <CHTYPE (<TYPE .OBJ>) SEGMENT>) (FRME .FRM) TT T1)
1206 #DECL ((CNT) FIX (FRME) <<PRIMTYPE LIST> ANY>)
1207 <COND (<EMPTY? <SET OBJ <REST .OBJ>>>
1209 <SET FRME <REST <PUTREST .FRME ([.CNT .DC])>>>)
1210 (ELSE <SET FRME <REST <PUTREST .FRME (.DC)>>>)>
1212 (<AND <=? <SET TT <GEN-DECL <1 .OBJ>>> .DC> .DC>
1213 <SET CNT <+ .CNT 1>>)
1216 <SET FRME <REST <PUTREST .FRME ([.CNT .DC])>>>)
1217 (ELSE <SET FRME <REST <PUTREST .FRME (.DC)>>>)>
1223 <DEFINE REST-DECL (DC N "AUX" TT TEM)
1226 (<TYPE? .DC FORM SEGMENT>
1228 (<OR <==? <SET TT <1 .DC>> OR> <==? .TT AND>>
1233 <FUNCTION (D "AUX" (IT <REST-DECL .D .N>))
1234 <COND (<==? .IT ANY>
1235 <COND (<==? .TT OR> <MAPLEAVE (ANY)>)
1240 <COND (<EMPTY? <REST .TT>> ANY)
1241 (<EMPTY? <REST .TT 2>> <2 .TT>)
1245 <COND (<0? .N> .DC) (ELSE <CHTYPE (.DC !<ANY-PAT .N>) FORM>)>)
1247 <FOSE <TYPE? .DC SEGMENT>
1248 <COND (<SET TEM <STRUCTYP .TT>> <FORM PRIMTYPE .TEM>)
1252 (<SET TEM <STRUCTYP .DC>>
1253 <COND (<0? .N> <FORM PRIMTYPE .TEM>)
1254 (ELSE <CHTYPE (<FORM PRIMTYPE .TEM> !<ANY-PAT .N>) FORM>)>)
1256 <COND (<0? .N> STRUCTURED)
1257 (ELSE <CHTYPE (STRUCTURED !<ANY-PAT .N>) FORM>)>)>>
1261 <COND (<L=? .N 0> ()) (<1? .N> (ANY)) (ELSE ([.N ANY]))>>
1263 " TYPE-OK? are two type patterns compatible. If the patterns
1264 don't parse, send user a message."
1266 <DEFINE TYPE-OK? (P1 P2 "AUX" TEM)
1267 <COND (<OR <==? .P1 NO-RETURN> <==? .P2 NO-RETURN>> NO-RETURN)
1268 (<SET TEM <TYPE-AND .P1 .P2>> .TEM)
1269 (<EMPTY? .TEM> .TEM)
1270 (ELSE <COMPILE-ERROR <1 .TEM> .P1 .P2>)>>
1272 " TYPE-ATOM-OK? does an atom's initial value agree with its DECL?"
1274 <DEFINE TYPE-ATOM-OK? (P1 P2 ATM)
1276 <COND (<TYPE-OK? .P1 .P2>)
1278 <COMPILE-ERROR "Atom's intial value disagrees with DECL"
1281 " Merge a group of type specs into an OR."
1285 <DEFINE TYPE-MERGE ("TUPLE" TYPS)
1286 #DECL ((TYPS) <PRIMTYPE VECTOR> (FTYP) FORM (LN) FIX)
1287 <COND (<EMPTY? .TYPS> <>)
1289 <REPEAT ((ORS <1 .TYPS>))
1290 <COND (<EMPTY? <SET TYPS <REST .TYPS>>> <RETURN .ORS>)>
1292 <COND (<==? <1 .TYPS> NO-RETURN> .ORS)
1293 (<==? .ORS NO-RETURN> <1 .TYPS>)
1294 (ELSE <TMERGE .ORS <1 .TYPS>>)>>>)>>
1296 <DEFINE PUT-IN (LST ELE)
1297 #DECL ((LST) <PRIMTYPE LIST> (VALUE) LIST)
1298 <COND (<AND <TYPE? .ELE FORM SEGMENT> <NOT <EMPTY? .ELE>> <==? <1 .ELE> OR>>
1299 <SET ELE <LIST !<REST .ELE>>>)
1300 (ELSE <SET ELE (.ELE)>)>
1303 <FUNCTION (L1 "AUX" TT)
1304 <COND (<EMPTY? .ELE> .L1)
1305 (<REPEAT ((A .ELE) B)
1307 <COND (<TMATCH <1 .A> .L1>
1308 <SET TT <TMERGE <1 .A> .L1>>
1309 <COND (<==? .A .ELE> <SET ELE <REST .ELE>>)
1310 (ELSE <PUTREST .B <REST .A>>)>
1312 <AND <EMPTY? <SET A <REST <SET B .A>>>>
1317 <LSORT <COND (<EMPTY? .ELE> .LST)
1318 (ELSE <PUTREST <REST .ELE <- <LENGTH .ELE> 1>> .LST> .ELE)>>>
1320 <DEFINE ORSORT (F) #DECL ((F) <FORM ANY ANY>) <PUTREST .F <LSORT <REST .F>>>>
1322 <DEFINE LSORT (L "AUX" (M ()) (B ()) (TMP ()) (IT ()) (N 0) A1 A2)
1323 #DECL ((L M B TMP IT VALUE) LIST (N) FIX
1324 (CMPRSN) <OR FALSE APPLICABLE>)
1326 <COND (<L? <SET N <LENGTH .L>> 2> <RETURN .L>)>
1327 <SET B <REST <SET TMP <REST .L <- </ .N 2> 1>>>>>
1334 <COND (<EMPTY? .TMP> <RETURN .B>)
1335 (ELSE <PUTREST .TMP .B> <RETURN .M>)>)
1337 <COND (<EMPTY? .TMP> <RETURN .L>)
1338 (ELSE <PUTREST .TMP .L> <RETURN .M>)>)
1342 <COND (<COND (<AND <TYPE? .A1 ATOM>
1344 <L? <STRCOMP <SPNAME .A1>
1346 (<TYPE? .A1 ATOM> T)
1347 (<TYPE? .A2 ATOM> <>)
1348 (<L? <FCOMPARE .A1 .A2> 0>)>
1349 <SET L <REST <SET IT .L>>>)
1350 (ELSE <SET B <REST <SET IT .B>>>)>
1352 <COND (<EMPTY? .M> <SET M <SET TMP .IT>>)
1354 <SET TMP <REST <PUTREST .TMP .IT>>>)>)>>>>
1358 <DEFINE FCOMPARE (F1 F2 "AUX" TC TC2 (L1 <LENGTH .F1>) (L2 <LENGTH .F2>))
1359 #DECL ((F1 F2) <PRIMTYPE LIST> (VALUE TC TC2 L1 L2) FIX)
1360 <COND (<==? .L1 .L2>
1361 <COND (<==? <SET TC <CALL TYPE .F1>>
1362 <SET TC2 <CALL TYPE .F2>>>
1365 <COND (<N==? .E1 .E2>
1366 <COND (<N==? <SET TC <CALL TYPE .E1>>
1367 <SET TC2 <CALL TYPE .E2>>>
1368 <COND (<L? .TC .TC2> -1)
1369 (ELSE <MAPLEAVE 1>)>)
1372 <STRCOMP <SPNAME .E1>
1375 <MAPLEAVE <VCOMP .E1 .E2>>)
1377 <MAPLEAVE <FCOMPARE .E1 .E2>>)>)
1385 <DEFINE VCOMP (V1 V2 "AUX" (L1 <LENGTH .V1>) (L2 <LENGTH .V2>) E1 E2)
1386 #DECL ((V1 V2) <VECTOR ANY> (VALUE L1 L2) FIX)
1387 <COND (<G? .L1 .L2> 1)
1389 (<N==? <SET E1 <1 .V1>> <SET E2 <1 .V2>>>
1390 <COND (<AND <TYPE? .E1 FIX> <TYPE? .E2 FIX>>
1391 <COND (<G? .E1 .E2> 1) (ELSE -1)>)
1393 (<TYPE? .E2 FIX> -1)
1394 (ELSE <STRCOMP <SPNAME .E1> <SPNAME .E2>>)>)
1397 <FUNCTION (E1 E2 "AUX" TC1:FIX TC2:FIX)
1398 <COND (<==? .E1 .E2> 0)
1399 (<==? <SET TC1 <CALL TYPE .E1>>
1400 <SET TC2 <CALL TYPE .E2>>>
1401 <COND (<TYPE? .E1 ATOM>
1402 <MAPLEAVE <STRCOMP <SPNAME .E1>
1405 <MAPLEAVE <FCOMPARE .E1 .E2>>)>)
1406 (<G? .TC1 .TC2> <MAPLEAVE 1>)
1407 (ELSE <MAPLEAVE -1>)>>
1408 <REST .V1> <REST .V2>>)>>
1410 <DEFINE CANONICAL-DECL (D)
1412 <COND (<AND <TYPE? .D FORM SEGMENT> <NOT <EMPTY? .D>>>
1413 <COND (<==? <1 .D> OR>
1415 !<MAPF ,LIST ,CANONICAL-DECL <REST .D>>>>)
1416 (<==? <1 .D> QUOTE> <CANONICAL-DECL <GEN-DECL <2 .D>>>)
1417 (ELSE <CAN-ELE .D>)>)
1420 <DEFINE CAN-ELE (L "AUX" (SAME <>) SAMCNT TT TEM X Y)
1421 #DECL ((L) <PRIMTYPE LIST> (SAMCNT) FIX)
1423 (<AND <TYPE? <1 .L> ATOM>
1424 <VALID-TYPE? <1 .L>>
1425 <SET X <DECL-GET <1 .L>>>
1426 <TYPE? .X FORM SEGMENT>
1428 <OR <=? <REST .X> <REST .L>>
1430 <CHTYPE (<SET Y <FORM PRIMTYPE <MTYPR <1 .L>>>> !<REST .L>)
1432 <CANONICAL-DECL <CHTYPE (.Y !<REST .X>) FORM>>>>>
1436 (<CANONICAL-DECL <1 .L>>
1438 <FUNCTION (EL "AUX" (ELE <1 .EL>) (LAST <EMPTY? <REST .EL>>))
1440 (<TYPE? .ELE VECTOR>
1442 (<AND <==? <LENGTH .ELE> 2> <TYPE? <1 .ELE> FIX>>
1443 <SET TT <CANONICAL-DECL <2 .ELE>>>
1444 <COND (<AND .SAME <=? .SAME .TT>>
1445 <SET SAMCNT <+ .SAMCNT <1 .ELE>>>
1446 <COND (.LAST [.SAMCNT .TT]) (ELSE <MAPRET>)>)
1448 <COND (.SAME <SET TEM <GR-RET .SAME .SAMCNT>>)
1449 (ELSE <SET TEM <>>)>
1451 <SET SAMCNT <1 .ELE>>
1453 <COND (.TEM <MAPRET .TEM <GR-RET .TT .SAMCNT>>)
1454 (ELSE <GR-RET .TT .SAMCNT>)>)
1457 (<AND <==? <1 .ELE> REST>
1458 <==? <LENGTH .ELE> 2>
1461 <SET TEM <GR-RET .SAME .SAMCNT>>
1466 <COND (.SAME <SET TEM <GR-RET .SAME .SAMCNT>>)
1467 (ELSE <SET TEM <>>)>
1468 <SET TT <IVECTOR <LENGTH .ELE>>>
1471 <COND (<==? <1 .ELE> OPT> OPTIONAL) (ELSE <1 .ELE>)>>
1472 <COND (<AND <G=? <LENGTH .ELE> 2> <==? <1 .ELE> REST>>
1473 <PUT .TT 2 <SET SAME <CANONICAL-DECL <2 .ELE>>>>)
1474 (ELSE <SET SAME <>>)>
1476 (<G=? <LENGTH .ELE> 3>
1478 <FUNCTION (X Y "AUX" THIS)
1479 <PUT .X 1 <SET THIS <CANONICAL-DECL <1 .Y>>>>
1480 <COND (<N=? .THIS .SAME> <SET SAME <>>)>>
1483 <COND (.SAME <SET TT [<1 .TT> <2 .TT>]>)>)>
1485 <COND (.TEM <MAPRET .TEM .TT>) (ELSE .TT)>)>)
1487 <SET ELE <CANONICAL-DECL .ELE>>
1488 <COND (<AND .SAME <=? .SAME .ELE>>
1489 <SET SAMCNT <+ .SAMCNT 1>>
1490 <COND (.LAST <GR-RET .ELE .SAMCNT>) (ELSE <MAPRET>)>)
1492 <COND (.SAME <SET TEM <GR-RET .SAME .SAMCNT>>)
1493 (ELSE <SET TEM <>>)>
1496 <COND (.LAST <COND (.TEM <MAPRET .TEM .ELE>) (ELSE .ELE)>)
1498 (ELSE <MAPRET>)>)>)>>
1502 <DEFINE GR-RET (X N) #DECL ((N) FIX) <COND (<1? .N> .X) (ELSE [.N .X])>>
1504 <DEFINE DECL-GET (DCL "OPT" (DEF <>) "AUX" X)
1506 <COND (<AND <SET X <GET-DECL .DCL>> <N==? .X ANY>> .X)
1507 (ELSE <GETPROP .DCL ALT-DECL .DEF>)>)
1508 (ELSE <GETPROP .DCL DECL .DEF>)>>
1511 <COND (<MEMQ .X '[OBLIST LVAL GVAL]> ATOM) (ELSE <TYPEPRIM .X>)>>
1513 <DEFINE GC-PRIMTYPE (ARG "AUX" ENTRY (TYP <LSH .ARG -6>))
1514 #DECL ((VALUE) ATOM (ENTRY) <PRIMTYPE VECTOR> (TYP) FIX)
1515 <M$$PTYPE <SET ENTRY <NTH ,M$$TYPE-INFO!-INTERNAL <+ 1 .TYP>>>>>