/* -*-c,save-*- */
/*
 * PATTERN.C - Pattern match functions
 * Robert Heller. Created: Sat Oct 19, 1985 13:52:15.52
 * Last Mod: Sun Oct 27, 1985 19:05:28.05
 * 
 * (c) Copyright 1985 by Robert Heller
 *     All Rights Reserved
 * 
 * 
 */
#define PMODULE
#include "patdef.h"
#define TRUE 1
#define FALSE 0
/*
 * global, "constant" primitives
 */

PATTERN_NODE *NIL,*FENCE,*FAIL,*SUCCESS,*ABORT,*REM,*ARB,*BAL;

static PATTERN_NODE _nil,_fence,_fail,_success,_abort,_rem,_arb1,_arb2,_arb3,
		    _gbal,_bal1,_bal2;

/*
 *  pattern_init() - initialize global, "constant" primitives
 */
pattern_init()
{
    short int m_nil(),m_fence(),m_fail(),m_success(),m_abort(),m_rem(),
	      m_arb1(),m_arb2(),m_gbal();
    PATTERN_NODE *temp;

    /* NIL primitive - match a zero length string */
    NIL = (&_nil);
    NIL->prog = m_nil;
    NIL->subs = NIL->alts = NIL->arg = 0L;
    NIL->resid = NIL->__mark = 0;

    /* FENCE - matchs the null string going forward, but aborts if backed
       into */
    FENCE = (&_fence);
    FENCE->prog = m_fence;
    FENCE->subs = FENCE->alts = FENCE->arg = 0L;
    FENCE->resid = FENCE->__mark = 0;

    /* FAIL - fails. */
    FAIL = (&_fail);
    FAIL->prog = m_fail;
    FAIL->subs = FAIL->alts = FAIL->arg = 0L;
    FAIL->resid = FAIL->__mark = 0;

    /* SUCCESS - succedes */
    SUCCESS = (&_success);
    SUCCESS->prog = m_success;
    SUCCESS->subs = SUCCESS->alts = SUCCESS->arg = 0L;
    SUCCESS->resid = SUCCESS->__mark = 0;

    /* ABORT - aborts */
    ABORT = (&_abort);
    ABORT->prog = m_abort;
    ABORT->subs = ABORT->alts = ABORT->arg = 0L;
    ABORT->resid = ABORT->__mark = 0;

    /* REM - matches the reaminder of the object string */
    REM = (&_rem);
    REM->prog = m_rem;
    REM->subs = REM->alts = REM->arg = 0L;
    REM->resid = REM->__mark = 0;

    /* ARB - matches an arbitrary string */
    /* (this one is a compound */
    ARB = (&_arb1);
    ARB->prog = m_arb1;
    ARB->alts = ARB->arg = 0L;
    ARB->resid = ARB->__mark = 0;
    ARB->subs = temp = (&_arb2);
    temp->prog = m_nil;
    temp->subs = temp->arg = 0L;
    temp->resid = temp->__mark = 0;
    temp->alts = (&_arb3);
    temp = temp->alts;
    temp->prog = m_arb2;
    temp->subs = temp->alts = temp->arg = 0L;
    temp->resid = temp->__mark = 0;

    /* BAL - matches a paren balanced string */
    BAL = (&_bal1);
    temp = (&_gbal);
    BAL->prog = m_nil;
    BAL->subs = temp;
    BAL->alts = BAL->arg = 0L;
    BAL->resid = 1;
    BAL->__mark = 0;
    temp->prog = m_gbal;
    temp->alts = temp->arg = 0L;
    temp->subs = (&_bal2);
    temp->resid = temp->__mark = 0;
    temp->subs->alts = temp;
    temp = temp->subs;
    temp->prog = m_nil;
    temp->subs = temp->arg = 0L;
    temp->resid = temp->__mark = 0;
    }
/*
 * STACK_SIZE is somewhat conservative
 */

#define STACK_SIZE 128

/* stacks */

static long int history_stack[STACK_SIZE];	/* history stack */
static struct nl_item {
    long int precur,postcur;
    ARG_DESCR *var;
    } namelist[STACK_SIZE];			/* name list stack */
static long int alpha_stack[STACK_SIZE];	/* alpha stack */

/* stack pointers */
static long int STACKPTR = -1L,
		NAMESP = -1L,
		ALPHASP = -1L,
		STACKBOT = -1L;

/* other "static" (free/bound vars) */

static STRING_DESCR *SUBJECT;	/* the current subject */
static long int LENGTH,		/* length */
		CURSOR,		/* current position */
		FUTILITY;	/* futility flag */
static PATTERN_NODE *NODE;	/* current node */

/* external functions */
extern char *calloc();

/*
 * stack functions
 */

/* push an item onto the history (main) stack */
static long int push(item)
long int item;
{
    history_stack[++STACKPTR] = item;
    return(item);
    }
/* define a macro to make it easy */
#define HPUSH(X) (push((long int)(X)))
/* define a macro to the top of the stack. returns garbage if stack is 
   empty */
#define HTOP() (history_stack[STACKPTR])
/* pop an item off of the history stack */
static long int HPOP()
{
    if (STACKPTR <= STACKBOT) return(0L);
    else return(history_stack[STACKPTR--]);
    }
/* push an item onto alpha stack */
static long int apush(item)
long int item;
{
    alpha_stack[++ALPHASP] = item;
    return(item);
    }
/* define a macro to make it easy */
#define APUSH(X) (apush((long int)(X)))
/* define a macro to the top of the stack. returns garbage if stack is 
   empty */
#define ATOP() (alpha_stack[ALPHASP])
/* pop an item off of the history stack */
static long int APOP()
{
    if (ALPHASP <= -1L) return(0L);
    else return(alpha_stack[ALPHASP--]);
    }
/* push an item onto the name list  stack */
static struct nl_item *NPUSH(prec,postc,ap)
long int prec,postc;
ARG_DESCR *ap;
{
    NAMESP++;
    namelist[NAMESP].precur = prec;
    namelist[NAMESP].postcur = postc;
    namelist[NAMESP].var = ap;
    return(&namelist[NAMESP]);
    }
/* define a macro to the top of the stack. returns garbage if stack is 
   empty */
#define NTOP() (&namelist[NAMESP])
/* pop an item off of the name list stack */
static struct nl_item *NPOP()
{
    if (NAMESP <= -1L) return(0L);
    else return(&namelist[NAMESP--]);
    }
/*
 * memory funtions
 */
/* allocate a pattern node. */
PATTERN_NODE *pncons(p,s,a,ar,r)
int (*p)();		/* prog field */
PATTERN_NODE *s,*a;	/* subs and alts field */
ARG_DESCR *ar;		/* arg descr */
short int r;		/* residual */
{
    register PATTERN_NODE *new;

    /* allocate the space */
    new = (PATTERN_NODE *) calloc(sizeof(PATTERN_NODE),1);
    /* allocation failure? if so die */
    if (new == 0L) {
	perror("pncons");
	abort(0);
	}
    /* fill in fields */
    new->prog = p;
    new->subs = s;
    new->alts = a;
    new->arg = ar;
    new->resid = r;
    new->__mark = 0;
    return(new);
    }
/* allocate an arg descriptor */
ARG_DESCR *acons(type,v)
int type;		/* type code */
long int v;		/* value */
{
    register ARG_DESCR *new;

    /* allocate some memory */
    new = (ARG_DESCR *) calloc(sizeof(ARG_DESCR),1);
    /* if allocation failure, bomb out */
    if (new == 0L) {
	perror("acons");
	abort(0);
	}
    /* fill in fields */
    new->data_type = type;
    new->value.fixnum = v;
    return(new);
    }
/* define some macros to make it easier to allocate specific types */
#define icons(i) (acons(FIXNUM,(long int) (i)))
#define fcons(f) (acons(FLONUM,(float) (f)))
#define sacons(s)(acons(STRING,(STRING_DESCR *) (s)))
#define pacons(p)(acons(PATTERN,(PATTERN_NODE *)(p)))
#define fncons(fn)(acons(FUNCTION,fn))

/* allocate a string descriptor */
STRING_DESCR *scons(b,o,l)
char *b;
int o,l;
{
    register STRING_DESCR *new;

    /* allocate some memory */
    new = (STRING_DESCR *) calloc(sizeof(STRING_DESCR),1);
    /* check for allocation failure */
    if (new == 0L) {
	perror("scons");
	abort(0);
	}
    /* fill is fields */
    new->base = b;
    new->offset = o;
    new->length = l;
    return(new);
    }
/* build a string descr from a string (string is copied) */
STRING_DESCR *build_string(str)
char *str;
{
    register char *newstr;

    /* allocate some memory */
    newstr = calloc(strlen(str)+1,1);
    /* check for allocation failure */
    if (newstr == 0L) {
	perror("build_string");
	abort(0);
	}
    /* copy string */
    strcpy(newstr,str);
    /* return a string descr */
    return(scons(newstr,0,strlen(newstr)));
    }
/* alternation pattern builder function */
PATTERN_NODE *alt(p1,p2)
PATTERN_NODE *p1,*p2;
{
    PATTERN_NODE *copy_pat();

    p1 = copy_pat(p1);	/* copy pattern p1 */
    alt1(p1,p2);	/* alternate copy with p2 */
    return(p1);
    }
/* helper function */
static alt1(p1,p2)
register PATTERN_NODE *p1,*p2;
{
    register PATTERN_NODE *p;

    clear_marks(p1);
    for (p=p1; (p != 0L) && (p->alts != 0L) && (p->__mark <= 0); p = p->alts)
	p->__mark == 1;
    if (p != 0L && p->alts == 0L) p->alts = p2;
    }
/* pattern concatenation */
PATTERN_NODE *concat(p1,p2)
PATTERN_NODE *p1,*p2;
{
    PATTERN_NODE *copy_pat();

    p1 = copy_pat(p1);
    update_resid(p1,p2->resid);
    concat1(p1,p2);
    return(p1);
    }
#define FLD(p,i)(((i) == 1)?(p)->subs:(p)->alts)
#define SFLD(p,i,nv) if ((i) == 1) p->subs = nv; else p->alts = nv
/* helper routine */
static int concat1(son,nephew)
register PATTERN_NODE *son,*nephew;
{
    register PATTERN_NODE *father,*gs,*gf;
    register int i;

    if (son == 0L) return;
    father = 0L;
    clear_marks(son);
    nephew->__mark = 1;
cc1_2:
    son->__mark = 1;
    if (son->subs == 0L) son->subs = nephew;
    i = 0;
cc1_1:
    i++;
    if (i>2) goto cc1_3;
    if (son == 0L) goto cc1_3;
    gs = FLD(son,i);
    if (gs == 0L) goto cc1_1;
    if (gs->__mark > 0) goto cc1_1;
    son->__mark = i;
    SFLD(son,i,father);
    father = son;
    son = gs;
    goto cc1_2;
cc1_3:
    if (father == 0L) return;
    i = father->__mark;
    gf = FLD(father,i);
    SFLD(father,i,son);
    son = father;
    father = gf;
    goto cc1_1;
    }
/* helper routine - smart deep copy */
static PATTERN_NODE *copy_pat(son)
register PATTERN_NODE *son;
{
    register PATTERN_NODE *father,*gs,*gf;
    PATTERN_NODE *pncons();
    register int i;

    if (son == 0L) return(son);
    father = 0L;
    clear_marks(son);
copy_2:
    son->__new = pncons(son->prog,son->subs,son->alts,son->arg,son->resid);
    son->__mark = 1;
    son = son->__new;
    i = 0;
copy_1:
    i++;
    if (i>2) goto copy_3;
    if (son == 0L) goto copy_3;
    gs = FLD(son,i);
    if (gs == 0L) goto copy_1;
    if (gs->__mark > 0) {
	SFLD(son,i,gs->__new);
	goto copy_1;
	}
    son->__mark = i;
    SFLD(son,i,father);
    father = son;
    son = gs;
    goto copy_2;
copy_3:
    if (father == 0L) return(son);
    i = father->__mark;
    gf = FLD(father,i);
    SFLD(father,i,son);
    son = father; father = gf;
    goto copy_1;
    }
/* helper function - clear marks */
static int clear_marks(son)
register PATTERN_NODE *son;
{
    register PATTERN_NODE *father,*gs,*gf;
    register int i;

    if (son == 0L) return;
    father = 0L;
clear_2:
    son->__mark = -1;
    i = 0;
clear_1:
    i++;
    if (i>2) goto clear_3;
    if (son == 0L) goto clear_3;
    gs = FLD(son,i);
    if (gs == 0L) goto clear_1;
    if (gs->__mark < 0) goto clear_1;
    son->__mark = -i;
    SFLD(son,i,father);
    father = son;
    son = gs;
    goto clear_2;
clear_3:
    if (father == 0L) return;
    i = -(father->__mark);
    gf = FLD(father,i);
    SFLD(father,i,son);
    son=father;
    father=gf;
    goto clear_1;
    }
/* helper routine - update resid */
static update_resid(son,resupd)
register PATTERN_NODE *son;
register int resupd;
{
    register PATTERN_NODE *father,*gs,*gf;
    register int i;

    if (son == 0L) return;
    father = 0L;
    clear_marks(son);
upd_2:
    son->__mark = 1;
    son->resid += resupd;
    i = 0;
upd_1:
    i++;
    if (i>2) goto upd_3;
    if (son == 0L) goto upd_3;
    gs = FLD(son,i);
    if (gs == 0L) goto upd_1;
    if (gs->__mark > 0) goto upd_1;
    son->__mark = i;
    SFLD(son,i,father);
    father = son;
    son = gs;
    goto upd_2;
upd_3:
    if (father == 0L) return;
    i = father->__mark;
    gf = FLD(father,i);
    SFLD(father,i,son);
    son = father;
    father = gf;
    goto upd_1;
    }
/*
 * pattern constructor primitives
 */
/* breakk(str) - break primitive */
PATTERN_NODE *breakk(str)
register STRING_DESCR *str;
{
    register ARG_DESCR *argl;
    PATTERN_NODE *pncons();
    ARG_DESCR *acons();
    int m_break();

    argl = sacons(str);
    return(pncons(m_break,0L,0L,argl,0));
    }
/* breakk_c(s) - simular, but s is simply a char ptr */
PATTERN_NODE *breakk_c(s)
register char *s;
{
    STRING_DESCR *build_string();
    PATTERN_NODE *breakk();

    return(breakk(build_string(s)));
    }
/* span(str) - span primitive */
PATTERN_NODE *span(str)
register STRING_DESCR *str;
{
    register ARG_DESCR *argl;
    PATTERN_NODE *pncons();
    ARG_DESCR *acons();
    int m_span();

    argl = sacons(str);
    return(pncons(m_span,0L,0L,argl,1));
    }
/* span_c(s) - simular, but s is simply a char ptr */
PATTERN_NODE *span_c(s)
register char *s;
{
    STRING_DESCR *build_string();
    PATTERN_NODE *span();

    return(span(build_string(s)));
    }
/* any(str) - any primitive */
PATTERN_NODE *any(str)
register STRING_DESCR *str;
{
    register ARG_DESCR *argl;
    PATTERN_NODE *pncons();
    ARG_DESCR *acons();
    int m_any();

    argl = sacons(str);
    return(pncons(m_any,0L,0L,argl,1));
    }
/* any_c(s) - simular, but s is simply a char ptr */
PATTERN_NODE *any_c(s)
register char *s;
{
    STRING_DESCR *build_string();
    PATTERN_NODE *any();

    return(any(build_string(s)));
    }
/* notany(str) - notany primitive */
PATTERN_NODE *notany(str)
register STRING_DESCR *str;
{
    register ARG_DESCR *argl;
    PATTERN_NODE *pncons();
    ARG_DESCR *acons();
    int m_notany();

    argl = sacons(str);
    return(pncons(m_notany,0L,0L,argl,1));
    }
/* notany_c(s) - simular, but s is simply a char ptr */
PATTERN_NODE *notany_c(s)
register char *s;
{
    STRING_DESCR *build_string();
    PATTERN_NODE *notany();

    return(notany(build_string(s)));
    }
/* lit_string(str) - literal string primitive */
PATTERN_NODE *lit_string(str)
register STRING_DESCR *str;
{
    register ARG_DESCR *argl;
    PATTERN_NODE *pncons();
    ARG_DESCR *acons();
    int m_string();

    argl = sacons(str);
    return(pncons(m_string,0L,0L,argl,str->length));
    }
/* c_lit_string(s) - simular, but s is simply a char ptr */
PATTERN_NODE *c_lit_string(s)
register char *s;
{
    STRING_DESCR *build_string();
    PATTERN_NODE *lit_string();

    return(lit_string(build_string(s)));
    }
/* len(l) - len primitive */
PATTERN_NODE *len(l)
register int l;
{
    register ARG_DESCR *argl;
    PATTERN_NODE *pncons();
    ARG_DESCR *acons();
    int m_len();

    argl = icons(l);
    return(pncons(m_len,0L,0L,argl,l));
    }
/* pos(l) - pos primitive */
PATTERN_NODE *pos(l)
register int l;
{
    register ARG_DESCR *argl;
    PATTERN_NODE *pncons();
    ARG_DESCR *acons();
    int m_pos();

    argl = icons(l);
    return(pncons(m_pos,0L,0L,argl,0));
    }
/* rpos(l) - rpos primitive */
PATTERN_NODE *rpos(l)
register int l;
{
    register ARG_DESCR *argl;
    PATTERN_NODE *pncons();
    ARG_DESCR *acons();
    int m_rpos();

    argl = icons(l);
    return(pncons(m_rpos,0L,0L,argl,0));
    }
/* tab(l) - tab primitive */
PATTERN_NODE *tab(l)
register int l;
{
    register ARG_DESCR *argl;
    PATTERN_NODE *pncons();
    ARG_DESCR *acons();
    int m_tab();

    argl = icons(l);
    return(pncons(m_tab,0L,0L,argl,0));
    }
/* rtab(l) - rtab primitive */
PATTERN_NODE *rtab(l)
register int l;
{
    register ARG_DESCR *argl;
    PATTERN_NODE *pncons();
    ARG_DESCR *acons();
    int m_rtab();

    argl = icons(l);
    return(pncons(m_rtab,0L,0L,argl,0));
    }
/*
 * primitive variant compounds
 */
/* arbno(p) - compound to match an arbitary number (incl. 0) of what
 * pattern p matches */
PATTERN_NODE *arbno(p)
register PATTERN_NODE *p;
{
    register PATTERN_NODE *temp;
    PATTERN_NODE *pncons(),*concat(),*alt();
    int m_nil();

    temp = pncons(m_nil,0L,0L,0L,0);
    p = concat(p,temp);
    temp->alts = p;
    return(pncons(m_nil,temp,0L,0L,0));
    }
/* star(funct) - "unevaluated expr", implemented in C as a function call */
PATTERN_NODE *star(funct)
register long int (*funct)();
{
    register ARG_DESCR *argl;
    ARG_DESCR *acons();
    register PATTERN_NODE *s1,*s2,*s3;
    PATTERN_NODE *pncons();
    int m_star(),m_restar(),m_nil();

    argl = fncons(funct);
    s1 = pncons(m_star,0L,0L,argl,0);
    s2 = pncons(m_nil,0L,0L,0L,0);
    s3 = pncons(m_restar,0L,0L,0L,0);
    s1->subs = s2;
    s3->subs = s2;
    s2->alts = s3;
    return(s1);
    }
/* cassign(p,v) - conditionall assign string match by pattern p to "var" v */
PATTERN_NODE *cassign(p,v)
register PATTERN_NODE *p;
register ARG_DESCR *v;
{
    PATTERN_NODE *pncons(),*concat();
    register PATTERN_NODE *v1,*v2,*vb1,*vb2;
    int m_va1(),m_va2(),m_vab1(),m_vab2();

    vb2 = pncons(m_vab2,0L,0L,0L,0);
    v2 = pncons(m_va2,0L,vb2,v,0);
    v2 = concat(p,v2);
    vb1 = pncons(m_vab1,0L,0L,0L,0);
    v1 = pncons(m_va1,v2,vb1,0L,v2->resid);
    return(v1);
    }
/* assign(p,v) - unconditionall assign string match by pattern p to "var" v */
PATTERN_NODE *assign(p,v)
register PATTERN_NODE *p;
register ARG_DESCR *v;
{
    PATTERN_NODE *pncons(),*concat();
    register PATTERN_NODE *v1,*v2,*vb1;
    int m_va1(),m_iva2(),m_vab1();

    v2 = pncons(m_iva2,0L,0L,v,0);
    v2 = concat(p,v2);
    vb1 = pncons(m_vab1,0L,0L,0L,0);
    v1 = pncons(m_va1,v2,vb1,0L,v2->resid);
    return(v1);
    }
/*
 * pattern match functions
 */

/* pattern match status codes */
#define SCAN_SUCCESS	0	/* success */
#define SCAN_L_FAIL	1	/* length failure */
#define SCAN_M_FAIL	2	/* match failure */
#define SCAN_ABORT	3	/* forced abort */

/* user entry point: match subj against pat. fill match with info about 
 * sub-string matched */
int pmatch(subj,pat,matched)
register char *subj;
register PATTERN_NODE *pat;
register STRING_DESCR *matched;
{
    register int status;
    register long int precursor;
    long int sspb,ssp,sab,snb,scur,sfut;
    STRING_DESCR subject;
    STRING_DESCR *ssubj;

    sspb = STACKBOT;
    ssp = STACKPTR;
    sab = ALPHASP;
    snb = NAMESP;
    sfut = FUTILITY;
    scur = CURSOR;
    ssubj = SUBJECT;
    STACKBOT = STACKPTR;
    SUBJECT = &subject;
    subject.base = subj;
    subject.offset = 0;
    subject.length = strlen(subj);

    status = SCAN_L_FAIL;
    for (precursor = 0; precursor<subject.length; precursor++) {
	CURSOR = precursor;
	STACKPTR = STACKBOT;
	ALPHASP = sab;
	NAMESP = snb;
	FUTILITY = TRUE;
	HPUSH(0);
	HPUSH(precursor);
	status = scan(subject.length,pat);
	if (status == SCAN_SUCCESS || status == SCAN_ABORT || FUTILITY) break;
	}
    if (status == SCAN_SUCCESS) {
	matched->base = subj;
	matched->offset = precursor;
	matched->length = CURSOR-precursor;
	do_assign(snb,subj);
	}
    STACKBOT = sspb;
    STACKPTR = ssp;
    ALPHASP = sab;
    NAMESP = snb;
    FUTILITY = sfut;
    CURSOR = scur;
    SUBJECT = ssubj;
    return((status == SCAN_SUCCESS)?MATCH_SUCCESS:MATCH_FAIL);
    }
/* helper function - scan: this is where all the work is done */
static int scan(l,node)
register int l;
register PATTERN_NODE *node;
{
    PATTERN_NODE *snode;
    long int slen;
    register int status;
    long int HPOP();
/*    int pattern_init();
    register long int pbase,fun;*/

/*    pbase = (long int) pattern_init;*/
    snode = NODE;
    NODE = node;
    slen = LENGTH;
    LENGTH = l;
    status = SCAN_SUCCESS;

    while(NODE != 0L) {
/*	fun = (long int) NODE->prog;
	fun -= pbase;
	printf("*** In scan(): NODE = %08lx\n->prog = %08lx\n->subs = %08lx\n",
	       NODE,fun,NODE->subs);
	printf("->alts = %08lx\n->arg = %08lx\n->resid = %d\n->__mark = %d\n",
	       NODE->alts,NODE->arg,NODE->resid,NODE->__mark);
	printf("->__new = %08ld\n",NODE->__new);
	printf("CURSOR = %ld, LENGTH = %ld, FUTILITY = %ld\nSTACKPTR = %ld\n",
	       CURSOR,LENGTH,FUTILITY,STACKPTR);*/
/*	if (NODE->arg != 0L) {
	    switch (NODE->arg->data_type) {
	    case FIXNUM: 
		printf("arg is FIXNUM: %ld\n",NODE->arg->value.fixnum);
		break;
	    case FLONUM:
		printf("arg is FLONUM: %10.5f\n",NODE->arg->value.flonum);
		break;
	    case STRING:
		printf("arg is STRING: '");
		{ int i,l; char *c;
		    l = NODE->arg->value.string->length;
		    c = NODE->arg->value.string->base+
			NODE->arg->value.string->offset;
		    for (i=0;i<l;i++) printf("%c",*c++);
		    }
		printf("'\n");
		break;
	    case FUNCTION:
		printf("arg is FUNCTION: %08lx\n",NODE->arg->value.function);
		break;
	    case PATTERN:
		printf("arg is PATTERN: %08lx\n",NODE->arg->value.pattern);
		break;
	    case UNDEFINED:
		printf("arg is UNDEFINED\n");
		break;
		}
	    }*/
	if (NODE->alts != 0L) {
	    HPUSH(NODE->alts);
	    HPUSH(CURSOR);
	    }
	status = (*(NODE->prog))(NODE->arg);
/*	printf("status is %d\n",status);*/
	switch (status) {
	case SCAN_SUCCESS:
	    NODE = NODE->subs;
	    break;
	case SCAN_M_FAIL: FUTILITY = FALSE;
	case SCAN_L_FAIL:
	    CURSOR = HPOP();
	    NODE = (PATTERN_DESCR *) HPOP();
	    break;
	case SCAN_ABORT: goto scan_exit;
	    }
	}
scan_exit:
    NODE = snode;
    LENGTH = slen;
    return(status);
    }
/*
 * primitives
 */
/* break primitive */
static int m_break(a)
register ARG_DESCR *a;
{
    register STRING_DESCR *s;

    s = a->value.string;
    for (;CURSOR<LENGTH;CURSOR++)
	if (memchar(*(SUBJECT->base+SUBJECT->offset+CURSOR),s))
	    return(SCAN_SUCCESS);
    return(SCAN_L_FAIL);
    }
/* span primitive */
static int m_span(a)
register ARG_DESCR *a;
{
    register STRING_DESCR *s;
    register long int sc;

    s = a->value.string;
    sc = CURSOR;
    if (CURSOR == LENGTH) return(SCAN_L_FAIL);
    for (;CURSOR<LENGTH;CURSOR++)
	if (!memchar(*(SUBJECT->base+SUBJECT->offset+CURSOR),s)) break;
    if (CURSOR == sc) return(SCAN_M_FAIL);
    else return(SCAN_SUCCESS);
    }
/* any primitive */
static int m_any(a)
register ARG_DESCR *a;
{
    register STRING_DESCR *s;

    s = a->value.string;
    if (CURSOR == LENGTH) return(SCAN_L_FAIL);
    else if (memchar(*(SUBJECT->base+SUBJECT->offset+CURSOR),s)) {
	CURSOR++;
	return(SCAN_SUCCESS);
	}
    else return(SCAN_M_FAIL);
    }
/* notany primitive */
static int m_notany(a)
register ARG_DESCR *a;
{
    register STRING_DESCR *s;

    s = a->value.string;
    if (CURSOR == LENGTH) return(SCAN_L_FAIL);
    else if (!memchar(*(SUBJECT->base+SUBJECT->offset+CURSOR),s)) {
	CURSOR++;
	return(SCAN_SUCCESS);
	}
    else return(SCAN_M_FAIL);
    }
/* nil primitive */
static int m_nil(a)
long int a;
{
    return(SCAN_SUCCESS);
    }
/* success primitive */
static int m_success(a)
long int a;
{
    return(SCAN_SUCCESS);
    }
/* fail primitive */
static int m_fail(a)
long int a;
{
    return(SCAN_M_FAIL);
    }
/* abort primitive */
static int m_abort(a)
long int a;
{
    return(SCAN_ABORT);
    }
/* fence primitive */
static int m_fence(a)
long int a;
{
    static PATTERN_NODE abt;
    static int init = FALSE;
    int m_abort();

    if (!init) {
	abt.prog = m_abort;
	abt.alts = abt.subs = abt.arg = 0L;
	abt.resid = 0;
	}
    HPUSH(&abt);
    HPUSH(CURSOR);
    return(SCAN_SUCCESS);
    }
/* pos primitive */
static int m_pos(a)
register ARG_DESCR *a;
{
    register long int p;

    p = a->value.fixnum;
    if (p < 0 || p>LENGTH) {
	FUTILITY = TRUE;
	return(SCAN_L_FAIL);
	}
    else if (p==CURSOR) return(SCAN_SUCCESS);
    else if (p<CURSOR) return(SCAN_M_FAIL);
    else {
	FUTILITY = TRUE;
	return(SCAN_L_FAIL);
	}
    }
/* rpos primitive */
static int m_rpos(a)
register ARG_DESCR *a;
{
    ARG_DESCR a1;

    a1.data_type = FIXNUM;
    a1.value.fixnum = LENGTH-a->value.fixnum;
    if (a1.value.fixnum < 0) {
	FUTILITY = TRUE;
	return(SCAN_L_FAIL);
	}
    return(m_pos(&a1));
    }
/* rem primitive */
static int m_rem(a)
long int a;
{
    CURSOR = LENGTH;
    return(SCAN_SUCCESS);
    }
/* literal string primitive */
static int m_string(a)
register ARG_DESCR *a;
{
    register STRING_DESCR *s;
    register long int l;
    register char *sc;

    s = a->value.string;
    if ((s->length+CURSOR)>LENGTH) return(SCAN_L_FAIL);
    for (l=s->length,sc=s->base+s->offset;
	 l > 0 && *sc == *(SUBJECT->base+SUBJECT->offset+CURSOR);
	 sc++,l--,CURSOR++) ;
    if (l != 0) return(SCAN_M_FAIL);
    else return(SCAN_SUCCESS);
    }
/* len primitive */
static int m_len(a)
register ARG_DESCR *a;
{
    register long int l;

    l = a->value.fixnum;
    if (CURSOR+l > LENGTH) return(SCAN_L_FAIL);
    else {
	CURSOR += l;
	return(SCAN_SUCCESS);
	}
    }
/* tab primitive */
static int m_tab(a)
register ARG_DESCR *a;
{
    register long int p;

    p = a->value.fixnum;
    if (p < 0 || p>LENGTH) {
	FUTILITY = TRUE;
	return(SCAN_L_FAIL);
	}
    else if (p<=CURSOR) {
	CURSOR = p;
	return(SCAN_SUCCESS);
	}
    else {
	FUTILITY = TRUE;
	return(SCAN_L_FAIL);
	}
    }
/* rtab primitive */
static int m_rtab(a)
register ARG_DESCR *a;
{
    ARG_DESCR a1;

    a1.data_type = FIXNUM;
    a1.value.fixnum = LENGTH-a->value.fixnum;
    if (a1.value.fixnum < 0) {
	FUTILITY = TRUE;
	return(SCAN_L_FAIL);
	}
    return(m_tab(&a1));
    }
/* arb1 primitive (part of ARB) */
static int m_arb1(a)
long int a;
{
   HPUSH(FUTILITY);
   FUTILITY = TRUE;
   return(SCAN_SUCCESS);
   }
/* arb2 primitive (part of ARB) */
static int m_arb2(a)
long int a;
{
    if (FUTILITY) {
	FUTILITY = HPOP();
	return(SCAN_L_FAIL);
	}
    else if ((CURSOR++) <= LENGTH) {
	HPOP();
	return(SCAN_M_FAIL);
	}
    else {
	HPUSH(NODE);
	HPUSH(CURSOR);
	return(SCAN_SUCCESS);
	}
    }
/* gbal primitive (part of BAL) */
static int m_gbal(a)
long int a;
{
    register int paren_count;

    if (CURSOR == LENGTH) return(SCAN_L_FAIL);
    if (*(SUBJECT->base+SUBJECT->offset+CURSOR) == '(') paren_count = 1;
    else if  (*(SUBJECT->base+SUBJECT->offset+CURSOR) == ')') 
	return(SCAN_M_FAIL);
    else paren_count = 0;
    CURSOR++;
    while (CURSOR <= LENGTH && paren_count != 0) {
	if (*(SUBJECT->base+SUBJECT->offset+CURSOR) == '(') paren_count++;
	else if  (*(SUBJECT->base+SUBJECT->offset+CURSOR) == ')') 
	    paren_count--;
	CURSOR++;
	}
    if (paren_count == 0) return(SCAN_SUCCESS);
    else return(SCAN_M_FAIL);
    }
/* star primitive (part of star()) */
static int m_star(a)
ARG_DESCR *a;
{
    register ARG_DESCR *p;
    PATTERN_NODE *lit_string();
    static char tempst[20];
    register int reduction,stat,allflg;
    register *pp;
    
    p = a;
    while (p != 0L && p->data_type == FUNCTION) 
	p = (ARG_DESCR *) (*(p->value.function))(p);
    if (p == 0L) return(SCAN_M_FAIL);
    if (p->data_type == PATTERN) {
	allflg = 0;
	pp = p->value.pattern;
	}
    else if (p->data_type == STRING) {
	allflg = 1;
	pp = lit_string(p);
	}
    else {
	allflg = 2;
	if (p->data_type == FIXNUM) sprintf(tempst,"%ld",p->value.fixnum);
	else sprintf(tempst,"%f20.10",p->value.flonum);
	pp = c_lit_string(tempst);
	}
    HPUSH(0L); HPUSH(CURSOR);
    reduction = NODE->resid;
    if ((reduction+CURSOR) > LENGTH) {
	if (allflg == 1) free(pp);
	else if (allflg == 2) {
	    free(pp->arg->value.string->base);
	    free(pp->arg->value.string);
	    free(pp->arg);
	    free(pp);
	    }
	return(SCAN_L_FAIL);
	}
    stat = scan((short int) (LENGTH - reduction),pp);
    if (allflg == 1) free(pp);
    else if (allflg == 2) {
	free(pp->arg->value.string);
	free(pp);
	}
    if (stat == SCAN_SUCCESS) return(SCAN_SUCCESS);
    else return(SCAN_M_FAIL);
    }
/* restar primitive (part of star()) */
static int m_restar(a)
long int a;
{
    register PATTERN_NODE *pp;
    register int reduction,stat;

    CURSOR = HPOP();
    pp = HPOP();
    if (pp == 0L) {
	return(SCAN_M_FAIL);
	}
    else {
	reduction = NODE->resid;
	if ((reduction+CURSOR) > LENGTH) return(SCAN_L_FAIL);
	stat = scan((short int) (LENGTH - reduction),pp);
	if (stat == SCAN_SUCCESS) return(SCAN_SUCCESS);
	else return(SCAN_M_FAIL);
	}
    }
/* va1 primitive - part of cassign and assign */
static int m_va1(a)
long int a;
{
    APUSH(CURSOR);
/*    printf("*** In m_va1(): CURSOR (%ld) pushed, ALPHASP=%ld\n",CURSOR,ALPHASP);*/
    return(SCAN_SUCCESS);
    }
/* vab1 primitive - part of cassign and assign */
static int m_vab1(a)
long int a;
{
    APOP();
/*    printf("*** In m_vab1(): Alpha Stack popped, ALPHASP=%ld\n",ALPHASP);*/
    return(SCAN_M_FAIL);
    }
/* va2 primitive - part of cassign */
static int m_va2(a)
register ARG_DESCR *a;
{
    register long int precurs;
    long int APOP();

    precurs = APOP();
    NPUSH(precurs,CURSOR,a);
/*    printf("*** In m_va2(): Alpha stack popped, precurs=%ld & CURSOR=%ld\n",
	   precurs,CURSOR);
    printf("                Name stack pushed.  ALPHASP=%ld, NAMESP=%ld\n",
	   ALPHASP,NAMESP);*/
    return(SCAN_SUCCESS);
    }
/* vab2 - part of cassign */
static int m_vab2(a)
long int a;
{
    register struct nl_item *nl;
    struct nl_item *NPOP();

    nl = NPOP();
    APUSH(nl->precur);
/*    printf("*** In m_vab2(): Name stack popped (precur = %ld). NAMESP=%ld,ALPHASP = %ld\n",
    	nl->precur,NAMESP,ALPHASP);*/
    return(SCAN_M_FAIL);
    }
/* iva2 primitive - part of assign */
static int m_iva2(a)
register ARG_DESCR *a;
{
    register long int prec;
    long int APOP();

    prec = APOP();
/*    printf("*** In m_iva2(): Alpha stack popped, prec=%ld, ALPHASP=%ld\n",
	prec,ALPHASP);*/
    while (a != 0L && a->data_type == FUNCTION) 
	a = (ARG_DESCR *) (*(a->value.function))(a);
/*    printf("                 (after eval) a = %08lx,a->data_type=%d\n",a,
	(a==0L)?UNDEFINED:a->data_type);*/
    if (a == 0L) {
	APUSH(prec);
/*	printf("                 (a == 0L). Alpha stack pushed.\n");*/
	return(SCAN_M_FAIL);
	}
    if (a->data_type == STRING) {
/*	printf("                 a->value.string = %08lx\n",a->value.string);*/
	a->value.string->base = SUBJECT->base;
	a->value.string->offset = SUBJECT->offset+prec;
	a->value.string->length = CURSOR - prec;
	}
    return(SCAN_SUCCESS);
    }
/*****************/
/*
 * general helper functions
 */
/* memchar - return TRUE if c is in s */
static int memchar(c,s)
register char c;
register STRING_DESCR *s;
{
    register char *ss;
    register int i,l;

    ss = s->base + s->offset;
    l = s->length;
    for (i=0;i<l;i++)
	if (c == *ss++) return(TRUE);
    return(FALSE);
    }
/* do_assign - process assignments */
do_assign(snb,subjbase)
register long int snb;
register char *subjbase;
{
    register struct nl_item *nl;
    register ARG_DESCR *v;
    register STRING_DESCR *s;
    struct nl_item *NPOP();
    static STRING_DESCR nullstr = {"",0,0};
    static ARG_DESCR anull = {STRING,&nullstr};

    while (NAMESP > snb) {
	nl = NPOP();
	v = nl->var;
	while (v != 0L &&
	       v->data_type == FUNCTION) 
	    v = (ARG_DESCR *) (*(v->value.function))(&anull);
	if (v != 0L && v->data_type == STRING) {
	    s = v->value.string;
	    s->base = subjbase;
	    s->offset = nl->precur;
	    s->length = nl->postcur - nl->precur;
	    }
	}
    }
/********************/
/* debug functions */
ARG_DESCR *DBG_p_stat()
{
    register char *p;
    register long int i;
    static ARG_DESCR null /* = {PATTERN,&_success} */;
    static int init = FALSE;
    
    if (!init) {
	null.data_type = PATTERN;
	null.value.pattern = &_success;
	init = TRUE;
	}
    printf("*** In DBG_p_stat: CURSOR = %ld, LENGTH = %ld, FUTILITY = %ld\n",
	   CURSOR,LENGTH,FUTILITY);
    printf("*** SUBJECT = |");
    p = SUBJECT->base+SUBJECT->offset;
    for (i=0;i<CURSOR;i++) {
	printf("%c",*p);
	p++;
	}
    printf("\n               ");
    for (i=0;i<CURSOR;i++) printf("%c",' ');
    for (i=CURSOR;i<LENGTH;i++) {
	printf("%c",*p);
	p++;
	}
    printf("|\n");
    return(&null);
    }