MUDDLE/omatch.1

   1 <SETG FRAMEN
   2   <FUNCTION (N)
   3    <COND (<0? .N> <FRAME>)
   4          (T <FRAME <FRAMEN <- .N 1>>>)>>>\e
   5
   6
   7
   8 <SETG CLEANUP
   9   <FUNCTION CF ()
  10     <FINALIZE>
  11     <BUMPER>>>
  12
  13
  14 <SETG BUMPER
  15   <FUNCTION ()
  16    <FAILPOINT FP ()
  17       <> (M A)
  18       <RESTORE .FP (FAILURE CAUGHT WITH M = .M AND A = .A)>>   >>
  19
  20
  21
  22 <SETG THSET
  23   <FUNCTION (VAR VAL "AUX" (OV <RLVAL .VAR>))
  24       <FAILPOINT ()
  25          <SET .VAR <RLVAL VAL>>
  26          (M A)
  27          <SET .VAR <RLVAL OV>>
  28          <FAIL .M .A>>   >>
  29
  30
  31 <SETG INSTANTIATE
  32   <FUNCTION ("BIND" CUR EXP "OPTIONAL" (ENV <>)
  33                "AUX" (TP <TYPE .EXP>) VAL EXP1)
  34    <SPLICE .CUR .ENV>
  35    <COND (<==? .TP FORM>
  36           <EVAL <CHTYPE <INSTANTIATE <CHTYPE .EXP LIST>>
  37                         FORM>>)
  38          (<MEMQ .TP '(ACTORFORM SACTORFORM)>
  39           <COND (<==? <SET EXP1 <1 .EXP>> GIVEN>
  40                  <OR <AND <ASSIGNED? <2 .EXP>>
  41                           <LVAL <2 .EXP>>>
  42                      .EXP>)
  43                 (<==? .EXP1 ALTER>
  44                  <THSET <2 .EXP> ?()>
  45                  <CHTYPE (GIVEN <2 .EXP>) .TP>)
  46                 (<==? .EXP1 VEL>
  47                  <FAILPOINT FP ((PATS <REST .EXP>) P1)
  48                      <FAIL> ()
  49                      <AND <EMPTY? .PATS> <FAIL>>
  50                      <SET P1 <1 .PATS>>
  51                      <SET PATS <REST .PATS>>
  52                      <RESTORE .FP <INSTANTIATE .P1>>>)
  53                 (<==? .EXP1 BE>
  54                  <OR <EVAL <2 .EXP>> <FAIL>>
  55                  .EXP)
  56                 (<==? .EXP1 ET>
  57                  <OR <AND <EMPTY? <REST .EXP>> .EXP>
  58                      <REPEAT R ((P1 <2 .EXP>) (PATS <REST .EXP 2>))
  59                           <AND <EMPTY? .PATS>
  60                                <EXIT .R <INSTANTIATE .P1>>>
  61                           <MATCH1 .P1 <1 .PATS>>
  62                           <SET PATS <REST .EXP>>   >>)
  63                 (T .EXP)>)
  64         (<MONAD? .EXP> .EXP)
  65         (<==? <TYPE <SET EXP1 <1 .EXP>> > SEGMENT>
  66          (!<EVAL <CHTYPE .EXP1 FORM>>
  67           !<INSTANTIATE <REST .EXP>>))
  68         (<==? <TYPE .EXP1> SACTORFORM>
  69          <SET VAL <INSTANTIATE .EXP1>>
  70          <OR <AND <MEMQ <TYPE .VAL> '(ACTORFORM SACTORFORM)>
  71                   (<CHTYPE .VAL SACTORFORM>
  72                    !<INSTANTIATE <REST .EXP>>)>
  73              (!.VAL !<INSTANTIATE <REST .EXP>>)>)
  74         (T (<INSTANTIATE .EXP1> !<INSTANTIATE <REST .EXP>>))>   >>\f<SETG FALSE
  75   <FUNCTION ("ARGS" A) <CHTYPE <EVAL .A> FALSE>  >>
  76
  77
  78 <SETG FORM
  79   <FUNCTION ("ARGS" A) <CHTYPE <EVAL .A> FORM>  >>
  80
  81 <SETG UNASSIGNED
  82   <FUNCTION ("ARGS" A) <CHTYPE <EVAL .A> UNASSIGNED>  >>
  83
  84 <SETG SEGMENT
  85   <FUNCTION ("REST" 'A) <CHTYPE <EVAL .A> SEGMENT>  >>
  86
  87 <SETG ACTOR
  88   <FUNCTION ("ARGS" A) <CHTYPE .A ACTOR>  >>
  89
  90 <SETG ACTOR-FUNCTION
  91   <FUNCTION ("ARGS" A) <CHTYPE .A ACTOR-FUNCTION>  >>
  92
  93 <SETG INVOKE
  94   <FUNCTION ("BIND" CUR AFORM OBJECT
  95              "OPTIONAL" (BOUNDARY <BOTTOM .OBJECT>) (OBLIGATORY T) (ENV <>)
  96              "AUX" ACTOR)
  97    <SPLICE .CUR .ENV>
  98    <COND (<ATOM? <1 .AFORM>>
  99           <SET ACTOR <AVAL <1 .AFORM>>>)
 100          (<SET ACTOR <EVAL <1 .AFORM>>>)>
 101    <COND (<==? <TYPE .ACTOR> ACTOR-FUNCTION>
 102           <EVAL <FORM <CHTYPE .ACTOR FUNCTION>
 103                       '.OBJECT
 104                       '.BOUNDARY
 105                       .OBLIGATORY
 106                       !<REST .AFORM>>>)
 107          (<==? <TYPE .ACTOR> ACTOR>
 108           <ERROR ATTEMPT-TO-INVOKE-ACTOR>)
 109          (<ERROR NON-INVOKABLE-TYPE>)>  >>
 110
 111
 112 <SETG AVAL
 113   <FUNCTION (ATOM)
 114    <COND (<GASSIGNED? .ATOM> <GVAL .ATOM>)
 115          (<LVAL .ATOM>)>  >>
 116
 117
 118 <SETG ACTOR?
 119   <FUNCTION (EXP)
 120    <AND <ATOM? .EXP> <SET EXP <AVAL .EXP>>>
 121    <MEMQ <TYPE .EXP> '(ACTOR ACTOR-FUNCTION)>  >>\f<SETG ACTORSUBST1
 122   <FUNCTION AS (AFORM PURESWITCH
 123                 "AUX" (A1 <1 .AFORM>) (TP <TYPE .AFORM>)
 124                       (A2 <OR <EMPTY? <REST .AFORM>> <2 .AFORM>>))
 125    <COND (<==? .A1 GIVEN>
 126           <COND (<ASSIGNED? .A2>
 127                  <SET .PURESWITCH T>
 128                  <LVAL .A2>)
 129                 (T <SET .PURESWITCH <FALSE .A2>>
 130                    .AFORM)>)
 131          (<==? .A1 ALTER>
 132           <THSET .A2 ?()>
 133           <SET .PURESWITCH <FALSE .A2>>
 134           <CHTYPE (GIVEN .A2) .TP>)
 135          (<==? .A1 VEL>
 136           <PROG ((PAT <ANOTHERPAT <REST .AFORM> .PURESWITCH>))
 137              <COND (<OR ..PURESWITCH
 138                         <NOT <==? <TYPE .PAT> FORM>>>
 139                     .PAT)
 140                    (<CHTYPE .PAT .TP>)>>)
 141          (<==? .A1 BE>
 142           <OR <EVAL .A2> <FAIL>>
 143           <CHTYPE '<?> .TP>)
 144          (<==? .A1 ET>
 145           <AND <EMPTY? <REST .AFORM>>
 146                <EXIT .AS <CHTYPE '<?> .TP>>>
 147           <REPEAT R ((PATS <REST .AFORM 2>) (SPATS ())
 148                      (BEG ()) (P <>))
 149              <COND (<EMPTY? <SET BEG <CHOMP PATS .BEG P>>>
 150                     <SET .PURESWITCH <>>
 151                     <EXIT .R <CHTYPE (ET !.SPATS) .TP>>)
 152                    (<OR .P <NOT <EMPTY? .P>>>
 153                     <SET .PURESWITCH .P>
 154                     <SET A2 <1 .BEG>>
 155                     <REPEAT RESTRICT ()
 156                        <AND <EMPTY? .SPATS> <EXIT .RESTRICT <>>>
 157                        <MATCH1 .A2 <1 .SPATS>>
 158                        <SET SPATS <REST .SPATS>>  >
 159                     <REPEAT ()
 160                        <AND <EMPTY? <SET BEG <CHOMP PATS .BEG P>>>
 161                             <EXIT .R .A2>>
 162                        <MATCH1 .A2 <1 .BEG>>  >)
 163                    (T <SET SPATS (<1 .BEG> !.SPATS)>)>  >)
 164          (.AFORM)>   >>\f<SETG ANOTHERPAT
 165   <FUNCTION (PATSVAL PURESWITCH
 166              "AUX" (VAL1 <CLIP PATSVAL>))
 167    <COND (<SET .PURESWITCH <MONAD? .VAL1>>
 168            .VAL1)
 169          (<==? <TYPE .VAL1> FORM>
 170           <COND (<ACTOR? <1 .VAL1>>
 171                  <ACTORSUBST1 .VAL1 .PURESWITCH>)
 172                 (<SET .PURESWITCH T>
 173                  <EVAL <ACTORSUBST .VAL1>>)   >)
 174          (T .VAL1)   >   >>
 175
 176
 177 <SETG CLIP
 178   <FUNCTION (VAR "AUX" (VAL ..VAR))
 179    <COND (<EMPTY? .VAL> <FAIL>)>
 180    <PROG1 <1 .VAL> <SET .VAR <REST .VAL>>>   >>\f<SETG CHOMP
 181  <FUNCTION CHOMP ("BIND" C VAR ENDVAR BEG PURESWITCH "OPTIONAL" (ENV <>)
 182                   "AUX" (VAL ..VAR) VAL1)
 183    <COND (<OR <EMPTY? .BEG>
 184               <EMPTY? <SET BEG <REST .BEG>>>
 185               <==? .BEG .VAL>>
 186           <COND (<OR <MONAD? .VAL> <==? .VAL .ENDVAR>>
 187                  <SET .PURESWITCH <>>
 188                  <EXIT .CHOMP ()>)>
 189           <THSET .VAR <REST .VAL>>
 190           <COND (<SET .PURESWITCH <MONAD? <SET VAL1 <1 .VAL>>>>
 191                  .VAL)
 192                 (<==? <TYPE .VAL1> FORM>
 193                  <SPLICE .C .ENV>
 194                  (<COND (<ACTOR? <1 .VAL1>>
 195                          <ACTORSUBST1 .VAL1 .PURESWITCH>)
 196                         (<SET .PURESWITCH T>
 197                          <EVAL <ACTORSUBST .VAL1 >>)   >))
 198                 (<==? <TYPE .VAL1> SEGMENT>
 199                  <SPLICE .C .ENV>
 200                  <SET VAL1
 201                       <COND (<ACTOR? <1 .VAL1>>
 202                              <SET VAL1 <ACTORSUBST1 .VAL1 .PURESWITCH>>
 203                              <OR <AND <OR ..PURESWITCH
 204                                           <NOT <==? <TYPE .VAL1> SEGMENT>>>
 205                                       .VAL1>
 206                                  (.VAL1)>)
 207                             (<SET .PURESWITCH T>
 208                              <EVAL <ACTORSUBST .VAL1>>)   >>
 209                  <COND (<EMPTY? .VAL1>
 210                         <SET BEG ()>
 211                         <SET .VAR <SET VAL <REST .VAL>>>
 212                         <AGAIN .CHOMP>)
 213                        (T .VAL1)>)
 214                 (T .VAL)>)
 215          (.BEG)>   >>
 216
 217 <SETG RESET
 218  <FUNCTION (VAR)
 219    <FAILPOINT ((VAL <RLVAL .VAR>)) <> ()
 220       <SET .VAR <RLVAL VAL>>
 221       <FAIL>>  >>
 222
 223 <SETG PROG1
 224  <FUNCTION ("REST" A) <1 .A>   >>\f<SETG ACTORSUBST
 225  <FUNCTION A ("BIND" C EXP "OPTIONAL" (ENV <>)
 226               "AUX" (PURE <>) TP EXP1)
 227    <OR <MULTILEVEL .EXP> <EXIT .A .EXP>>
 228    <SPLICE .C .ENV>
 229    <COND (<ACTORFORM? <SET EXP1 <1 .EXP>>>
 230           <SET TP <TYPE .EXP1>>
 231           <SET EXP1 <ACTORSUBST1 .EXP1 PURE>>
 232           <AND <==? .TP SEGMENT>
 233                <OR .PURE <NOT <==? <TYPE .EXP1> FORM>>>
 234                <EXIT .A
 235                      <<CONSTRUCTOR <TYPE .EXP>>
 236                       !.EXP1
 237                       !.<ACTORSUBST <REST .EXP>>>>>)
 238          (T <SET EXP1 <ACTORSUBST .EXP1>>)   >
 239    <<CONSTRUCTOR <TYPE .EXP>> .EXP1 !.<ACTORSUBST <REST .EXP>>>   >>
 240
 241
 242 <SETG MULTILEVEL
 243  <FUNCTION (OBJECT)
 244    <AND <NOT <MONAD? .OBJECT>>
 245         <MEMQ <TYPE .OBJECT> '(LIST FORM VECTOR SEGMENT VECTOR)>>   >>
 246
 247
 248 <SETG ACTORFORM?
 249  <FUNCTION (EXP)
 250    <AND <MEMQ <TYPE .EXP> '(FORM SEGMENT)>
 251         <NOT <EMPTY? .EXP>>
 252         <ACTOR? <1 .EXP>>>  >>
 253
 254
 255 <SETG GIVEN
 256  <ACTOR-FUNCTION (OBJECT BOUNDARY OBLIGATORY VAR
 257                   "AUX" (VAL <RLVAL .VAR>))
 258    <AND <==? <TYPE <RLVAL VAL>> UNASSIGNED>
 259         <REPEAT R ((V <CHTYPE <RLVAL VAL> LIST>))
 260            <AND <EMPTY? .V> <EXIT .R <>>>
 261            <SET BOUNDARY <IS2 <1 <1 .V>> .OBJECT .BOUNDARY .OBLIGATORY <2 <1 .V>>>>
 262            <SET OBLIGATORY T>
 263            <SET V <REST .V>>  >>
 264    <COND (<ASSIGNED? .VAR>
 265           <COND (<OR <MONAD? .OBJECT> .OBLIGATORY>
 266                  <OR <=? ..VAR .OBJECT> <FAIL>>)
 267                 (T
 268                  <SET BOUNDARY <PREFIX1 ..VAR () .OBJECT .BOUNDARY>>)>)
 269          (T <THSET .VAR
 270                    <UPTO .OBJECT
 271                          <COND (<OR <MONAD? .OBJECT> .OBLIGATORY>
 272                                 .BOUNDARY)
 273                                (T <SET BOUNDARY
 274                                        <ANOTHER .OBJECT .BOUNDARY>>)>>>)>
 275    .BOUNDARY  >>
 276
 277
 278
 279 <SETG BE
 280  <ACTOR-FUNCTION (OBJECT BOUNDARY OBLIGATORY PRED)
 281    <OR .PRED <FAIL>>
 282    <COND (.OBLIGATORY .BOUNDARY)
 283          (T <ANOTHER .OBJECT .BOUNDARY>)>  >>
 284
 285
 286
 287 <SETG ?
 288  <ACTOR-FUNCTION (OBJECT BOUNDARY OBLIGATORY "OPTIONAL" (N <>))
 289    <COND (.OBLIGATORY
 290           <OR <NOT .N> <==? .N <BLENGTH .OBJECT .BOUNDARY>> <FAIL>>
 291           .BOUNDARY)
 292          (.N
 293           <COND (<G? .N <BLENGTH .OBJECT .BOUNDARY>>
 294                  <FAIL>)
 295                 (T <REST .OBJECT .N>)>)
 296          (T <ANOTHER .OBJECT .BOUNDARY>)>  >>
 297
 298
 299
 300 <SETG ALTER
 301  <ACTOR-FUNCTION (OBJECT BOUNDARY OBLIGATORY VAR)
 302    <THSET .VAR
 303           <UPTO .OBJECT
 304                 <COND (<OR <MONAD? .OBJECT> .OBLIGATORY>
 305                        .BOUNDARY)
 306                       (T <SET BOUNDARY
 307                               <ANOTHER .OBJECT .BOUNDARY>>)>>>
 308    .BOUNDARY  >>
 309
 310
 311 <SETG VEL
 312  <ACTOR-FUNCTION (OBJECT BOUNDARY OBLIGATORY "ARGS" A)
 313    <ERROR VEL-UNDER-CONSTRUCTION> >>\f<SETG ANOTHER
 314  <FUNCTION (OBJ BOUND)
 315    <FAILPOINT FP ()
 316      .OBJ ()
 317      <AND <==? .OBJ .BOUND> <FAIL>>
 318      <RESTORE .FP <SET OBJ <REST .OBJ>>>>  >>
 319
 320
 321
 322 <SETG HACKPAT
 323  <FUNCTION P (PAT ENDV KV BETAV)
 324    <REPEAT ((END .PAT) (KS 0) (BETAS 0))
 325       <COND (<EMPTY? .PAT>
 326              <SET .KV .KS> <SET .BETAV .BETAS>
 327              <SET .ENDV .END>  <EXIT .P <>>)
 328             (<==? <TYPE <1 .PAT>> SEGMENT>
 329              <SET KS <+ .KS .BETAS>>
 330              <SET BETAS 0>
 331              <SET END <REST .PAT>>)
 332             (T <SET BETAS <+ .BETAS 1>>)>
 333       <SET PAT <REST .PAT>>  >  >>
 334
 335
 336 <SETG POST
 337  <FUNCTION (L LBOUND K BETA "AUX" (KOUNT <BLENGTH .L .LBOUND>))
 338    <AND <G? <+ .K .BETA> .KOUNT>
 339         <FAIL>>
 340    <REST .L <- .KOUNT .BETA>>  >>
 341
 342
 343
 344 <SETG BLENGTH
 345  <FUNCTION BL (L LB "AUX" (K 0))
 346    <COND (<==? .L .LB> .K)
 347          (T <SET L <REST .L>>
 348             <SET K <+ .K 1>>
 349             <AGAIN .BL>)>  >>
 350
 351 <SETG PREFIX1
 352  <FUNCTION P (L1 TERM1 L2 TERM2)
 353    <COND (<OR <EMPTY? .L1> <==? .L1 .TERM1>>
 354           <EXIT .P .L2>)
 355          (<==? .L2 .TERM2> <FAIL>)>
 356    <OR <=? <1 .L1> <1 .L2>> <FAIL>>
 357    <SET L1 <REST .L1>>   <SET L2 <REST .L2>>
 358    <AGAIN .P>  >>
 359
 360
 361 <SETG CONSTRUCTOR
 362  <FUNCTION (TYPE)
 363    <GET .TYPE 'CONSTRUCTOR>   >>
 364
 365
 366 <PUT LIST CONSTRUCTOR ,CONSL>
 367 <PUT FORM CONSTRUCTOR ,FORM>
 368 <PUT VECTOR  CONSTRUCTOR ,CONSV>
 369 <PUT SEGMENT CONSTRUCTOR ,SEGMENT>
 370 <PUT UVECTOR CONSTRUCTOR ,CONSU>\f<SETG IS1
 371  <FUNCTION S ("BIND" C PAT EXP
 372               "OPTIONAL" (BOUND <BOTTOM .EXP>) (OBLIGATORY T) (ENV <>)
 373               "AUX" (BEG ()) PURE ENDP BETA ENDE K ENDP1)
 374    <COND (<EMPTY? .PAT> <EXIT .S <OR <EMPTY? .EXP> <FAIL>>>)
 375          (<MONAD? .PAT>
 376           <EXIT .S <OR <=? .PAT .EXP> <FAIL>>>)
 377          (<MONAD? .EXP>
 378           <OR <EMPTY? .EXP> <FAIL>>)>
 379    <SPLICE .C .ENV>
 380    <SET ENDP1 <BOTTOM .PAT>>
 381    <REPEAT R ()
 382       <COND (<EMPTY? <THSET BEG <CHOMP PAT .ENDP1 .BEG PURE>>>
 383              <EXIT .S <GOTEND .EXP .BOUND .OBLIGATORY>>)
 384             (.PURE
 385              <THSET EXP <PREFIX1 .BEG .PAT .EXP .BOUND>>
 386              <SET BEG ()>)
 387             (<==? <TYPE <1 .BEG>> SEGMENT>
 388              <EXIT .R <>>)
 389             (T <IS2 <1 .BEG> <1 .EXP>>
 390                <THSET EXP <REST .EXP>>)>  >
 391    <HACKPAT .PAT ENDP K BETA>
 392    <SET ENDE <POST .EXP .BOUND .K .BETA>>
 393    <REPEAT R ()
 394       <COND (.PURE
 395              <THSET EXP <PREFIX1 .BEG .PAT .EXP .ENDE>>
 396              <SET BEG ()>)
 397             (<==? <TYPE <1 .BEG>> SEGMENT>
 398              <THSET EXP <INVOKE <1 .BEG>
 399                                 .EXP
 400                                 .ENDE
 401                                 <AND <==? .PAT .ENDP> .OBLIGATORY>>>)
 402             (<==? .EXP .ENDE> <FAIL>)
 403             (T <IS2 <1 .BEG> <1 .EXP>>
 404                <THSET EXP <REST .EXP>>)>
 405       <COND (<EMPTY? <THSET BEG <CHOMP PAT .ENDP .BEG PURE>>>
 406              <EXIT .R <OR <==? .EXP .ENDE> <NOT .OBLIGATORY> <FAIL>>>)>   >
 407    <THSET ENDE .EXP>
 408    <REPEAT ()
 409       <COND (<EMPTY? <THSET BEG <CHOMP ENDP .ENDP1 .BEG PURE>>>
 410              <EXIT .S .ENDE>)
 411             (.PURE
 412              <OR <=? <1 .BEG> <1 .ENDE>> <FAIL>>)
 413             (T <IS2 <1 .BEG> <1 .ENDE>>) >
 414       <SET ENDE <REST .ENDE>>  >  >>\f<SETG GOTEND
 415  <FUNCTION (EXP BOUND OBLIGATORY)
 416    <OR <==? .EXP .BOUND>
 417        <NOT .OBLIGATORY>
 418        <FAIL>>
 419    .EXP  >>
 420
 421
 422 <SETG IS2
 423  <FUNCTION (PAT EXP "OPTIONAL" (BOUND <BOTTOM .EXP>) (OBLIGATORY T) (ENV <>))
 424    <COND (<==? <TYPE .PAT> FORM>
 425           <INVOKE .PAT .EXP .BOUND .OBLIGATORY .ENV>)
 426          (<IS1 .PAT .EXP .BOUND .OBLIGATORY .ENV>)  >  >>
 427
 428
 429 <SETG UPTO
 430  <FUNCTION (EXP1 EXP2)
 431    <COND (<MONAD? .EXP1>
 432           .EXP1)
 433          (<==? .EXP1 .EXP2>
 434           ())
 435          ((<1 .EXP1> !<UPTO <REST .EXP1> .EXP2>))>  >>
 436
 437
 438 <SETG IS
 439  <FUNCTION S ('PAT EXP "AUX" (PURE <>))
 440    <COND (<ACTORFORM? .PAT>
 441           <SET PAT <ACTORSUBST1 .PAT PURE>>
 442           <AND .PURE
 443                <EXIT .S <=? .PAT .EXP>>>
 444           <FAILPOINT ()
 445              <PROG1 T <INVOKE .PAT .EXP>>
 446              () <>>)
 447          (T <FAILPOINT ()
 448                <PROG1 T <IS1 .PAT .EXP>>
 449                () <>>)>  >>
 450
 451
 452 <SETG BOTTOM
 453  <FUNCTION (THING)
 454    <COND (<MONAD? .THING> <>)
 455          (<==? <TYPE .THING> LIST> ())
 456          (T <REST .THING <LENGTH .THING>>)>  >>\f\f\ 3\f