GET "LIBHDR"
GET "pattern"

STATIC $(
WORK=0;   WP=0;   SUCCFLAG=FALSE
PAT=0;    AUX=0
CH=0;     PATP=0; PATLEN=0
ERRORFLAG=FALSE
$)

// The Interpreter

LET MATCH(PAT, AUX, STR) = VALOF
$(1 LET W = VEC 128
    LET S = 0
    WORK, WP, SUCCFLAG := W, 0, FALSE
    PUT(1)
    UNLESS GETBYTE(AUX,0)=0 DO PUT(GETBYTE(AUX,0))

$(2 // FIRST COMPLETE THE CLOSURE
    $( LET N = 1
       UNTIL N>WP DO
       $( LET P = WORK!N
          LET K, Q = GETBYTE(PAT,P), GETBYTE(AUX,P)
          SWITCHON K INTO
          $( CASE '#': PUT(P+1)
             CASE '%': PUT(Q)
             DEFAULT:  ENDCASE
             CASE '(':
             CASE '/': PUT(P+1)
                       UNLESS Q=0 DO PUT(Q)
          $)
          N := N+1
       $)

    IF S>=GETBYTE(STR,0) RESULTIS SUCCFLAG
    IF WP=0 RESULTIS FALSE
    S := S+1
    CH := GETBYTE(STR,S)

    // NOW DEAL WITH MATCH ITEMS
    $( LET N = WP
       WP, SUCCFLAG := 0, FALSE

       FOR I = 1 TO N DO
       $( LET P = WORK!I
          LET Q = P
          LET K = GETBYTE(PAT,P)
          SWITCHON K INTO
          $( CASE '#':
             CASE '/':
             CASE '%':
             CASE '(': LOOP

             CASE '*'':K := GETBYTE(PAT,Q+1)
                       Q := Q+1
             DEFAULT:  // A MATCH ITEM
             $( LET K1 = K
                IF GETBYTE(PAT,Q+1)='-' DO
                $( K1 := GETBYTE(PAT,Q+2)
                   IF K1='*'' DO K1 := GETBYTE(PAT,Q+3)
                $)
                UNLESS K<=CH<=K1 LOOP  // I.E. NO MATCH
             $)
             CASE '?': // SUCCESSFUL MATCH
                       PUT(GETBYTE(AUX,P))
                       LOOP
          $)
       $)
    $)
$)2 REPEAT
$)1

AND PUT(N) BE TEST N=0
    THEN SUCCFLAG := TRUE
    ELSE $( FOR I = 1 TO WP IF WORK!I=N RETURN
            WP := WP+1
            WORK!WP := N
         $)

// The Compiler

LET RCH() BE TEST PATP>=PATLEN
    THEN CH := ENDSTREAMCH
    ELSE $( PATP := PATP+1
            CH := GETBYTE(PAT,PATP)
         $)

AND NEXTITEM() BE SWITCHON CH INTO
    $( CASE '#':
       CASE '(':
       CASE '/':
       CASE ')':
       CASE '%':
       CASE '?': RCH()
                 RETURN

       CASE '*'':RCH()
       DEFAULT:  RCH()
       IF CH='-' DO $( RCH()
                       IF CH='*'' DO RCH()
                       RCH()
                    $)
    $)

AND PRIM() = VALOF
$(1 LET A, OP = PATP, CH
    NEXTITEM()
    SWITCHON OP INTO
    $( CASE ENDSTREAMCH:
       CASE ')':
       CASE '-':
       CASE '/': ERRORFLAG := TRUE
       DEFAULT:  RESULTIS A

       CASE '#': SETEXITS(PRIM(), A)
                 RESULTIS A

       CASE '(': A := EXP(A)
                 UNLESS CH=')' DO ERRORFLAG := TRUE
                 NEXTITEM()
                 RESULTIS A
    $)
$)1

AND EXP(ALTP) = VALOF
$(1 LET EXITS = 0

$(2 LET A = PRIM()
    TEST CH='/' \/ CH=')' \/ CH=ENDSTREAMCH
    THEN $( EXITS := JOIN(EXITS,A)
            UNLESS CH='/' RESULTIS EXITS
            PUTBYTE(AUX,ALTP,PATP)
            ALTP := PATP
            NEXTITEM()
         $)
    ELSE SETEXITS(A,PATP)
$)2 REPEAT
$)1


AND SETEXITS(LIST,VAL) BE UNTIL LIST=0 DO
$( LET A = GETBYTE(AUX,LIST)
   PUTBYTE(AUX,LIST,VAL)
   LIST := A  $)

AND JOIN(A,B) = VALOF
$( LET T = A
   IF A=0 RESULTIS B
   UNTIL GETBYTE(AUX,A)=0 DO A := GETBYTE(AUX,A)
   PUTBYTE(AUX,A,B)
   RESULTIS T
$)

AND CMPLPAT(PATTERN, CMPLPATTERN) = VALOF
$(1 PAT, AUX := PATTERN, CMPLPATTERN
    PATP, PATLEN := 0, GETBYTE(PAT,0)
    ERRORFLAG := FALSE
    FOR I = 0 TO PATLEN DO PUTBYTE(AUX,I,0)
    RCH()
    SETEXITS(EXP(0),0)
    RESULTIS NOT ERRORFLAG
$)1