MUDDLE/nmatch.1

   1 <DEFINE IS
   2  <FUNCTION ("STACK" "BIND" TOPMATCH
   3             'PAT EXP)
   4    <IS1 .PAT .EXP>
   5    T   >>
   6
   7
   8 <DEFINE IS?
   9  <FUNCTION ("STACK" "BIND" TOPMATCH
  10             'PAT EXP)
  11    <FAILPOINT ()
  12       <PROG2 <IS1 .PAT .EXP> T>
  13       ("STACK")
  14       <>   >>>
  15
  16
  17 <DEFINE MATCH
  18  <FUNCTION ("STACK" "BIND" TOPMATCH
  19             'PAT1 'PAT2)
  20    <MATCH1 .PAT1 .PAT2>
  21    T   >>
  22
  23
  24 <DEFINE MATCH?
  25  <FUNCTION ("STACK" "BIND" TOPMATCH
  26             'PAT1 'PAT2)
  27    <FAILPOINT ()
  28       <PROG2 <MATCH1 .PAT1 .PAT2> T>
  29       ("STACK")
  30       <>   >>>
  31
  32
  33 <DEFINE ASSIGN
  34  <FUNCTION ("STACK" "BIND" TOPMATCH
  35             'PAT EXP)
  36   <FAILPOINT ()
  37       <PROG2 <IS1 .PAT .EXP> .EXP>
  38       ("STACK")
  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>>)
  46          (<EMPTY? .PAT>
  47           <OR <==? .EXP .BOUND> <FAIL>>
  48           .BOUND)
  49          (<MONAD? .PAT>
  50           <.S <OR <=? .PAT .EXP> <FAIL>>>)
  51          (<MONAD? .EXP>
  52           <OR <EMPTY? .EXP> <FAIL>>)   >
  53    <FINSPLICE .C .ENV>
  54    <HACKPAT .PAT .PBOUND ENDP K BETA>
  55    <SET ENDE <POST .EXP .BOUND .K .BETA>>
  56    <REPEAT R ("STACK")
  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>>   >
  64    <REPEAT ("STACK")
  65       <COND (<==? .PAT .PBOUND>
  66              <.S .EXP>)
  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>)
  72                       (OBL T))
  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>>
  83           <FAIL>)
  84          (<AND <EMPTY? .PAT1> <EMPTY? .PAT2>>
  85           <.MATCHER .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>
  91                     <FAIL>)
  92                    (<SET SEG1 <REST .PAT1 <SET ALPHA1 .ALPHA2>>>)   >)
  93             (<G? .ALPHA2 .ALPHA1>
  94              <COND (<AND .OBL <==? .SEG1 .BOUND1>>
  95                     <FAIL>)
  96                    (<SET SEG2 <REST .PAT2 <SET ALPHA2 .ALPHA1>>>)   >)   >
  97       <REPEAT R ("STACK")
  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>
 105              <OR .OBL <FAIL>>
 106              <SET END1 <REST .END1 <SET INC <- .BETA1 .BETA2>>>>
 107              <SET K1 <+ .K1 .INC>>
 108              <SET BETA1 .BETA2>)
 109             (<G? .BETA2 .BETA1>
 110              <COND (.OBL
 111                     <SET END2 <REST .END2 <SET INC <- .BETA2 .BETA1>>>>
 112                     <SET K2 <+ .K2 .INC>>
 113                     <SET BETA2 .BETA1>)
 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 <>>)
 123             (<0? .S2>
 124              <COND (<G? .K1 .K2> <FAIL>)
 125                    (T <THSET END2
 126                              <SEGMATCH .SEG1 .SEG2 .ENV1 .ENV2 .END1 .END2 .OBL>>)   >)
 127             (<0? .S1>
 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>>)   >
 135       <REPEAT ("STACK")
 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)
 142                      "AUX" FORM1)
 143    <REPEAT ("STACK")
 144       <COND (<==? .PAT1 .BOUND1>
 145              <.SMATCHER .PAT2>)
 146             (<==? <TYPE <1 .PAT1>> SEGMENT>
 147              <THSET PAT2
 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>>
 160              <SET BETAS 0>
 161              <SET END <REST .PAT>>)
 162             (T <SET BETAS <+ .BETAS 1>>)>
 163       <SET PAT <REST .PAT>>  >  >>
 164
 165
 166 <DEFINE POST
 167  <FUNCTION ("STACK" L LBOUND K BETA "OPTIONAL" (KOUNT <BLENGTH .L .LBOUND>))
 168    <AND <G? <+ .K .BETA> .KOUNT>
 169         <FAIL>>
 170    <REST .L <- .KOUNT .BETA>>  >>
 171
 172
 173
 174 <DEFINE BLENGTH
 175  <FUNCTION BL ("STACK" L LB "AUX" (K 0))
 176    <COND (<==? .L .LB> .K)
 177          (T <SET L <REST .L>>
 178             <SET K <+ .K 1>>
 179             <AGAIN .BL>)>  >>
 180
 181
 182 <DEFINE GOTEND
 183  <FUNCTION ("STACK" EXP BOUND OBLIGATORY)
 184    <OR <==? .EXP .BOUND>
 185        <NOT .OBLIGATORY>
 186        <FAIL>>
 187    .EXP  >>
 188 \f<DEFINE PATSOFTEN
 189  <FUNCTION SOFTENER ("STACK" PAT BOUND "AUX" (ALPHA 0))
 190    <REPEAT ("STACK")
 191       <COND (<OR <==? .PAT .BOUND> <==? <TYPE <1 .PAT>> SEGMENT>>
 192              <.SOFTENER [.ALPHA .PAT]>)   >
 193       <SET ALPHA <+ .ALPHA 1>>
 194       <SET PAT <REST .PAT>>   >   >>
 195
 196
 197 <DEFINE PATHACK
 198  <FUNCTION HACKER ("STACK" "BIND" CURENV
 199                    PAT PBOUND ENV
 200                    "AUX" (END .PAT) (K 0) (BETA 0) (S 0)
 201                          PAT1)
 202    <FINSPLICE .CURENV .ENV>
 203    <REPEAT ("STACK")
 204       <COND (<==? .PAT .PBOUND>
 205              <.HACKER [.END .K .BETA .S]>)
 206             (<==? <TYPE <SET PAT1 <1 .PAT>>> SEGMENT>
 207              <COND (<OR <FULL? <UARGS .PAT1>>
 208                         <AND <FULL? .PAT1>
 209                              <SET ACTR <ACTOR? <1 .PAT1>>>>>
 210                     <SET S <+ .S 1>>)   >
 211              <SET K <+ .K .BETA>>
 212              <SET BETA 0>
 213              <SET END <REST .PAT>>)
 214             (T <SET BETA <+ .BETA 1>>)   >
 215       <SET PAT <REST .PAT>>   >   >>
 216 \f\ 3\f