2 <FUNCTION ("STACK" "BIND" TOPMATCH
9 <FUNCTION ("STACK" "BIND" TOPMATCH
12 <PROG2 <IS1 .PAT .EXP> T>
18 <FUNCTION ("STACK" "BIND" TOPMATCH
25 <FUNCTION ("STACK" "BIND" TOPMATCH
28 <PROG2 <MATCH1 .PAT1 .PAT2> T>
34 <FUNCTION ("STACK" "BIND" TOPMATCH
37 <PROG2 <IS1 .PAT .EXP> .EXP>
39 <ERROR IMPOSSIBLE-ASSIGNMENT> >>>
\f<DEFINE IS1
40 <FUNCTION S ("STACK" "BIND" C
41 PAT EXP "OPTIONAL" (ENV <>) (BOUND <BOTTOM .EXP>)
42 (OBLIGATORY T) (PBOUND <BOTTOM .PAT>)
43 "AUX" PURE ENDP K BETA ENDE)
44 <COND (<==? <TYPE .PAT> FORM>
45 <.S <INVOKE .PAT .EXP .BOUND .OBLIGATORY .ENV>>)
47 <OR <==? .EXP .BOUND> <FAIL>>
50 <.S <OR <=? .PAT .EXP> <FAIL>>>)
52 <OR <EMPTY? .EXP> <FAIL>>) >
54 <HACKPAT .PAT .PBOUND ENDP K BETA>
55 <SET ENDE <POST .EXP .BOUND .K .BETA>>
57 <COND (<==? .PAT .ENDP> <.R <GOTEND .EXP .ENDE .OBLIGATORY>>)
58 (<==? <TYPE <1 .PAT>> SEGMENT>
59 <THSET EXP <INVOKE <1 .PAT> .EXP .ENDE <AND <==? .PAT .ENDP> .OBLIGATORY>>>)
60 (<==? .EXP .ENDE> <FAIL>)
61 (T <IS1 <1 .PAT> <1 .EXP>>
62 <THSET EXP <REST .EXP>>) >
63 <THSET PAT <REST .PAT>> >
65 <COND (<==? .PAT .PBOUND>
67 (T <IS1 <1 .PAT> <1 .EXP>>) >
68 <THSET PAT <REST .PAT>>
69 <THSET EXP <REST .EXP>> > >>
\f<DEFINE MATCH1
70 <FUNCTION MATCHER ("STACK" PAT1 PAT2 "OPTIONAL" (ENV1 <>) (ENV2 <>)
71 (BOUND1 <BOTTOM .PAT1>) (BOUND2 <BOTTOM .PAT2>)
73 <COND (<==? <TYPE .PAT1> FORM>
74 <COND (<AND <==? <TYPE .PAT2> FORM>
75 <G? <PRECEDENCE <1 .PAT2>> <PRECEDENCE <1 .PAT1>>>>
76 <.MATCHER <INVOKE .PAT2 .PAT1 .BOUND1 T .ENV2 .ENV1 <>>>) >
77 <.MATCHER <INVOKE .PAT1 .PAT2 .BOUND2 .OBL .ENV1 .ENV2 <>>>)
78 (<==? <TYPE .PAT2> FORM>
79 <.MATCHER <INVOKE .PAT2 .PAT1 .BOUND1 T .ENV2 .ENV1 <>>>)
80 (<AND <MONAD? .PAT1> <FULL? .PAT1>>
81 <.MATCHER <OR <=? .PAT1 .PAT2> <FAIL>>>)
82 (<AND <MONAD? .PAT2> <FULL? .PAT2>>
84 (<AND <EMPTY? .PAT1> <EMPTY? .PAT2>>
86 <PROG ("STACK" END1 END2 K1 K2 ALPHA1 ALPHA2 BETA1 BETA2 S1 S2 SEG1 SEG2 FORM1 INC)
87 <SPREAD <PATSOFTEN .PAT1 .BOUND1> ALPHA1 SEG1>
88 <SPREAD <PATSOFTEN .PAT2 .BOUND2> ALPHA2 SEG2>
89 <COND (<G? .ALPHA1 .ALPHA2>
90 <COND (<==? .SEG2 .BOUND2>
92 (<SET SEG1 <REST .PAT1 <SET ALPHA1 .ALPHA2>>>) >)
94 <COND (<AND .OBL <==? .SEG1 .BOUND1>>
96 (<SET SEG2 <REST .PAT2 <SET ALPHA2 .ALPHA1>>>) >) >
98 <COND (<==? .PAT1 .SEG1> <.R <>>)
99 (T <MATCH1 <1 .PAT1> <1 .PAT2> .ENV1 .ENV2>) >
100 <THSET PAT1 <REST .PAT1>>
101 <THSET PAT2 <REST .PAT2>> >
102 <SPREAD <PATHACK .SEG1 .BOUND1 .ENV1> END1 K1 BETA1 S1>
103 <SPREAD <PATHACK .SEG2 .BOUND2 .ENV2> END2 K2 BETA2 S2>
104 <COND (<G? .BETA1 .BETA2>
106 <SET END1 <REST .END1 <SET INC <- .BETA1 .BETA2>>>>
107 <SET K1 <+ .K1 .INC>>
111 <SET END2 <REST .END2 <SET INC <- .BETA2 .BETA1>>>>
112 <SET K2 <+ .K2 .INC>>
114 (T <OR <==? .PAT2 .END2> <FAIL>>
115 <SET END2 <POST .END2 .BOUND2 .K1 .BETA1 .BETA2>>) >) >
116 <COND (<AND <==? .S1 1> <0? .K1>>
117 <COND (<AND <==? .S2 1> <0? .K2>>
118 <SET FORM1 <CHTYPE <1 .SEG2> FORM>>
119 <INVOKE <1 .SEG1> .FORM1 .FORM1 T .ENV1 .ENV2 <>>)
120 (T <INVOKE <1 .SEG1> .SEG2 .END2 T .ENV1 .ENV2 <>>) >)
121 (<AND <==? .S2 1> <0? .K2>>
122 <INVOKE <1 .SEG2> .SEG1 .END1 T .ENV1 .ENV2 <>>)
124 <COND (<G? .K1 .K2> <FAIL>)
126 <SEGMATCH .SEG1 .SEG2 .ENV1 .ENV2 .END1 .END2 .OBL>>) >)
128 <COND (<G? .K2 .K1> <FAIL>)
129 (<SEGMATCH .SEG2 .SEG1 .ENV2 .ENV1 .END2 .END1>) >)
130 (T <#FUNCTION ("STACK" (UV1 UV2)
131 <AND <EMPTY? .UV1> <EMPTY? .UV2> <FAIL>>
132 <LINKVARS .UV1 .UV2 .SEG1 .SEG2 .ENV1 .ENV2 .END1 .END2>)
133 <UVARS .SEG1 .END1 .ENV1>
134 <UVARS .SEG2 .END2 .ENV2>>) >
136 <COND (<==? .END1 .BOUND1> <EXIT .MATCHER .END2>) >
137 <MATCH1 <1 .END1> <1 .END2> .ENV1 .ENV2>
138 <THSET END1 <REST .END1>>
139 <THSET END2 <REST .END2>> > > >>
\f<DEFINE SEGMATCH
140 <FUNCTION SMATCHER ("STACK" PAT1 PAT2 ENV1 ENV2 "OPTIONAL" (BOUND1 <BOTTOM .PAT1>)
141 (BOUND2 <BOTTOM .PAT2>) (OBL T)
144 <COND (<==? .PAT1 .BOUND1>
146 (<==? <TYPE <1 .PAT1>> SEGMENT>
148 <INVOKE <1 .PAT1> .PAT2 .BOUND2 <AND <==? <REST .PAT1> .BOUND1> .OBL> .ENV1 .ENV2 <>>>)
149 (<==? .PAT2 .BOUND2> <FAIL>)
150 (T <MATCH1 <1 .PAT1> <1 .PAT2> .ENV1 .ENV2>
151 <THSET PAT2 <REST .PAT2>>) >
152 <THSET PAT1 <REST .PAT1>> > >>
\f<DEFINE HACKPAT
153 <FUNCTION P ("STACK" PAT PBOUND ENDV KV BETAV)
154 <REPEAT ("STACK" (END .PAT) (KS 0) (BETAS 0))
155 <COND (<==? .PAT .PBOUND>
156 <SET .KV .KS> <SET .BETAV .BETAS>
157 <SET .ENDV .END> <EXIT .P <>>)
158 (<==? <TYPE <1 .PAT>> SEGMENT>
159 <SET KS <+ .KS .BETAS>>
161 <SET END <REST .PAT>>)
162 (T <SET BETAS <+ .BETAS 1>>)>
163 <SET PAT <REST .PAT>> > >>
167 <FUNCTION ("STACK" L LBOUND K BETA "OPTIONAL" (KOUNT <BLENGTH .L .LBOUND>))
168 <AND <G? <+ .K .BETA> .KOUNT>
170 <REST .L <- .KOUNT .BETA>> >>
175 <FUNCTION BL ("STACK" L LB "AUX" (K 0))
176 <COND (<==? .L .LB> .K)
183 <FUNCTION ("STACK" EXP BOUND OBLIGATORY)
184 <OR <==? .EXP .BOUND>
189 <FUNCTION SOFTENER ("STACK" PAT BOUND "AUX" (ALPHA 0))
191 <COND (<OR <==? .PAT .BOUND> <==? <TYPE <1 .PAT>> SEGMENT>>
192 <.SOFTENER [.ALPHA .PAT]>) >
193 <SET ALPHA <+ .ALPHA 1>>
194 <SET PAT <REST .PAT>> > >>
198 <FUNCTION HACKER ("STACK" "BIND" CURENV
200 "AUX" (END .PAT) (K 0) (BETA 0) (S 0)
202 <FINSPLICE .CURENV .ENV>
204 <COND (<==? .PAT .PBOUND>
205 <.HACKER [.END .K .BETA .S]>)
206 (<==? <TYPE <SET PAT1 <1 .PAT>>> SEGMENT>
207 <COND (<OR <FULL? <UARGS .PAT1>>
209 <SET ACTR <ACTOR? <1 .PAT1>>>>>
213 <SET END <REST .PAT>>)
214 (T <SET BETA <+ .BETA 1>>) >
215 <SET PAT <REST .PAT>> > >>