/*  --- University of Sussex POPLOG file -----------------------------------
 > File:           $usepop/pop/local/auto/strmatches.p
 > Purpose:        string matching operator
 > Author:         Roger Evans, Mar 18 1986
 > Machines:       cvaxa unx1 csuna csunb csunc csunh esuna vax2 cgeca
 > Documentation:  HELP * $USEPOP/POP/LOCAL/HELP/STRMATCHES
 */


/* LIB STRMATCHES       R.Evans February 1985

STRMATCHES matches a string against a pattern. See HELP *STRMATCHES

This library is based on the SYSMATCH system procedure for list matching.

*/

vars popmatchvars;  nil -> popmatchvars; ;;; records variable bindings
vars datum;
define sysstrmatch(pattern, i, lrem);
    /*  I is the index into the string to start matching at, LREM is
        the length of string remaining.
        NB: DATUM (the string) is accessed globally */
    lvars pattern i lrem ttt nnn vvv sss rrr savepmvars vi vl;
    popmatchvars -> sss;
loop:
    if pattern == [] and lrem == 0 then return(true) endif;
    unless dataword(pattern)=="pair" then
        if substring(i,lrem,datum) = pattern then return(true) endif;
        goto mfalse;
    endunless;

    fast_front(pattern) -> ttt;
    fast_back(pattern) -> pattern;
    if ttt == "==" then
        if pattern /== [] and front(pattern) == "@" and
           ispair(back(pattern)) and isinteger(front(back(pattern)) ->> nnn)
        then
            ;;; index marker follows == - jump to index position
            back(back(pattern)) -> pattern;
            nnn fi_- i -> nnn;
            if nnn fi_< 0 or nnn fi_> lrem then
                goto mfalse
            else
                i fi_+ nnn -> i;
                lrem fi_- nnn -> lrem;
                goto loop;
            endif;
        elseif pattern == []  then
            return(true)
        endif;
        until sysstrmatch(pattern, i,  lrem) do
            if lrem == 0 then goto mfalse endif;
            i fi_+ 1 -> i;
            lrem fi_- 1 -> lrem;
        enduntil;
        return(true);
    endif;
    if ttt == "??" and pattern /== [] then
        destpair(pattern) -> pattern -> nnn;
        if lmember(nnn, popmatchvars) then
            ;;; the variable was previously found in the pattern
            valof(nnn) -> vvv;
            1 -> vi;
            datalength(vvv) -> vl;
            until vi fi_> vl do
                if lrem == 0  then goto mfalse endif;
                if fast_subscrs(i,datum) /== fast_subscrs(vi,vvv) then
                    goto mfalse
                endif;
                i fi_+ 1 -> i;
                lrem fi_- 1 -> lrem;
                vi fi_+ 1 -> vi;
            enduntil;
            if pattern == nil or front(pattern) /== ":" then goto loop endif;
            ;;; found a colon after the variable
            destpair(fast_back(pattern)) -> pattern -> ttt;
            if isinteger(ttt) then
                ;;; integer followed colon. Check length
                unless datalength(valof(nnn)) == ttt then
                    goto mfalse
                endunless;
                goto loop;
            else
                ;;; restriction procedure followed colon. Apply it
                if isword(ttt) then valof(ttt) -> ttt endif;
                ttt(valof(nnn)) -> vvv;
                unless vvv then goto mfalse endunless;
                if vvv == true then goto loop endif;
                unless sysstrmatch(pattern, i, lrem) then goto mfalse endunless;
                vvv -> valof(nnn);
                return(true);
            endif
        endif;
        ;;; the variable was not previously found in the pattern
        conspair(nnn, popmatchvars) -> popmatchvars;
        if pattern == nil then
            substring(i,lrem,datum) -> valof(nnn);
            return(true);
        endif;
        '' -> valof(nnn);
        ;;; check that if there's an atom following the variable, it occurs in
        ;;; the datum too
        if front(pattern) == ":"
        then
            if ispair(back(back(pattern)) ->> vvv)
            then front(vvv)
            else false endif;
        else front(pattern)
        endif -> vvv;
        if vvv and atom(vvv) and vvv /== "??" and vvv /== "?"
        and vvv /== "=" and vvv /== "==" and vvv /== "@" and
        not((if isinteger(vvv) then locchar else issubstring endif)(vvv,i,datum))
        then
            goto mfalse;
        endif;

        if front(pattern) /== ":" then
            until sysstrmatch(pattern, i, lrem) do
                if lrem == 0 then goto mfalse endif;
                consstring(explode(valof(nnn)),fast_subscrs(i,datum),
                           datalength(valof(nnn)) fi_+ 1)                    
                    -> valof(nnn);
                i fi_+ 1 -> i;
                lrem fi_- 1 -> lrem;
            enduntil;
            return(true);
        endif;
        ;;; found ":" after a ?? variable. Get the restrictor ttt (integer or procedure name)
        destpair(fast_back(pattern)) -> pattern -> ttt;
        if isinteger(ttt) then
            ;;; if there's nothing else in pattern, rest of datum must be right length
            if pattern == [] then
                if lrem == ttt then
                    substring(i,lrem,datum) -> valof(nnn);
                    return(true)
                else
                    goto mfalse
                endif;
            endif;
            /* grab a substring of correct length */
            if lrem fi_< ttt then goto mfalse endif;                    
            substring(i,ttt,datum) -> valof(nnn);
            i fi_+ ttt -> i;
            lrem fi_- ttt -> lrem;
            goto loop;
        endif;
        ;;; found a restriction procedure after the ?? variable
        if isword(ttt) then valof(ttt) -> ttt endif;
        ;;; if there's nothing else in pattern, rest of datum must be right
        if pattern == [] then
            substring(i,lrem,datum) -> rrr;
            ttt(rrr) -> vvv;
            if vvv == true then rrr -> valof(nnn); return(true)
            elseif vvv then vvv -> valof(nnn); return(true)
            else    goto mfalse
            endif;
        endif;

        popmatchvars -> savepmvars;   ;;; may be reset in recursive call
        until sysstrmatch(pattern,i,lrem) and (apply(valof(nnn), ttt) ->> vvv) do
            if lrem == 0 then goto mfalse endif;
            consstring(explode(valof(nnn)),fast_subscrs(i,datum),
                       datalength(valof(nnn)) fi_+ 1)
                -> valof(nnn);
            i fi_+ 1 -> i;
            lrem fi_- 1 -> lrem;
            savepmvars -> popmatchvars;   ;;; in case reset in sysmatch
        enduntil;
        ;;; if restriction procedure produces non-truth-value, give that to the value of the variable
        unless vvv == true then vvv -> valof(nnn) endunless;
        return(true);
    endif;
    if lrem == 0 then goto mfalse endif;
    if ttt == "=" then
        i fi_+ 1 -> i;
        lrem fi_- 1 -> lrem;
        goto loop;
    endif;
    if ttt == "?" and pattern /== [] then
        destpair(pattern) -> pattern -> nnn;
        fast_subscrs(i,datum) -> ttt;
        i fi_+ 1 -> i;
        lrem fi_- 1 -> lrem;
        if lmember(nnn, popmatchvars) then
            unless valof(nnn) = ttt then goto mfalse endunless
        else
            ttt -> valof(nnn);      ;;; check nnn a word etc
            conspair(nnn, popmatchvars) -> popmatchvars;
        endif;
        if pattern == nil or front(pattern) /== ":" then goto loop endif;
        ;;; colon found after pattern variable
        destpair(fast_back(pattern)) -> pattern -> ttt;
        ;;; Restriction procedure found after colon. Apply it.
        if isword(ttt) then valof(ttt) -> ttt endif;
        ttt(valof(nnn)) -> vvv;
        unless vvv then goto mfalse endunless;
        if vvv == true then goto loop endif;
        unless sysstrmatch(pattern, i, lrem) then goto mfalse endunless;
        vvv -> valof(nnn);
        return(true);
    endif;
    if ttt == "@" and pattern /== [] then
        destpair(pattern) -> pattern -> nnn;
        i -> ttt;
        if isinteger(nnn) then
            unless ttt == nnn then goto mfalse endunless;
            goto loop;
        else
            ;;; variable position marker
            if lmember(nnn, popmatchvars) then
                unless valof(nnn) = ttt then goto mfalse endunless
            else
                ttt -> valof(nnn);      ;;; check nnn a word etc
                conspair(nnn, popmatchvars) -> popmatchvars;
            endif;
            if pattern == nil or front(pattern) /== ":" then goto loop endif;
            ;;; colon found after pattern variable
            destpair(fast_back(pattern)) -> pattern -> ttt;
            ;;; Restriction procedure found after colon. Apply it.
            if isword(ttt) then valof(ttt) -> ttt endif;
            ttt(valof(nnn)) -> vvv;
            unless vvv then goto mfalse endunless;
            if vvv == true then goto loop endif;
            unless sysstrmatch(pattern, i, lrem) then goto mfalse endunless;
            vvv -> valof(nnn);
            return(true);
        endif;
    endif;
    /* embedded list call doesn't make sense for strings - just do
       string or character equality */
    if isinteger(ttt) then
        unless fast_subscrs(i,datum) == ttt then goto mfalse endunless;
        i fi_+1 -> i;
        lrem fi_- 1 -> lrem;
        goto loop;
    elseif issubstring(ttt,i,datum) == i then
        length(ttt) -> rrr;
        i fi_+ rrr -> i;
        lrem fi_- rrr -> lrem;
        goto loop;
    endif;
mfalse:
    sss -> popmatchvars;
    return(false);
enddefine;

define vars 8 datum strmatches pattern;
    vars popmatchvars datum pattern;
    unless isstring(datum) or isword(datum) then
        mishap(datum,1,'STRING NEEDED FOR STRMATCHES');
    endunless;
    nil -> popmatchvars;
    sysstrmatch(pattern,1,datalength(datum))
enddefine;

define 8 datum str_--> pattern;
    lvars datum pattern;
    unless datum strmatches pattern then
        mishap(datum,pattern,2,'NON MATCHING ARGUMENTS FOR str_-->')
    endunless
enddefine;