seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-23 08:24:18 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity
Files
31738079c43b1cd3eae2815a0dfb36f71505257a
Digital-Research-Source-Code/CPM OPERATING SYSTEMS/CPM 68K/cpm68k_pgms/snobol4/PATTERN.C
Sepp J Morris 31738079c4 Upload 
Digital Research
2020-11-06 18:50:37 +01:00

1 line
31 KiB
C
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

/* -*-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);
}

Reference in New Issue View Git Blame Copy Permalink