2 <FUNCTION ("ARGS" A) <CHTYPE .A ACTOR> >>
5 <FUNCTION ("ARGS" A) <CHTYPE .A ACTOR-FUNCTION> >>
9 <AND <ATOM? .EXP> <SET EXP <AVAL .EXP>>>
10 <AND <MEMQ <TYPE .EXP> '(ACTOR ACTOR-FUNCTION)>
15 <AND <MEMQ <TYPE .EXP> '(FORM SEGMENT)>
21 <FUNCTION (ATOM) <OR <GET .ATOM PRECEDENCE> 0> >>
25 <FUNCTION INVOKER (F OBJECT "OPTIONAL" (BOUND <BOTTOM .OBJECT>)
26 (OBL T) (ENV <>) (OBJENV <>) (PURE? T)
29 <SET F <CHTYPE .F FORM>>
30 <COND (<OR <EMPTY? .UV1> <GET <1 .F> FACTOR>>
31 <.INVOKER <INVOKE1 .F .OBJECT .BOUND .OBL .PURE? .ENV .OBJENV>>)
34 (T <SET BOUND <ANOTHER .OBJECT .BOUND>>) >)
36 <COND (<==? <TYPE .OBJECT> FORM>
37 <COND (<OR <EMPTY? <SET UV2 <UARGS .OBJECT .OBJENV>>>
39 <.INVOKER <INVOKE1 .OBJECT .F '<> T <> .OBJENV .ENV .UV2>>) >)
40 (T <SET UV2 <UVARS .OBJECT .BOUND .OBJENV>>) >)
41 (T <SET OBJECT <FRONT .OBJECT <> <LLOC BOUND> .OBJENV <LLOC UV2>>>) >
42 <LINKVARS .UV1 .UV2 .F .OBJECT <OR .ENV .TOPMATCH> <OR .OBJENV .TOPMATCH>>
43 .BOUND >>
\f<DEFINE INVOKE1
45 F OBJECT BOUND OBL PURE? ENV OBJENV
47 <COND (<OR <EMPTY? .F> <NOT <SET ACTR <ACTOR? <1 .F>>>>>
48 <SET VAL <EVAL .F .ENV>>
51 <OR <=UPTO? .VAL .OBJECT .BOUND> <FAIL>>
53 (T <PREFIX1 .VAL <BOTTOM .VAL> .OBJECT .BOUND>) >)
55 <IS1 .OBJECT .VAL .OBJENV <BOTTOM .VAL> .BOUND>)
56 (T <MATCH1 .VAL .OBJECT .ENV .OBJENV <BOTTOM .VAL> .BOUND <>>) >)
57 (<==? <TYPE .ACTR> ACTOR-FUNCTION>
59 <EVAL <FORM <CHTYPE .ACTR FUNCTION>
60 '.OBJECT '.BOUND '.OBL '.PURE? '<OR .ENV .TOPMATCH>
61 '<OR .OBJENV .PURE? .TOPMATCH> !<REST .F>>>)
62 (<==? <TYPE .ACTR> ACTOR>
65 ((BODY <REST .ACTR <COND (<ATOM? <1 .ACTR>> 2) (1) >>))
66 <APPLY <CHTYPE ,ET FUNCTION>
67 (.OBJECT .BOUND .OBL .PURE? <ENVIRON> .OBJENV !.BODY)> >)
68 (T <ERROR NON-INVOKABLE-TYPE>) > >>
\f<DEFINE GIVEN
69 <ACTOR-FUNCTION GA (OBJECT BOUNDARY OBLIGATORY PURE? ENV OBJENV VAR
70 "AUX" (VAL <RLVAL .VAR>) RS (VALRS ()) (UV ()) PURESOFAR NEWVAL
71 NEWBOUND (VARLOC <LLOC .VAR>) VARFORM RS2)
72 <COND (<ASSIGNED? .VAR>
75 <OR <=UPTO? .VAL .OBJECT .BOUNDARY> <FAIL>>)
76 (T <IS1 .OBJECT .VAL .OBJENV <BOTTOM .VAL> T .BOUNDARY>) >
79 <.GA <PREFIX1 .VAL <BOTTOM .VAL> .OBJECT .BOUNDARY>>)
80 (T <.GA <MATCH1 .VAL .OBJECT .ENV .OBJENV <BOTTOM .VAL> .BOUND <>>>) >) >
81 <SET RS <CHTYPE <RLVAL VAL> LIST>>
82 <COND (<AND .PURE? .OBLIGATORY>
83 <THSET .VAR <UPTO .OBJECT .BOUNDARY>>
84 <CHECKRESTRICTS .RS () ..VAR>
86 <COND (<AND <==? .OBJECT <SET VARFORM <FORM GIVEN .VAR>>>
88 <EVAL <PUT '<LLOC VAR> 2 .VAR> .OBJENV>>>
90 (<SET RS2 <MEMRES .OBJECT .BOUNDARY .OBJENV .RS>>
95 <AND <EMPTY? .RS> <.CHECK <>>>
96 <SET RS1 <1 .RS>> <SET RS <REST .RS>>
98 (<==? <1 .RS1> PATTERN>
101 <IS1 <2 .RS1> .OBJECT <3 .RS1> .BOUNDARY .OBLIGATORY>)
103 <MATCH1 <2 .RS1> .OBJECT <3 .RS1> .OBJENV
104 <BOTTOM <2 .RS1>> .BOUNDARY
107 <COND (<ASSIGNED? .VAR>
108 <CHECKRESTRICTS .RS .VALRS ..VAR>
110 (<FULL? <RLVAL .VAR>>
111 <THSET RS <NCONC <CHTYPE <RLVAL .VAR> LIST>
114 (T <THSET VALRS (.RS1 !.VALRS)>) >>) >
115 <THTRYSET .VARLOC .VARFORM .OBJECT .BOUNDARY .OBLIGATORY .PURE?
116 .ENV .OBJENV .RS .VALRS> >>
118 <PUT GIVEN PRECEDENCE 3>
\f<DEFINE ALTER
119 <ACTOR-FUNCTION (OBJECT BOUND OBL? PURE? ENV OBJENV VAR)
120 <THTRYSET <LLOC .VAR> <FORM GIVEN .VAR> .OBJECT .BOUND .OBL?
121 .PURE? .ENV .OBJENV> >>
123 <PUT ALTER PRECEDENCE 4>
128 <DO <OR .PRED <FAIL>>> >>
130 <PUT BE PRECEDENCE 30>
137 <PUT DO PRECEDENCE 29>
141 <ACTOR-FUNCTION (OBJECT BOUND OBL? PURE? ENV OBJENV "OPTIONAL" (N <>)
146 <==? .N <BLENGTH .OBJECT .BOUND>>
148 (<OR <PROG2 <SET OBJECT <INSTANTIATE .OBJECT UV .BOUND .OBJENV>>
150 <NOT <UNCERTAINLENGTH .OBJECT>>>
151 <OR <NOT .N> <==? .N <LENGTH .OBJECT>> <FAIL>>)
152 (<EMPTY? .UV> <FAIL>)
153 (T <LINKVARS () .UV <SET FORM1 <FORM ? .N>> .OBJECT
154 <> .OBJENV .FORM1 .BOUND>) >
158 <COND (<G? .N <BLENGTH .OBJECT .BOUND>> <FAIL>)
159 (T <REST .OBJECT .BOUND>) >)
160 (T <ANOTHER .OBJECT .BOUND>) >)
162 <SET OBJECT <FRONT .OBJECT T <LLOC BOUND> .OBJENV>>
164 <OR <==? .N <LENGTH .OBJECT>> <FAIL>>) >
167 <PUT ? PRECEDENCE 2>
\f<DEFINE ET
168 <ACTOR-FUNCTION (OBJECT BOUND OBL? PURE? ENV OBJENV "REST" 'PATS)
170 <COND (<EMPTY? .PATS>
171 <.ACTITER <COND (.OBL? .BOUND)
172 (.PURE? <ANOTHER .OBJECT .BOUND>)
173 (T <REAR .OBJECT .OBJENV .BOUND>) >>) >
176 <IS1 <1 .PATS> .OBJECT .ENV .BOUND .OBL?>)
185 <THSET PATS <REST .ITER>> > >>
187 <PUT ET PRECEDENCE 10> <PUT ET FACTOR T>
192 <ACTOR-FUNCTION (OBJECT BOUND OBL? PURE? ENV OBJENV "REST" 'PATS
193 "AUX" (PAT1 <CLIP PATS>))
195 <IS1 .PAT1 .OBJECT <> .BOUND .OBL?>)
196 (T <MATCH1 .PAT1 .OBJECT <> .OBJENV <BOTTOM .PAT1> .BOUND .OBL?>) > >>
199 <PUT VEL PRECEDENCE 20> <PUT VEL FACTOR T>
202 <ACTOR-FUNCTION (OBJECT BOUND OBL? PURE? ENV OBJENV 'PAT)
205 <COND (.PURE? <UPTO .OBJECT <SET BOUND <ANOTHER .OBJECT .BOUND>>>)
206 (T <FRONT .OBJECT <> <LLOC BOUND> .OBJENV>) >> >
207 <FAILPOINT NAY-SAYER ()
208 <PROG2 <COND (.PURE? <IS1 .PAT .OBJECT>)
209 (T <MATCH1 .PAT .OBJECT <> .OBJENV>) >
210 <FAIL <> .NAY-SAYER>>
212 <.NAY-SAYER .BOUND> >>>
214 <PUT NON PRECEDENCE 6> <PUT NON FACTOR T>
\f<DEFINE WHEN
215 <ACTOR-FUNCTION WA (OBJECT BOUND OBL? PURE? ENV OBJENV "REST" 'CLAUSES
216 "AUX" (CLAUSE <CLIP CLAUSES>) NEWBOUND)
218 <COND (<EMPTY? .CLAUSE> <ERROR EMPTY-CLAUSE--WHEN>)
219 (.PURE? <IS1 <1 .CLAUSE> .OBJECT <> .BOUND .OBL?>)
220 (T <MATCH1 <1 .CLAUSE> .OBJECT <> .OBJENV
221 <BOTTOM <1 .CLAUSE>> .BOUND .OBL?>) >>
222 <FAILPOINT () <> () <FAIL <> .WA>>
223 <APPLY <CHTYPE ,ET FUNCTION>
224 (.OBJECT .NEWBOUND T .PURE? .ENV .OBJENV !<REST .CLAUSE>)>
227 <PUT WHEN PRECEDENCE 25> <PUT WHEN FACTOR T>
\f<DEFINE THTRYSET
228 <FUNCTION (VARLOC VARFORM OBJECT BOUND OBL? PURE? ENV OBJENV "OPTIONAL"
233 <CHECKRESTRICTS .RS .VALRS <THSETLOC .VARLOC <UPTO .OBJECT .BOUND>>>)
235 <SET OBJECT <INSTANTIATE .OBJECT PURE? .BOUND .OBJENV>>
237 <CHECKRESTRICTS .RS .VALRS <THSETLOC .VARLOC .OBJECT>>)
239 (<SET VAR2 <UVAR? .OBJECT>>
240 <THPSEUDOSETLOC <LLOC .VAR2> .VARFORM .ENV>
241 <THPSEUDOSETLOC .VARLOC .OBJECT .OBJENV>)
242 (T <THIMPURESETLOC .VARLOC .PURE? .VARFORM .OBJECT .ENV .OBJENV>) >)
244 <THSETLOC .VARLOC <UPTO .OBJECT <SET BOUND <ANOTHER .OBJECT .BOUND>>>>)
246 <SET OBJECT <FRONT .OBJECT T <LLOC BOUND> .OBJENV <LLOC PURE?>>>
248 <CHECKRESTRICTS .RS .VALRS <THSETLOC .VARLOC .OBJECT>>)
249 (T <THIMPURESETLOC .VARLOC .PURE? .VARFORM .OBJECT .ENV .OBJENV>) >
253 <DEFINE THIMPURESETLOC
254 <FUNCTION (LOC UV VARFORM OBJECT ENV OBJENV)
255 <COND (<MEMQ .VARLOC <LINKVARS () .UV .VARFORM .OBJECT .ENV .OBJENV>>
257 (T <THPSEUDOSETLOC .VARLOC .OBJECT .OBJENV>) > >>
260 <DEFINE THPSEUDOSETLOC
261 <FUNCTION (LOC OBJ OBJENV)
263 <CHTYPE ([PATTERN .OBJ .OBJENV] !<CHTYPE <IN .LOC> LIST>)
264 UNASSIGNED>> >>
\f<DEFINE PREFIX1
265 <FUNCTION P (L1 TERM1 L2 TERM2)
266 <COND (<OR <EMPTY? .L1> <==? .L1 .TERM1>>
268 (<==? .L2 .TERM2> <FAIL>)>
269 <OR <=? <1 .L1> <1 .L2>> <FAIL>>
270 <SET L1 <REST .L1>> <SET L2 <REST .L2>>
276 <FUNCTION ("BIND" CUR
277 OBJECT EV? BOUNDLOC "OPTIONAL" (ENV <>)
279 "AUX" V P (LP <LLOC P>) (CONSTRUCT <CONSTRUCTOR <TYPE .OBJECT>>)
280 (BOUND <IN .BOUNDLOC>))
281 <SETLOC .BOUNDLOC .OBJECT>
282 <AND .PURELOC <SETLOC .PURELOC ()>>
283 <FINSPLICE .CUR .ENV>
285 <FAILPOINT EXTENDER ()
288 <COND (<==? .OBJECT .BOUND> <FAIL>)
289 (<==? <TYPE <1 .OBJECT>> SEGMENT>
290 <SET V <FORMSUBST <1 .OBJECT> .LP>>
292 <SET OBJECT <REST .OBJECT>>
294 <SET OBJECT <BACKTO .OBJECT <REST .V> .BOUNDLOC>>
295 <RESTORE .EXTENDER <.CONSTRUCT !.RESULT <1 .V>>>)
296 (.EV? <SET V <INSTANTIATE <1 .OBJECT> P>>
297 <AND .PURELOC <NOT .P> <SETLOC .PURELOC <NCONC .P <IN .PURELOC>>>>
298 <SETLOC .BOUNDLOC <SET OBJECT <REST .OBJECT>>>
299 <RESTORE .EXTENDER <.CONSTRUCT !.RESULT .V>>)
301 <FULL? <SET P <UVARS <1 .OBJECT>>>>
302 <SETLOC .PURELOC <NCONC <CHTYPE .P FALSE> <IN .PURELOC>>>>
304 <PROG1 <.CONSTRUCT !.RESULT <1 .OBJECT>>
305 <SETLOC .BOUNDLOC <SET OBJECT <REST .OBJECT>>>>>) >>> >>
\f<DEFINE REAR
306 <FUNCTION ("BIND" CUR
307 OBJECT "OPTIONAL" (ENV <>) (BOUND <BOTTOM .OBJECT>)
308 "AUX" V P (LP <LLOC P>))
309 <FINSPLICE .CUR .ENV>
310 <FAILPOINT CHOPPER ()
313 <COND (<==? .OBJECT .BOUND> <FAIL>)
314 (<==? <TYPE <1 .OBJECT>> SEGMENT>
315 <SET V <FORMSUBST <1 .OBJECT> .LP>>
317 <SET OBJECT <REST .OBJECT>>
319 <RESTORE .CHOPPER <SET OBJECT <BACKTO .OBJECT <REST .V>>>>)
320 (T <RESTORE .CHOPPER <SET OBJECT <REST .OBJECT>>>) > >>>
\f<DEFINE INSTANTIATE
321 <FUNCTION ("BIND" CUR
322 EXP UVAR "OPTIONAL" (BOUND <BOTTOM .EXP>) (ENV <>)
324 <FINSPLICE .CUR .ENV>
325 <COND (<==? <TYPE .EXP> FORM>
326 <FORMSUBST .EXP .LUV>)
330 (T <INSTANTIATE1 .EXP .LUV .BOUND>) >>>
334 <FUNCTION INSTLP (EXP LUV "OPTIONAL" (BOUND <BOTTOM .EXP>)
335 "AUX" (RESULT ()) (P ()) P1 (LP1 <LLOC P1>) EXP1)
336 <COND (<==? .EXP .BOUND> <SETLOC .LUV .P>
337 <.INSTLP <REVERSE .RESULT <CONSTRUCTOR <TYPE .EXP>>>>)
338 (<==? <TYPE <SET EXP1 <1 .EXP>>> SEGMENT>
339 <SET RESULT (<REVERSE <FORMSUBST .EXP1 .LP1> ,CONSL>
341 (T <SET RESULT (<INSTANTIATE .EXP1 P1> !.RESULT)>) >
342 <OR .P1 <SET P <NCONC .P1 .P>>>
343 <SET EXP <REST .EXP>>
348 <FUNCTION (F PURELOC "AUX" P A1 VAR)
349 <COND (<FULL? <SET P <UARGS .F>>>
350 <SETLOC .PURELOC <CHTYPE .P FALSE>>
352 (<OR <EMPTY? .F> <NOT <SET A1 <ACTOR? <1 .F>>>>>
359 <THSET <SET VAR <EVAL <2 .F>>> ?()>
360 <SETLOC .PURELOC <FALSE .VAR>>
363 <COND (<ASSIGNED? <SET VAR <EVAL <2 .F>>>>
366 (T <SETLOC .PURELOC <FALSE .VAR>>
368 (T <SETLOC .PURELOC <>>
369 .F) >>>
\f<DEFINE UVARS
370 <FUNCTION ("BIND" CUR
371 EXP "OPTIONAL" (BOUND <BOTTOM .EXP>) (ENV <>)
373 <FINSPLICE .CUR .ENV>
374 <COND (<==? <TYPE .EXP> FORM>
375 <COND (<FULL? <SET UA <UARGS .EXP>>> .UA)
376 (<AND <==? <LENGTH .EXP> 2>
377 <SET ACTR <ACTOR? <1 .EXP>>>>
378 <COND (<==? .ACTR ,GIVEN>
379 <COND (<OR <NOT <BOUND? <SET VAR <EVAL <2 .EXP>>>>>
383 <THSET <SET VAR <EVAL <2 .EXP>>> ?()>
385 (<==? .EXP .BOUND> ())
386 (T <NCONC <UVARS <1 .EXP>> <UVARS <REST .EXP> .BOUND>>) >>>
391 F "OPTIONAL" (ENV <>)
394 <COND (<MULTILEVEL .F>
395 <COND (<AND <MEMQ <TYPE .F> '(FORM SEGMENT)>
397 <ATOM? <SET VAR <2 .F>>>
398 <OR <NOT <BOUND? .VAR>> <UNASSIGNED? .VAR>>>
400 (T <MAPCAN ,UARGS .F>) >) > >>
404 <FUNCTION (OBJECT "AUX" RES)
405 <AND <==? <TYPE .OBJECT> FORM>
406 <==? <LENGTH .OBJECT> 2>
407 <==? <1 .OBJECT> GIVEN>
408 <ATOM? <SET RES <EVAL <2 .OBJECT>>>>
412 <DEFINE UNCERTAINLENGTH
414 <OR <==? <TYPE .OBJECT> FORM>
415 <AND <MULTILEVEL .OBJECT>
416 <MAPC #FUNCTION ((EL) <AND <==? <TYPE .EL> SEGMENT> <.UNC T>>)
418 <>>> >>
\f<DEFINE UPTO
419 <FUNCTION (OBJECT BOUNDARY)
420 <COND (<MONAD? .OBJECT> .OBJECT)
421 (T <REVERSE <UPTO1 .OBJECT .BOUNDARY>
422 <CONSTRUCTOR <TYPE .OBJECT>>>) > >>
426 <FUNCTION LOOP (OBJ BOU "AUX" (RES ()))
427 <COND (<==? .OBJ .BOU> .RES)
428 (T <SET RES (<1 .OBJ> !.RES)>
429 <SET OBJ <REST .OBJ>>
434 <FUNCTION (PAT BEG "OPTIONAL" (BOUNDLOC <>))
435 <COND (<EMPTY? .BEG> .PAT)
436 (<ISREST .PAT .BEG> .BEG)
437 (T <SET PAT <REVERSE (!<REVERSEUPTO .PAT <IN .BOUNDLOC>>
438 !<REVERSE .BEG ,CONSL>)
439 <CONSTRUCTOR <TYPE .PAT>>>>
440 <SETLOC .BOUNDLOC <BOTTOM .PAT>>
445 <FUNCTION REV (EXP1 EXP2 "AUX" (RESULT()))
446 <COND (<==? .EXP1 .EXP2> .RESULT)
447 (T <SET RESULT (<1 .EXP1> !.RESULT)>
448 <SET EXP1 <REST .EXP1>>
453 <FUNCTION CHECKER (EXP1 EXP2)
454 <COND (<==? .EXP1 .EXP2> T)
456 (T <SET EXP2 <REST .EXP2>>
457 <AGAIN .CHECKER>) >>>
\f<DEFINE CHECKRESTRICTS
458 <FUNCTION CH (RS VALRS OBJECT "OPTIONAL" (BOUNDARY <BOTTOM .OBJECT>))
460 <AND <EMPTY? .RS> <EXIT .CR <>>>
461 <COND (<MONAD? <SET RS1 <1 .RS>>>)
462 (<==? <1 .RS1> PATTERN>
463 <IS1 <2 .RS1> .OBJECT <3 .RS1> .BOUNDARY>)
464 (<THSET VALRS (.RS1 !.VALRS)>) >
465 <THSET RS <REST .RS>> >
467 <AND <EMPTY? .VALRS> <EXIT .CH <>>>
468 <SET VALRS1 <1 .VALRS>>
469 <OR <==? <1 .VALRS1> VALUE>
470 <ERROR MEANINGLESS-RESTRICTION--CHECKRESTRICTS>>
471 <REPEAT REMTAGS ((LOCS <REST .VALRS1 7>))
472 <AND <EMPTY? .LOCS> <EXIT .REMTAGS<>>>
473 <COND (<==? <TYPE <IN <1 .LOCS>>> UNASSIGNED>
474 <THSETLOC <1 .LOCS> <THDELQ .VALRS1 <IN <1 .LOCS>>>>) >
475 <SET LOCS <REST .LOCS>> >
476 <MATCH1 <2 .VALRS1> <3 .VALRS1> <4 .VALRS1> <5 .VALRS1>
477 <6 .VALRS1> <7 .VALRS1>>
478 <THSET VALRS <REST .VALRS>> > >>
482 <FUNCTION CHECK (EXP BOUND ENV RESTRICTIONS "AUX" R1)
484 <AND <EMPTY? .RESTRICTIONS> <EXIT .CHECK <>>>
485 <SET R1 <1 .RESTRICTIONS>>
486 <COND (<AND <NOT <MONAD? .R1>>
487 <==? <1 .R1> PATTERN>
489 <=UPTO? <2 .R1> .EXP .BOUND>>
491 <SET RESTRICTIONS <REST .RESTRICTIONS>> > >>
495 <FUNCTION (EXP1 EXP2 BOUND)
496 <COND (<AND <MONAD? .EXP1> <FULL? .EXP1>>
498 (<AND <MONAD? .EXP2> <FULL? .EXP2>> <>)
500 <COND (<EMPTY? .EXP1> <==? .EXP2 .BOUND>)
501 (<==? .EXP2 .BOUND> <>)
502 (<=? <1 .EXP1> <1 .EXP2>>
503 <SET EXP1 <REST .EXP1>> <SET EXP2 <REST .EXP2>>
504 <AGAIN .=CHECK>) >>) >>>
\f<DEFINE LINKVARS
505 <FUNCTION LINKER (VARS1 VARS2 PAT1 PAT2 ENV1 ENV2 "OPTIONAL"
506 (BOUND1 <BOTTOM .PAT1>) (BOUND2 <BOTTOM .PAT2>)
507 "AUX" (LOCS <NCONC <GENLOCS .VARS1 .ENV1>
508 <GENLOCS .VARS2 .ENV2>>))
509 <REPEAT ((LOCS1 .LOCS)
510 (R [VALUE .PAT1 .PAT2 .ENV1 .ENV2 .BOUND1 .BOUND2 !.LOCS]))
511 <AND <EMPTY? .LOCS1> <.LINKER .LOCS>>
513 <CHTYPE (.R !<CHTYPE <IN <1 .LOCS>> LIST>) UNASSIGNED>>
514 <SET LOCS1 <REST .LOCS1>> > >>
518 <FUNCTION ("BIND" C VARS ENV)
519 <COND (<EMPTY? .VARS> ())
521 <REPEAT GEN ((LOCS ()))
522 <SET LOCS (<LLOC <1 .VARS>> !.LOCS)>
523 <SET VARS <REST .VARS>>
524 <AND <EMPTY? .VARS> <.GEN .LOCS>> >) >>>
\f\f\ 3\f