home *** CD-ROM | disk | FTP | other *** search
- /* action.c -- "action" routines for interpretor. These are the base-level
- * routines, pointed to by the code-list.
- */
-
- #include "bsdefs.h"
-
- int status = 0;
-
- /* M_COMPILE:
- * x print x --to-- x,_print,x
- * M_EXECUTE:
- * stack: string,x --to-- x
- * output: "string\n"
- */
- _print(l,p)
- int (*l[])(),p;
- {
- union value s1;
- if((status&XMODE) == M_EXECUTE) {
- s1 = pop();
- printf("%s",s1.sval);
- if(s1.sval != 0) free(s1.sval);
- }
- return(p);
- }
-
- /* M_COMPILE:
- * x rlabel name goto x --to-- x,rlabel,lval,_goto,0,x
- * (the 0 is for the benefit of interp())
- * M_FIXUP: nothing.
- * any other mode:
- * stack: lval,x --to-- x
- * other: Thisline = lval.lval.codelist;
- * Thisp = lval.lval.place;
- */
- _goto(l,p) int (*l[])(),p;
- {
- union value lval;
-
- if((status&XMODE) == M_FIXUP) return(++p);
- if((status&XMODE) == M_EXECUTE) {
- lval = pop();
- if(lval.lval.codelist == 0) ULerror(l,p);
- Thisline = lval.lval.codelist;
- Thisline--;
- Thisp = lval.lval.place;
- if(dbg) printf("_goto:EXEC:to:llent:%o:pl:%d:num:%u\n",lval.lval.codelist,
- lval.lval.place,lval.lval.codelist->num);
- return(p);
- }
- return(p);
- }
-
- /* M_COMPILE:
- * x dlabel name x --to-- x,_dlabel,&vlist entry,x
- * M_FIXUP:
- * Make vlist entry for "name" point to current place.
- */
- _dlabel(l,p) int (*l[])(),p;
- {
- struct dictnode *vp;
-
- if((status&XMODE) == M_FIXUP) {
- vp=l[p++];
- vp->val.lval.codelist = (int **)gllentry(l);
- vp->val.lval.place = p;
- return(p);
- }
- p++; return(p); /* skip over the vp in any other mode */
- }
-
- /* M_COMPILE:
- * x rlabel name x --to-- x,rlabel,&vlist entry,x
- * any other mode:
- * push(vp->val) (i.e. pointer to location of label)
- */
- _rlabel(l,p) int (*l[])(),p;
- {
- struct dictnode *vp;
-
- if((status&XMODE) == M_FIXUP) return(++p);
- if((status&XMODE) == M_EXECUTE) {
- vp = l[p++];
- if(dbg) printf("_rlabel:M_EXECUTE:name:%s:llent:%o:place:%d\n",vp->name,
- vp->val.lval.codelist,vp->val.lval.place);
- push(vp->val);
- }
- return(p);
- }
-
- /* M_COMPILE:
- * x rlabel name gosub x --to-- x,_rlabel,lval,_gosub,0,x
- *
- * M_EXECUTE:
- * stack: lval,x --to-- x
- * other: saves current place (on stack) and jumps to lval.
- */
- _gosub(l,p) int(*l[])(),p;
- {
- union value here,there;
- if((status&XMODE) == M_FIXUP) return(++p);
- if((status&XMODE) == M_EXECUTE) {
- there = pop();
- here.lval.codelist = gllentry(l);
- here.lval.place = p+1;
- if(dbg) printf("_gosub:EXEC:here.l:%o:here.pl:%d:there.l:%o:there.pl:%d\n",
- here.lval.codelist,here.lval.place,there.lval.codelist,there.lval.place);
- push(here);
- Thisline = there.lval.codelist;
- Thisline--;
- Thisp = there.lval.place;
- }
- return(p);
- }
-
- _return(l,p) int(*l[])(),p;
- {
- union value loc;
- if((status&XMODE) == M_FIXUP) return(++p);
- if((status&XMODE) == M_EXECUTE) {
- loc = pop();
- Thisp = loc.lval.place;
- Thisline = loc.lval.codelist;
- Thisline--;
- }
- return(p);
- }
-
- /* Routines control entering and leaving of loops.
- *
- * enter -- makes a mark that we have entered a loop, and also records
- * branch points for "continue" and "leave".
- * exitlp -- undoes the mark made by enter.
- * contin -- branches to "continue" point.
- * leave -- branches to "leave" point.
- *
- * The following stack structure is used to record these loop markers.
- */
-
- struct loopstack {
- struct label contlb,leavlb;
- };
-
- struct loopstack lpstk[20];
- int lpstkp = -1; /* -1 when stack is empty.
- * always points to CURRENT loop marker.
- */
-
- /* M_COMPILE:
- * x rlabel contlb rlabel leavlb enter x
- *--to--
- * x,_rlabel,contlb,_rlabel,_leavlb,_enter,x
- *
- * M_EXECUTE:
- * loopstack: x --to-- <contlb,leavlb>,x
- */
- _enter(l,p) int (*l[])(),p;
- {
- union value loc;
-
- if((status&XMODE) == M_EXECUTE) {
- lpstkp++;
- loc = pop();
- if(dbg) printf("_enter:EXEC:lpsp:%d:leav.list:%o:leav.pl:%d",lpstkp,
- loc.lval.codelist,loc.lval.place);
- lpstk[lpstkp].leavlb.codelist = loc.lval.codelist;
- lpstk[lpstkp].leavlb.place = loc.lval.place;
- loc = pop();
- if(dbg) printf(":cont.list:%o:cont.pl:%d\n",loc.lval.codelist,loc.lval.place);
- lpstk[lpstkp].contlb.codelist = loc.lval.codelist;
- lpstk[lpstkp].contlb.place = loc.lval.place;
- }
- return(p);
- }
-
- /* M_EXECUTE:
- * loopstack: <contlb,leavlb>,x --to-- x
- * other: ensures that lpstkp doesnt get less that -1;
- */
- _exitlp(l,p) int (*l[])(),p;
- {
- if((status&XMODE) == M_EXECUTE)
- if(lpstkp >= 0)
- lpstkp--;
- else
- lpstkp = -1;
- if(dbg) printf("_exitlp:M_%d:lpstkp:%d\n",status,lpstkp);
- return(p);
- }
-
- /* M_COMPILE:
- * x leave x --to-- x,_leave,0,x
- * (the 0 is for the benefit of interp())
- *
- * M_EXECUTE:
- * loopstack: <contlb,leavlb>,x --to-- <contlb,leavlb>,x
- * other: branches to leavlb. exitlp takes care of cleaning up stack.
- */
- _leave(l,p) int(*l[])(),p;
- {
- if((status&XMODE) == M_FIXUP) return(++p);
- if((status&XMODE) == M_EXECUTE) {
- if(lpstkp == -1) /* not inside a loop, ergo cannot leave a loop */
- LVerror(l,p);
- Thisline = lpstk[lpstkp].leavlb.codelist;
- Thisline--;
- Thisp = lpstk[lpstkp].leavlb.place;
- }
- return(p);
- }
-
- /* M_COMPILE:
- * x contin x --to-- x,_contin,0,x
- *
- * M_EXECUTE:
- * loopstack: <contlb,leavlb>,x --to-- <contlb,leavlb>,x
- * other: jumps to contlb.
- */
- _contin(l,p) int (*l[])(),p;
- {
- if((status&XMODE) == M_FIXUP) return(++p);
- if((status&XMODE) == M_EXECUTE) {
- if(lpstkp == -1) /* cannot continue a loop we're not in */
- CNerror(l,p);
- Thisline = lpstk[lpstkp].contlb.codelist;
- Thisline--;
- Thisp = lpstk[lpstkp].contlb.place;
- }
- return(p);
- }
-
-
-
- /* M_COMPILE:
- * x rlabel name if x --to-- x,_rlabel,vp,if,0,x
- * (the 0 is for the benefit for interp()).
- * M_EXECUTE:
- * stack: loc,bool,x --to-- x
- * p: if bool, p=p else p=loc->place
- */
- _if(l,p)
- int (*l[])(),p;
- {
- union value bv,lv;
-
- if((status&XMODE) == M_FIXUP) return(++p);
- if((status&XMODE) == M_EXECUTE) {
- lv = pop();
- bv = pop();
- if(dbg) printf("_if:M_EXECUTE:lv.pl:%d:p:%d:bv.iv:%D\n",lv.lval.place,
- p,bv.ival);
- if(bv.ival == (long)0) { /* jump to else part. */
- Thisline = lv.lval.codelist;
- Thisline--;
- Thisp = lv.lval.place;
- }
- else p++; /* skip the 0 so we get to the then part */
- }
- return(p);
- }
-
- /* M_COMPILE:
- * var name <from>expr <to>expr <step>expr <flag>con 0 dlabel FORx rlabel FORx+1 for
- *--to--
- * _var,vp,<from>,<to>,<step>,<flag>,0,_dlabel,lblp,_rlabel,lblp2,_for
- *
- * M_EXECUTE:
- * stack: xitpt,vizd,step,to,from,vp,x
- * other: if exit conditions are correct, jump to exit point.
- * vizd is used to hold the data type for vp. Data types
- * are always non-zero so the test for the first visit to
- * the loop is to see if vizd is 0.
- */
- _for(l,p) int(*l[])(),p;
- {
- union value xitpt,vizd,from,to,step,place;
-
- if((status&XMODE) == M_FIXUP) return(++p);
- if((status&XMODE) == M_EXECUTE) {
- xitpt = pop(); vizd = pop();
- step = pop(); to = pop();
- from = pop();
- if(dbg) printf("_for:EXEC:xit.l:%o:xit.pl:%d:viz.iv:%D:step.iv:%D:to.iv:%D:from.iv:%D:",
- xitpt.lval.codelist,xitpt.lval.place,(long)vizd.ival,(long)step.ival,(long)to.ival,(long)from.ival);
- if(vizd.ival == 0) { /* first visit to loop */
- place = pop();
- if(dbg) printf("first time:var:%s:",place.vpval->name);
- vizd.ival = place.vpval->type_of_value&T_TMASK; /* != 0 */
- place.plval = getplace(place.vpval);
- *(place.plval) = from; /* since first time, set starting val */
- if(vizd.ival == T_INT) { /* if it is an INT, convert to/from/step to INT also */
- to.ival = (long)to.rval;
- from.ival = (long)from.rval;
- step.ival = (long)step.rval;
- }
- if(dbg) printf("var.pl:%o:var.val:%D:",place.plval,(long)place.plval->ival);
- if(vizd.ival==T_INT && step.ival==0)
- if(to.ival < from.ival)
- step.ival = -1;
- else
- step.ival = 1;
- else if(vizd.ival==T_DBL && step.rval==0)
- if(to.rval < from.rval)
- step.rval = -1;
- else
- step.rval = 1;
- }
- else place = pop();
- if(dbg) printf("var.place:%o:",place.plval);
-
- /* The stack frame is now correctly popped off.
- * Next, we check if the loop is finished.
- */
-
- if(vizd.ival == T_INT)
- if(step.ival<0 && place.plval->ival<to.ival) goto loop_done;
- else if(step.ival>0 && place.plval->ival>to.ival) goto loop_done;
- else /* vizd.ival == T_DBL */
- if(step.rval<0 && place.plval->rval<to.rval) goto loop_done;
- else if(step.rval>0 && place.plval->rval>to.rval) goto loop_done;
-
- /* Loop is not done yet, push back stack frame. */
-
- if(dbg) printf("loop not done, push everything back\n");
- push(place); push(from); push(to);
- push(step); push(vizd); push(xitpt);
- return(++p); /* skip over the 0 */
-
- /* Come here when the loop is finished. */
- loop_done:
- if(dbg) printf("loop done, jump to xitpt\n");
- Thisline = xitpt.lval.codelist;
- Thisline--;
- Thisp = xitpt.lval.place;
- return(p); /* hit the 0 */
- }
- return(p);
- }
-
- /* M_COMPILE:
- * var name next rlabel FORx goto dlabel FORx+1
- *--to--
- * _var,vp,_next,_rlabel,lblp,_goto,dlabel,lblp2
- *
- * M_EXECUTE:
- * stack: same as M_EXECUTE in _for.
- * other: adds step to (control var)->val.
- */
- _next(l,p) int(*l[])(),p;
- {
- union value vp,xitpt,vizd,step,to,from,place;
-
- if((status&XMODE) == M_EXECUTE) {
- vp = pop();
- if(dbg) printf("_next():EXEC:var:%s",vp.vpval->name);
- vp.plval = getplace(vp.vpval);
- if(dbg) printf(":vp.pl:%o:",vp.plval);
- xitpt = pop(); vizd = pop(); step = pop();
- to = pop(); from = pop(); place = pop();
- if(dbg) printf("pl.pl:%o:from.iv:%D:to.iv:%D:step.iv:%D:viz.iv:%D:",
- place.plval,(long)from.ival,(long)to.ival,(long)step.ival,(long)vizd.ival);
- if(dbg) printf("xit.list:%o:xit.pl:%d:xit.num:%u\n",xitpt.lval.codelist,
- xitpt.lval.place,xitpt.lval.codelist->num);
- if(place.plval != vp.plval) FNerror(l,p);
- if(vizd.ival == T_INT)
- place.plval->ival += step.ival;
- else
- place.plval->rval += step.rval;
- push(place); push(from); push(to);
- push(step); push(vizd); push(xitpt);
- return(p);
- }
- return(p);
- }
-
- /* variables needed for M_READ. */
-
- struct line *dlist[DLSIZ];
- int dlp = 0;
- int dlindx = 2; /* skips <_data,0> */
- int dtype; /* type of last operation. */
-
-
- /* M_COMPILE:
- * x data x --to-- x,_data,0,x (0 is for interp())
- * M_FIXUP:
- * allocates a spot in dlist, stores pointer to llist entry for
- * this line at that spot.
- * M_EXECUTE:
- * Returns, with p pointing at the zero, making interp() return.
- */
- _data(l,p) int(*l[])(),p;
- {
- if((status&XMODE) == M_FIXUP) {
- dlist[dlp++] = gllentry(l);
- p++;
- }
- return(p);
- }
-
- /* M_COMPILE: x dsep x --to-- x,_dsep,0,x
- */
- _dsep(l,p) int(*l[])(),p;
- {
- if((status&XMODE) == M_FIXUP) ++p;
- return(p);
- }
-
- /* routines for changing the interpretors state. */
-
- struct statstk { /* for saving old states */
- int stkp;
- int stat;
- } sstk[30];
- int sstktop = 0;
-
- /* M_COMPILE:
- * x pushstate <state> x --to-- x,pushstate,<state>,x
- * M_FIXUP:
- * skip <state>
- * any other state:
- * save old state and stack pointer.
- * set state to <state>.
- */
- _pushstate(l,p) int (*l[])(),p;
- {
- if((status&XMODE) == M_FIXUP) return(++p);
- sstk[sstktop].stkp = stackp;
- sstk[sstktop].stat = status;
- sstktop++;
- status = l[p++];
- return(p);
- }
- _popstate(l,p) int (*l[])(),p;
- {
- if((status&XMODE) == M_FIXUP) return(p); /* want to stay in this mode */
- sstktop--;
- stackp = sstk[sstktop].stkp;
- status = sstk[sstktop].stat&XMODE;
- return(p);
- }
-
-
- /* stack maintanence routines.
- */
-
-
- /* M_COMPILE:
- * x spop x --to-- x,_spop,x
- * M_EXECUTE:
- * stack: string,x --to-- x
- * other: frees storage used by string (if any).
- */
- _spop(l,p) int(*l[])(),p;
- {
- union value s;
-
- if((status&XMODE) == M_EXECUTE) {
- s=pop();
- if(s.sval != 0) free(s.sval);
- }
- return(p);
- }
-
- /* M_COMPILE:
- * x pop x --to-- x,_pop,x
- * M_EXECUTE:
- * stack: int,x --to-- x
- */
- _pop(l,p) int(*l[])(),p;
- {
- if((status&XMODE) == M_EXECUTE) pop();
- return(p);
- }
-
- _stop(l,p) int(*l[])(),p;
- {
- if((status&XMODE) == M_EXECUTE) exit(1);
- return(p);
- }
- _end(l,p) int (*l[])(),p; { return(_stop(l,p)); }
-
-
-