home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 18 REXX / 18-REXX.zip / rximc175.zip / rexx.c < prev    next >
C/C++ Source or Header  |  2002-08-06  |  101KB  |  2,145 lines
  1. /* The basic interpreter functions of REXX/imc    (C) Ian Collier 1992 */
  2.  
  3. #include<stdio.h>
  4. #include<stdlib.h>
  5. #include<unistd.h>
  6. #include<memory.h>
  7. #include<string.h>
  8. #include<signal.h>
  9. #include<setjmp.h>
  10. #include<sys/types.h>
  11. #include<sys/time.h>
  12. #include<sys/stat.h>
  13. #include<sys/file.h>
  14. #include<sys/socket.h>
  15. #include"const.h"
  16. #include"globals.h"
  17. #include"functions.h"
  18. #define INCL_REXXSAA
  19. #include "rexxsaa.h"
  20.  
  21. static program *oldprog=0;     /* while loading a new one */
  22. static int oldstmts=0;         /* Old number of statements */
  23. static int tmpstack=0;         /* whether a temporary pstack item is present */
  24. static int haltline=0;         /* line number where halt occurred */
  25. static char *signalto;         /* name of label to go to */
  26. static int ippc;               /* statement number of INTERPRET */
  27. static int interpreting=0;     /* =1 while tokenising INTERPRETed data */
  28. extern char version[];         /* version string (for parse) */
  29. extern char *psource;          /* source string (for parse) */
  30.  
  31. /* when extra data has been found on the end of a clause, the following
  32.    distinguishes between "unexpected ')' or ','" and "invalid data" */
  33. #define Edata (c==')'||c==','?Erpar:Exend) 
  34.  
  35. /* memory allocation. */
  36.  
  37. /* allocm(size) allocates "size" bytes of memory and returns the answer.
  38.    It dies if malloc returns an error. */
  39. /* mtest and dtest (macros, except during debug) check that the given REXX
  40.    structure is large enough; if not they try to extend it and die if realloc
  41.    fails.  dtest returns 1 if the area moved and sets mtest_diff to the
  42.    distance between the old and new pointers */
  43.    
  44. char *allocm(size)
  45. unsigned size;
  46. {  char *pointer;
  47.    if((pointer=malloc(size))==cnull)die(Emem);
  48. #ifdef DEBUG
  49.    /* tell what has been alloced */
  50.    printf("allocm: allocated (%lX,%d)\n",(long)pointer,size);
  51. #endif
  52.    return pointer;
  53. }
  54.  
  55. /* The non-debug version of mtest is now a macro; the debug version calls
  56.    this function. Note that in
  57.       mtest(memptr,alloc,length,extend)
  58.    memptr and alloc are identifiers. length is an expression which is
  59.    evaluated exactly once. extend is an expression which is evaluated
  60.    zero or one times. In all other ways, mtest acts like a function.
  61. */
  62. #ifdef DEBUG
  63. int mtest_debug(memptr,alloc,length,extend,diff)
  64. unsigned *alloc,length,extend;
  65. char **memptr;
  66. long *diff;
  67. {
  68.    static int elabptr=0;
  69.    static char **areas[]={&cstackptr,&pstackptr,&workptr,&vartab,&labelptr};
  70.    static char *aname[]={"cstack","pstack","worksp","variables","labels"};
  71.    static int  *lens[]={&cstacklen,&pstacklen,&worklen,&vartablen,&elabptr};
  72.    static int  num=5;
  73.    char *oldmemptr=*memptr;
  74.    int oldlen= *alloc;
  75.    int newlen= *alloc+extend;
  76.    int i,j;
  77.    char *a,*b,*c,*d;
  78.    static int doneit=0;
  79.    if((*alloc)>=length)return 0;
  80.     /* used to be if(doneit==2) */
  81.       doneit=1;
  82.       printf("Areas:\n");
  83.       for(j=0;j<num;j++)
  84.          printf(" %s (%lX,%d)\n",aname[j],(long)*areas[j],*lens[j]);
  85.    for(i=0;i<num&&*areas[i] !=oldmemptr;i++);
  86.    if((*memptr=realloc(*memptr,(*alloc)+=extend))==cnull)
  87.       *memptr=oldmemptr,(*alloc)-=extend,die(Emem);
  88.    printf("mtest: %s changed from (%lX,%d) to (%lX,%d)\n",i<num?aname[i]:"area",(long)oldmemptr,oldlen,(long)*memptr,newlen);
  89.    if(diff)*diff=*memptr-oldmemptr;
  90.    a=*memptr;
  91.    b=a+newlen;
  92.    if(!doneit)doneit=2;
  93.    for(j=0;j<num;j++){
  94.       if(j==i)continue;
  95.       c= *areas[j];
  96.       d=c+*lens[j];
  97.       if(!c)doneit=0;
  98.       if((c>=a&&c<=b)||(d>=a&&d<=b)||(a>=c&&a<=d))
  99.          printf("   overlaps with %s (%lX,%d)\n",aname[j],(long)*areas[j],*lens[j]);
  100.    }
  101.    return 1;
  102. }
  103. #endif
  104.  
  105. void die(rc) /* Error (exception) handler: cleans up, prints message, and */
  106. int rc;      /* does all the usual things that happen at error time */
  107. {
  108.    int i=0,l;
  109.    int catch;   /* Whether the error is to be caught by SIGNAL ON xxx */
  110.    int lev;     /* nesting level of interpreter() to longjmp to if catch!=0 */
  111.    int bit;     /* bit to test against "trap" flags in signal structure */
  112.    int stmt;    /* Where to signal to if the error is caught */
  113.    char rcb[20];/* for printing the rc */
  114.    char *ptr;   /* for traversing the program stack */
  115.    char *edata; /* saved copy of errordata */
  116.    int errline; /* which line number to say the error occurred in */
  117.    int sigl;    /* What to set SIGL to */
  118. recurse:
  119.    edata=errordata;
  120.    if(prog)errline=sigl=prog[ppc].num;
  121.    errordata=cnull; /* Clear this now for next time; it has been saved */
  122. /* find out whether the error is to be caught */
  123.    switch(rc){      /* find out what trap has occurred, based on rc */
  124.       case Ehalt:    bit=Ihalt;    break;
  125.       case Enovalue: bit=Inovalue; break;
  126.       case Eerror:   bit=Ierror;   break;
  127.       case Efailure: bit=Ifailure; break;
  128.       case Enotready:bit=Inotready;break;
  129.       case 0:
  130. /*    case Esys:
  131.       case Emem: */  bit=0;        break;/* never catch `OK' or `out of memory'
  132.                                             or `failure in system service' */
  133.       default:       bit=Isyntax;
  134.    } /* Now check that bit against the signal stack */
  135.    catch=(interpreting || ppc>0) && interplev>=0 &&
  136.          (sgstack[interplev].bits&(1<<bit));
  137.                               /* catch>0 if signal was on or inherited */
  138.    if(catch){                 /* Find lev = level in which signal is caught */
  139.       for(lev=interplev;!(sgstack[lev].bitson&(1<<bit));lev--);
  140.       if(lev<=interact)catch=0; /* Do not trap errors in interactive command */
  141.    }
  142.    if(catch&&interpreting){ /* error has been trapped while tokenising */
  143.       free(prog[0].source); /* for INTERPRET, so silently get rid of */
  144.       free(prog[0].line);   /* the source string and point to the */
  145.       free((char*)prog);    /* program instead */
  146.       prog=oldprog;
  147.       stmts=oldstmts;
  148.       errline=sigl=prog[ppc=ippc].num;
  149.       interpreting=0;
  150.    }
  151.    if(catch){
  152.       stmt=sgstack[lev].ppc[bit];
  153.       sgstack[lev].bits &= ~(1<<bit);  /* Turn off trapping immediately */
  154.       sgstack[lev].bitson &= ~(1<<bit);
  155.       sgstack[interplev].bits &= ~(1<<bit);
  156.       if(stmt<0){             /* If label not found, then see whether this
  157.                                  is to be caught.  If not then display an
  158.                                  appropriate message.  (If it is then it
  159.                                  will be caught later). */
  160.          catch=bit!=Isyntax&&(sgstack[lev].bits&(1<<Isyntax));
  161.          if(!catch){
  162.             ptr=(char*)pstack(20,sizeof(struct errorstack));/*Stack the trapped line*/
  163.             ((struct errorstack *)ptr)->prg=prog;   /* so that it appears in */
  164.             ((struct errorstack *)ptr)->stmts=stmts;/* the traceback         */
  165.             ppc=-stmt;
  166.             findsigl(&lev);               /* Find the SIGNAL ON instruction. */
  167.             if(bit==Inotready)
  168.                tracestr("      +++ "),
  169.                tracestr(sigdata[bit]),
  170.                tracestr(": "),
  171.                tracestr(message(Eerrno+lasterror));
  172.             else tracestr("      +++ "),
  173.                tracestr(message(rc));
  174.             if(edata&&rc==Enovalue)tracestr(" on ");
  175.             if(edata)tracestr(edata);
  176.             tracechar('\n');     /* This writes an informative message about */
  177.                                  /* the trapped condition                    */
  178.             rc=Elabel;
  179.             goto recurse;      /* Report the label not found error.          */
  180.          }
  181.       }
  182.    }
  183.    else lev=0;           /* not caught: catch and lev are zero */
  184.    trcresult=0;          /* not nested inside scanning() */
  185.    if(prog && !ppc && rc>=0){  /* Error occurred while tokenising */
  186.                                /* Noisily get rid of the new program */
  187.       ptr=prog[stmts].source;    /* The error occurred after this point */
  188.       if(!ptr)              /* default: start of the last line encountered*/
  189.          ptr=prog[stmts].source=source[lines],
  190.          prog[stmts].num=lines;
  191.       errline=prog[stmts].num;
  192.       /* Try and find a place to stop  */
  193.       for(i=64;i--&&ptr[0]!='\n'&&ptr[0];ptr++);
  194.       if(i<0)ptr[-1]=ptr[-2]=ptr[-3]='.';/* Elipsis if not at end of line */
  195.       prog[stmts++].sourcend=ptr;
  196.       source[++lines]=ptr+1;
  197.       i=pstacklev;
  198.       if(!interpreting)pstacklev=0;      /* Don't indent a program line */
  199.       else pstacklev++;                  /* do indent an interpret */
  200.       printstmt(stmts-1,0,1);
  201.       pstacklev=i;
  202.       if(interpreting){     /* free interpreted text then continue to */
  203.          free(prog[0].source);  /* report an error in the program */
  204.          free(prog[0].line);
  205.          free((char*)prog);
  206.          prog=oldprog;
  207.          stmts=oldstmts;
  208.          errline=prog[ppc=ippc].num;
  209.          interpreting=0;
  210.       }
  211.       else{                 /* report the error and exit */
  212.          tracestr("Error ");
  213.          tracenum(rc,1);
  214.          tracestr(" running ");
  215.          tracestr(fname);
  216.          tracestr(", line ");
  217.          tracenum(errline,1);
  218.          tracestr(": ");
  219.          tracestr(message(rc));
  220.          if(edata)tracestr(edata);
  221.          tracechar('\n');
  222.          longjmp(*exitbuf,rc);
  223.       }
  224.    }
  225. /* Get the name of the file in which the error occurred */
  226.    if (edata&&rc==-3)    /* the error data for rc -3 is a file name, */
  227.       strcpy(fname,edata);/* which will be printed by message() */
  228.    else if(source)       /* by default, use the current file name. If that */
  229.       strcpy(fname,source[0]);  /* doesn't exist, fname will already be OK */
  230. /* Clean program stack and print out traceback */
  231.    if (rc==Enoend && ppc==stmts){
  232.       /* if an END is missing, don't use EOF as the error line */
  233.       tmpstack=0;
  234.       i=unpstack();
  235.       if (i<=10 || i==15) {  /* the start of the thing that needed END */
  236.          ppc=newppc;
  237.          errline=sigl=prog[ppc].num;
  238.          delpstack();
  239.       }
  240.    }
  241.    if (rc&&source){             /* source exists and it is a real error */
  242.       if(tmpstack)
  243.          tmpstack=0,delpstack();     /* remove temporary stack item */
  244.       if(!catch)printstmt(ppc,0,1);  /* print the line in error */
  245.       while(pstacklev){ 
  246.          i=unpstack();               /* find out what the next entry is */
  247.          if(i==16)                   /* stop if interactive reached */
  248.             break;
  249.          if(catch && (i==11||i==12) && interplev==lev) /* at CALL entry and */
  250.             break;                 /* the level is right to catch the error */
  251.          freestack(delpstack(),i);       /* delete stack entry and clean up */
  252.          if(!catch)printstmt(newppc,0,1);/* print a traceback line */
  253.          if(!sigl &&interplev!=interact) /* if in INTERPRET (sigl==0) then */
  254.             sigl=prog[newppc].num;       /* point sigl to the INTERPRET */
  255.       }
  256.    }
  257.    if(!errline)errline=sigl; /* don't say "error in line 0" if it happened
  258.                           during INTERPRET. Flag the INTERPRET instruction */
  259.    if(interact>=0&&interplev==interact){
  260.       /* the error occurred while interpreting interactive data.  Print the
  261.          message and jump back to interactive trace mode. */ 
  262.       fputs(message(rc),ttyout);
  263.       if(edata && rc==Enovalue)fputs(" on ",ttyout);
  264.       if(edata)fputs(edata,ttyout);
  265.       fputc('\n',ttyout);
  266.       longjmp(interactbuf,1);
  267.    }
  268.    if(catch){     /* the error has been caught. jump to the right label */
  269.       sprintf(rcb,"%d",rc);           /* set the special variable rc */
  270.       if(bit==Isyntax||bit==Ihalt||bit==Inovalue)
  271.          varset("RC",2,rcb,strlen(rcb));
  272.       if(stmt<=0){    /* If "label not found" was caught, go and catch it */
  273.          rc=Elabel;
  274.          goto recurse;
  275.       }
  276.       sgstack[interplev].type=1;      /* Store the information for CONTITION */
  277.       sgstack[interplev].which=bit;
  278.       sgstack[interplev].data=sigdata[bit];
  279.       sigdata[bit]=0;
  280.       if(bit==Inovalue && edata)
  281.          strcpy(sgstack[interplev].data=allocm(strlen(edata)),edata);
  282.       if(bit==Isyntax){
  283.          l=edata?strlen(edata):0;
  284.          l+=strlen(ptr=message(rc));
  285.          strcpy(sgstack[interplev].data=allocm(l+1),ptr);
  286.          if(edata)strcat(sgstack[interplev].data,edata);
  287.       }
  288.       if(bit==Ihalt)sigl=haltline;    /* in the case of halt, use stored sigl*/
  289.       sprintf(rcb,"%d",sigl);         /* set the special variable sigl */
  290.       varset("SIGL",4,rcb,strlen(rcb));
  291.       ppc=stmt;
  292.       longjmp(sgstack[interplev].jmp,1);
  293.    }
  294. /* Print the error message */
  295.    if (rc>0){
  296.       tracestr("Error "),
  297.        tracenum(rc,1);
  298.       if (ppc<0)tracestr(" interpreting arguments: ");
  299.       else 
  300.          tracestr(" running "),
  301.          tracestr(fname),
  302.          tracestr(", line "),
  303.          tracenum(errline,1),
  304.          tracestr(": ");
  305.       tracestr(message(rc));
  306.       if(edata)tracestr(edata);
  307.       tracechar('\n');
  308.    }
  309.    if (rc<0){
  310.       tracestr(message(rc));
  311.       if(rc==-3 && edata)tracechar(' ');
  312.       if(edata)tracestr(edata);
  313.       tracechar('\n');
  314.    }
  315. /* Finally, exit... */
  316.    longjmp(*exitbuf,rc);
  317. }
  318.  
  319. char *interpreter(anslen,start,callname,calltype,args,arglen,inherit,delay)
  320. /* Interprets a program, or part of a program. Called by main() and the REXX
  321.    instructions which cause control to move temporarily.
  322.    The return value is NULL, or the address of a string, determined by what
  323.    is specified on EXIT or RETURN from the rexx program.  The length of the
  324.    result (if any) is stored in anslen.  */
  325.    
  326. int start;        /* which statement to start at */
  327. char *callname;   /* fourth token of "parse source" */
  328. long calltype;    /* COMMAND, FUNCTION or SUBROUTINE */
  329. char *args[];     /* array of arguments, ending with null pointer */
  330. int arglen[];     /* array of argument lengths */
  331. int *anslen;      /* length of the answer */
  332. int inherit;      /* Whether to inherit signals */
  333. int delay;        /* Whether to delay any signals */
  334. {
  335.    char *lineptr; /* Pointer to the current program line */
  336.    char *tmpptr;
  337.    int tmpchr,tmpppc;
  338.    char c,c2;
  339.    int len;
  340.    int env;
  341.    int i,m,e,z;
  342.    int up;        /* whether to uppercase (during PARSE) */
  343.    char *exp;
  344.    int l;
  345.    int chkend;    /* whether to check for a line terminator */
  346.    char varname[maxvarname];
  347.    static char exitbuff[RXRESULTLEN];
  348.    int varlen;
  349.    char *varref;
  350.    int reflen;
  351.    char *parselist[maxargs+1]; /* list of strings to PARSE */
  352.    int parselen[maxargs+1];    /* lengths of those strings */
  353.    int stype,sllen,sslen;      /* used for DO and END */
  354.    char *slimit,*sstep,*svar;
  355.    int ilimit,istep,istart;
  356.    int whilep,untilp;          /* values of WHILE and UNTIL conditions */
  357.    char *entry;                /* address of a program stack entry */
  358.    char *mtest_old;
  359.    long mtest_diff;
  360.    int fr;                     /* number following FOR in a DO instruction */
  361.    int s;
  362.    int *lptr;
  363.    struct fileinfo *info;
  364.    long filepos;
  365.  
  366.    ppc=start;
  367.    
  368. /* save stack details in case of signal or signal on or exit. The return
  369.    from _setjmp is: 0 when called initially, 1 when jumped to after an error
  370.    is trapped, 2 during SIGNAL (when the stack is cleared) and
  371.    -1 when jumped to on EXIT */
  372.    if(inherit){
  373.       sgstack[interplev].bits=sgstack[interplev-1].bits,
  374.       sgstack[interplev].callon=sgstack[interplev-1].callon,
  375.       sgstack[interplev].delay=sgstack[interplev-1].delay|(1<<delay)&~1;
  376.       sgstack[interplev].type=sgstack[interplev-1].type;
  377.       sgstack[interplev].which=sgstack[interplev-1].which;
  378.       for(l=0;l<Imax;l++)sgstack[interplev].ppc[l]=sgstack[interplev-1].ppc[l];
  379.    }
  380.    else sgstack[interplev].bits=0,
  381.         sgstack[interplev].callon=0,
  382.         sgstack[interplev].delay=0,
  383.         sgstack[interplev].type=0,
  384.         sgstack[interplev].data=0;
  385.    sgstack[interplev].bitson=0;
  386.    sgstack[interplev].data=0;
  387.    if(delay){
  388.       sgstack[interplev].which=delay;
  389.       sgstack[interplev].type=2;
  390.       sgstack[interplev].data=sigdata[delay];
  391.       sigdata[delay]=0;
  392.    }
  393.    if((s=setjmp(sgstack[interplev].jmp))<0){
  394.       /* after EXIT, return from external call with the result */
  395.       if(!returnval)return cnull;
  396.       stack(returnval,returnlen);
  397.       free(returnfree);
  398.       return delete(anslen);
  399.    }
  400. /* save the arguments (done here in case of a "signal on") */   
  401.    curargs=args,
  402.    curarglen=arglen;
  403.    if(s==2)goto signal;
  404.    if(s==0&&trcflag&Tclauses)printstmt(ppc-1,1,0); /* Trace opening comments */
  405. /* Loop for each statement */
  406.    while(ppc<stmts){
  407.       lineptr=prog[ppc].line;
  408.       ecstackptr=0; /* clear the calculator stack */
  409.       nextvar=0;    /* RXSHV_NEXTV starts from scratch */
  410.  
  411.       /* tracing - check for labels */
  412.       if(*lineptr==LABEL && (trcflag&Tlabels)){
  413.          printstmt(ppc,0,0);
  414.          interactive();
  415.       }
  416.  
  417.       chkend=1;                     /* do check for line terminator */
  418.  
  419.       /* trace clauses */
  420.       if(trcflag&Tclauses){
  421.          if((c= *lineptr)==END&&pstacklev)
  422.             tmpchr=epstackptr,
  423.             unpstack(),         /* at an END, print out also the DO */
  424.             delpstack(),        /* this un-indents the END and the DO */
  425.             printstmt(ppc,0,0), /* whilst maintaining a consistent stack */
  426.             printstmt(newppc,0,0),
  427.             pstacklev++,        /* put the deleted stack entry back. */
  428.             epstackptr=tmpchr;
  429.          else printstmt(ppc,0,0);
  430.          interactive();
  431.       }
  432. /* Select what to do on the first character of the line */
  433.       if(*lineptr<0)  /* i.e. a keyword */
  434.          switch(c2=*lineptr++){
  435.             case SAYN: /* If a parameter is given, print it on stdout. */
  436.             case SAY:  /* With SAY, follow it with a newline */
  437.                if(*lineptr){
  438.                   tmpchr=0;
  439.                   exp=scanning(lineptr,&tmpchr,&len);
  440.                   lineptr+=tmpchr;
  441.                   delete(&len);
  442.                   if(c2==SAY)exp[len++]='\n';
  443.                }else{
  444.                   if(c2==SAYN)break;
  445.                   len=1,
  446.                   exp=pull,
  447.                   exp[0]='\n';
  448.                } 
  449.                if(c2==SAY && exitlist[RXSIO]){
  450.                   RXSIOSAY_PARM rxs;
  451.                   rxs.rxsio_string.strptr=exp;
  452.                   rxs.rxsio_string.strlength=len-1;
  453.                   exp[len-1]=0;
  454.                   if(exitcall(RXSIO,RXSIOSAY,&rxs)==RXEXIT_HANDLED)break;
  455.                   exp[len-1]='\n';
  456.                }
  457.                /* mirror the charout function to print the data */
  458.                if(!(info=(struct fileinfo *)hashget(1,"stdout",&l)))break;
  459.                if(info->lastwr&&(filepos=ftell(info->fp))>=0&&filepos!=info->wrpos)
  460.                   info->wrpos=filepos,
  461.                   info->wrline=0;  /* position has been disturbed */
  462.                if(info->lastwr==0)fseek(info->fp,info->wrpos,0);
  463.                info->lastwr=1;
  464.                if(fwrite(exp,len,1,info->fp)){
  465.                   if(info->wrline)info->wrline++;
  466.                   info->wrchars=0;
  467.                   if(info->persist && (info->wrpos=ftell(info->fp))<0) info->wrpos=0;
  468.                }
  469.                else fseek(info->fp,info->wrpos,0);
  470.                if(c2==SAYN)fflush(info->fp);
  471.                break;
  472.             case DO: tmpstack=1,  /* stack the current position. */
  473.                entry=(char *)pstack(stype=0,sizeof(struct minstack));
  474.                if(!(c= *lineptr))               /* non-repetitive. */
  475.                   {tmpstack=0;break;}           /* do nothing. */
  476.                if(c>0) {     /* a repetition count or a variable follows */
  477.                   tmpchr=0;
  478.                   varref=lineptr;               /* save the var's reference */
  479.                   getvarname(lineptr,&tmpchr,varname,&varlen,maxvarname);
  480.                   reflen=tmpchr;
  481.                   if(lineptr[tmpchr]!='=') /* not a variable unless followed */
  482.                      varname[0]=0;         /* by "=" */
  483.                }
  484.                else varname[0]=0;   /* a keyword follows */
  485.                if(varname[0]){
  486. /* a variable clause was found. Begin by getting the start value, then get
  487.    the "TO", "BY" and "FOR" values. The values are stored as integer offsets
  488.    in the calculator stack, in case the stack moves. FOR is stored as an
  489.    integer value. */
  490.                   tmpchr++;           /* character after '=' */
  491.                   scanning(lineptr,&tmpchr,&len);
  492.                   lineptr+=tmpchr;
  493.                   unplus(OPplus);   /* do "name = expri + 0" */
  494.                   istart=undelete(&len)-cstackptr;
  495.                   sllen= -1,  /* limit=default (=null) (length -1) */
  496.                   sslen= -1,  /* step=default (=1)   */
  497.                   fr= -1;     /* for=default (=null) */
  498.                   while((c=*lineptr)==TO||c==BY||c==FOR){
  499.                      tmpchr=1;
  500.                      if(c==TO)
  501.                         slimit=scanning(lineptr,&tmpchr,&sllen),
  502.                         ilimit=slimit-cstackptr;
  503.                      else if(c==BY)
  504.                         sstep=scanning(lineptr,&tmpchr,&sslen),
  505.                         istep=sstep-cstackptr;
  506.                      else /* c==FOR */{
  507.                         scanning(lineptr,&tmpchr,&i);
  508.                         if((fr=getint(1))<0)die(Erange);
  509.                      }
  510.                      lineptr+=tmpchr;
  511.                   }  /* a keyword or line terminator must follow: */
  512.                   if(c>0)die(Exdo);
  513.                      /* now stack the parameters in the correct order. This
  514.                         leaves unused copies further down the stack, but
  515.                         these are cleared at the end of the command anyway.
  516.                         Once stacked they will be copied into the program
  517.                         stack. */
  518.                   i=reflen+sllen+sslen+len+64+ecstackptr;
  519.                      /* make sure cstack doesn't move while stacking data */
  520.                   mtest(cstackptr,cstacklen,i,i-ecstackptr);
  521.                   stack(istart+cstackptr,len),
  522.                   varset(varname,varlen,istart+cstackptr,len),/* var = start */
  523.                   tmpchr=ecstackptr;  /* save the address of the following: */
  524.                   if(sllen>=0)stack(ilimit+cstackptr,sllen),sllen=1;
  525.                   else stack(cnull,sllen=0); /* sllen now is "limit given?" */
  526.                   if(sslen>=0)stack(istep+cstackptr,sslen);
  527.                   else stack("1",1);
  528.                   stack(varref,reflen+1), /* variable name plus the '=' */
  529.                   i=ecstackptr-tmpchr;/* i is the length of all that data */
  530.                   if dtest(pstackptr,pstacklen,epstackptr+i+30,i+300)
  531.                      entry+=mtest_diff; /* stack the data on the pstack */
  532.                   memcpy((char*)&((struct minstack *)entry)->len,cstackptr+tmpchr,i),
  533.                   epstackptr+=i-2*four, /* now add the FOR num, the length, */
  534.                   (*(int *)(pstackptr+epstackptr))=fr,      /* and the type */
  535.                   (*(int *)(pstackptr+(epstackptr+=four)))=i+four+sizeof(struct minstack),
  536.                   (*(int*)(pstackptr+(epstackptr+=four)))=stype=10,
  537.                   epstackptr+=four,
  538. /* having constructed the program stack, make an initial test on the data */
  539.                   delete(&l);                       /* delete the varname */
  540.                   if(num(&m,&e,&z,&l)<0)die(Enum);  /* test the step      */
  541.                   delete(&l);                       /* delete the step    */
  542.                   if(sllen)binmin(4); /* if limit supplied, sub from value*/
  543.                   else stack("0",1);  /* else just stack 0                */
  544.                   if(!m)unmin(20);    /* Negate that if step >= 0         */
  545.                   num(&m,&e,&z,&l);   /* test the answer                  */
  546.                   if(m||!fr)          /* if that<0 or FOR==0 then leave   */
  547.                      {sllen=1,tmpstack=0;goto leaveit;}
  548.                }
  549. /* End of control variable processing; start of numeric count processing  */
  550.                else if(c>0){
  551.                   tmpchr=0;
  552.                   scanning(lineptr,&tmpchr,&len);
  553.                   lineptr+=tmpchr;
  554.                   if((i=getint(1))<0)die(Erange); /* i is the number */
  555.                   if(!i){ /* i==0 so leave already */
  556.                      sllen=1,
  557.                      tmpstack=0;
  558.                      goto leaveit;
  559.                   } /* Make a FOR stack containing the counter */
  560.                   ((struct forstack *)entry)->fornum=i,
  561.                   ((struct forstack *)entry)->len=sizeof(struct forstack),
  562.                   ((struct forstack *)entry)->type=stype=15,
  563.                   epstackptr+=sizeof(struct forstack)-sizeof(struct minstack);
  564.                }
  565. /* Next deal with any other data (while/until/forever) */
  566.                /* first update the character pointer to the current position */
  567.                ((struct minstack *)entry)->pos=lineptr;
  568.                c=*lineptr;
  569.                if(c==FOREVER){ /* like UNTIL but no expression follows */
  570.                   if(!stype)((struct minstack *)entry)->type=8;
  571.                   c=*++lineptr;
  572.                }
  573.                if(c==WHILE||c==UNTIL){     /* s/if/while for multiple conds */
  574.                   if(!stype)               /* no control variable or counter */
  575.                      ((struct minstack *)entry)->type=stype=8;
  576.                   if(c==WHILE){           /* evaluate and test the value now */
  577.                      tmpchr=1;
  578.                      scanning(lineptr,&tmpchr,&len);
  579.                      lineptr+=tmpchr;
  580.                      if(num(&m,&e,&z,&l)<0)die(Enum);
  581.                      if(*lineptr>0)die(Exdo);
  582.                      if(z){sllen=1,tmpstack=0;goto leaveit;}
  583.                   } /* but jump past an UNTIL value. */
  584.                   else for(c=1;c&&c!=WHILE&&c!=UNTIL;c=*++lineptr);
  585.                }
  586. /* Finish off DO processing */
  587.                if(*lineptr)die(Exdo);    /* check for invalid data at end */
  588.                tmpstack=0;          /* stack entry is no longer temporary */
  589.                break;
  590.             case END:if(!pstacklev)die(Eend); /* no data on stack */
  591.                exp=pstackptr+epstackptr;      /* Get top stack entry */
  592.                stype= *((int *)exp-1);
  593.                exp-=  *((int *)exp-2);
  594.                tmpppc=((struct minstack *)exp)->stmt;
  595.                tmpptr=((struct minstack *)exp)->pos;
  596.                if(stype==2)                   /* top entry is SELECT */
  597.                   goto when;
  598.                if(stype>10&&stype!=15)die(Eend); /* top entry is not DO */
  599.                if(!stype){ /* a non-repetitive DO - just continue */
  600.                   delpstack();
  601.                   break;
  602.                }
  603. /* First the UNTIL condition(s) are evaluated.  tmpppc and tmpptr point to
  604.    them in the original DO instruction.  Variable untilp will be set to
  605.    true if the loop needs to be exited */
  606.                whilep=0;untilp=0;
  607.                c= *tmpptr;
  608.                if(c==FOREVER)c= *++tmpptr;               /* ignore FOREVER */
  609.                if(c==UNTIL){
  610.                   tmpchr=1,
  611.                   scanning(tmpptr,&tmpchr,&len),
  612.                   tmpptr+=tmpchr,
  613.                   eworkptr=0,
  614.                   len=num(&m,&e,&z,&l);
  615.                   /* so len>=0 if the number was valid, z=1 if it was zero. */
  616.                   if(len<0)die(Enum);
  617.                   untilp=!z;
  618.                }
  619.                if((c=*tmpptr) && c!=WHILE) /* should be nothing after UNTIL*/
  620.                   delpstack(), /* If not, remove the DO's stack entry but  */
  621.                   ppc=tmpppc,  /* flag the error in the DO statement, not  */
  622.                                /* the END */
  623.                   die(Edata);
  624. /* Now, the UNTIL condition is tested before incrementing the control
  625.    variable (if any).  A symbol after the END, if any, must be skipped if
  626.    the loop is to be left at this point. */
  627.                if(untilp){
  628.                   if((c= *lineptr)==SELECT)die(Exend);
  629.                   if(c>0){
  630.                      if(stype!=10)die(Exend);   /* must be DO with control   */
  631.                      svar=pstackptr+epstackptr-3*four;/* point to FOR field  */
  632.                      svar-=four,                /* point to variable length  */
  633.                      svar -= align(varlen= *(int *)svar);/* point to name    */
  634.                      testvarname(&lineptr,svar,varlen-1);/* Check it matches */
  635.                   }
  636.                   delpstack();
  637.                   /* Check for conditions before leaving */
  638.                   tmpchr=ppc; ppc=tmpppc;doconds();ppc=tmpchr;
  639.                   break;
  640.                }
  641. /* The integer counter (if any) is decremented, tested and added to the
  642.    WHILE condition */
  643.                if(stype==10||stype==15){
  644.                   svar=pstackptr+epstackptr-3*four;/* point to FOR field */
  645.                   if((fr= *(int *)svar)>0) /* get the FOR field */
  646.                      (*(int *)svar)= --fr; /* fr now holds its new value */
  647.                   if(!fr)whilep=1;
  648.                }
  649.                if(stype==10){
  650. /* the top stack entry is DO with variable. Increment the variable */
  651.                   svar-=four,              /* point to variable length */
  652.                   svar -= align(varlen= *(int *)svar); /* point to name */
  653.                   testvarname(&lineptr,svar,varlen-1); /* Check it matches */
  654.                   tmpchr=0;         /* Evaluate the symbol's current name */
  655.                   getvarname(svar,&tmpchr,varname,&varlen,maxvarname);
  656.                   if(!(exp=varget(varname,varlen,&len))) 
  657.                      die(Enum);     /* no value */ /* Er, what about NOVALUE?*/
  658.                   stack(exp,len),              /* stack the variable's value */
  659.                   sslen= *((int *)svar-1),     /* get the step's length */
  660.                   sstep=svar-align(sslen)-four,/* and the step's address */
  661.                   sllen= *((int *)sstep-1),    /* get the limit's length */
  662.                   slimit=sstep-align(sllen)-four,/* and the limit's value */
  663.                   stack(sstep,sslen),
  664.                   num(&m,&e,&z,&l),            /* get the step's sign in m */
  665.                   binplus(OPadd),              /* add step to value */
  666.                   tmpchr=ecstackptr,           /* get the result without */
  667.                   exp=delete(&len),            /* deleting it (by saving */
  668.                   ecstackptr=tmpchr,           /* ecstackptr) */
  669.                   varset(varname,varlen,exp,len); /* set the var's new value */
  670.                   if(sllen)                    /* if limit was given, */
  671.                      stack(slimit,sllen),      /* subtract it from value */
  672.                      binmin(4);
  673.                   else stack("0",1);           /* else just stack 0 */
  674.                   if(!m)unmin(20);             /* negate if step>=0 */
  675.                   num(&m,&e,&z,&l);            /* get sign in m */
  676.                   if(m||!fr)                   /* if loop has finished then */
  677.                      whilep=1;                 /* pretend the WHILE was false*/
  678.                } /* end if(DO with control variable) */
  679.                /* otherwise if END is followed by anything, it is an error. */
  680.                else if((c=*lineptr)==SELECT||c>0)die(Exend);
  681.                /* Finally, the WHILE condition(s) are evaluated.  tmpptr
  682.                   points to them in the original DO instruction. */
  683.                if(!whilep && *tmpptr==WHILE){
  684.                   tmpchr=1,
  685.                   scanning(tmpptr,&tmpchr,&len),
  686.                   tmpptr+=tmpchr,
  687.                   eworkptr=0,
  688.                   len=num(&m,&e,&z,&l);
  689.                   if(len<0)die(Enum);
  690.                   whilep=z;
  691.                   if((c=*tmpptr)) /* should be nothing after WHILE */
  692.                      delpstack(),
  693.                      ppc=tmpppc,  /* flag the error in the DO statement */
  694.                      die(Edata);
  695.                }
  696. /* So now leave if whilep is true, but iterate if it is false. */
  697.                tmpchr=ppc;ppc=tmpppc;
  698.                doconds();         /* Check for trapped conditions in the DO */
  699.                if(whilep)ppc=tmpchr,delpstack(); 
  700.                else lineptr=tmpptr;    /* copy the character ptr to the end */
  701.                                        /* of the DO clause */
  702.                break;
  703.             case IF: tmpchr=0,
  704.                scanning(lineptr,&tmpchr,&len);
  705.                if(num(&m,&e,&z,&l)<0)die(Enum); /* !z is the given value */
  706.                if(!(c=*lineptr))die(Edata);     /* line end reached      */
  707.                doconds();          /* trap conditions before continuing  */
  708.                if(ppc+1==stmts || prog[++ppc].line[0]!=THEN)die(Enothen);
  709.                if(++ppc==stmts)die(Eprogend);
  710.                chkend=0;           /* We will be already at start of a stmt */
  711.                if(!z)break;                    /* true: continue with THEN  */
  712.                skipstmt();                     /* false: skip THEN          */
  713.                if(prog[ppc].line[0]==ELSE)     /* if the next word is ELSE  */
  714.                   if(++ppc==stmts)die(Eprogend);/* check for more statements*/
  715.                   else break;                /* Do the stmt after the ELSE. */
  716.                                              /* Usually it would be skipped */
  717.                break;                        
  718.             case ELSE:chkend=0;    /* We will be already at start of a stmt */
  719.                if(++ppc==stmts)die(Eprogend);/* check for more statements   */
  720.                skipstmt();                   /* Skip the ELSE statement     */
  721.                break;
  722.             case SELECT:chkend=0;  /* We will be already at start of a stmt */
  723.                if(*lineptr)
  724.                   s=1, /* s means a value is given, and is on the stack */
  725.                   tmpchr=0,
  726.                   scanning(lineptr,&tmpchr,&len),
  727.                   lineptr+=tmpchr;
  728.                else s=0; /* it is a standard SELECT with no value */
  729.                if(c=*lineptr)die(Edata);
  730.                pstack(2,sizeof(struct minstack));/*stack SELECT entry */
  731.                if(++ppc==stmts)die(Eprogend);/* check for more statements   */
  732.                z=1;
  733.                while((lineptr=prog[ppc].line)[0]== WHEN){
  734.                   if(trcflag&Tclauses)
  735.                      printstmt(ppc-1,1,0),
  736.                      printstmt(ppc,0,0);
  737.                   tmpchr=1;
  738.                   if(s)rxdup(); /* duplicate the SELECT value */
  739.                   scanning(lineptr,&tmpchr,&len); /* what comes after WHEN */
  740.                   lineptr+=tmpchr;
  741.                   if(c=*lineptr)die(Edata);
  742.                   doconds();          /* trap conditions before continuing  */
  743.                   if(1+ppc==stmts)die(Enothen);
  744.                   if(prog[++ppc].line[0]!=THEN)die(Enothen);/* find a THEN  */
  745.                   if(++ppc==stmts)die(Eprogend);/* check for more statements*/
  746.                   if(s)binrel(OPequ); /* Compare value with SELECT value */
  747.                   if(num(&m,&e,&z,&l)<0)die(Enum); /* test the result */
  748.                   delete(&l);
  749.                   if(!z)break;            /* True: follow this WHEN */
  750.                   if((c=prog[ppc].line[0])==WHEN||c==OTHERWISE)die(Ewhen);
  751.                   skipstmt();
  752.                }
  753.                if(z){
  754.                   if((lineptr=prog[ppc].line)[0]!=OTHERWISE)
  755.                      die(Enowhen);      /* No correct alternative: error */
  756.                   if(++ppc==stmts)die(Eprogend);/* check for more statements*/
  757.                }
  758.                break;
  759.             case OTHERWISE: /* for OTHERWISE and WHEN, just escape out of */
  760.             case WHEN:      /* the current SELECT construction. */
  761.                if((!pstacklev)||unpstack()!=2)
  762.                   die(Ewhen); /* the WHEN wasn't inside a SELECT */
  763.                when:
  764.                while(prog[ppc].line[0]==WHEN){  /* find an END by repeatedly */
  765.                   if(1+ppc>=stmts)die(Enothen); /* skipping WHENs */
  766.                   if(prog[1+ppc].line[0]!=THEN)die(Enothen);
  767.                   if((ppc+=2)==stmts)die(Enoend);
  768.                   skipstmt();
  769.                }
  770.                if(prog[ppc].line[0]==OTHERWISE)/* and step over any OTHERWISE*/
  771.                   findend();
  772.                else if(prog[ppc].line[0]!=END)die(Enowhen);
  773.                c=prog[ppc].line[1];         /* the character after END */
  774.                if(c&&c!= SELECT)            /* must be SELECT or terminator */
  775.                   die(Exend);
  776.                epstackptr-=sizeof(struct minstack), /* delete stack entry */
  777.                pstacklev--;
  778.                lineptr=prog[ppc].line+1+(c!=0);
  779.                chkend=1;                        /* do check for linend char */
  780.                break;
  781.             case OPTIONS: /* Split the option into tokens and call setoption */
  782.                tmpchr=0,
  783.                exp=scanning(lineptr,&tmpchr,&len),
  784.                lineptr+=tmpchr;
  785.                while(len){
  786.                   while(len&&*exp==' ')exp++,len--;
  787.                   if(!len)break;
  788.                   tmpptr=exp;
  789.                   while(len&&*exp!=' ')exp++,len--;
  790.                   setoption(tmpptr,exp-tmpptr);
  791.                }
  792.                break;
  793.             case PARSE: up=0;
  794.                if(*lineptr == UPPER)lineptr++,up=1;/* up="upper case?" */
  795.                i=1;                         /* one argument to parse usually */
  796. /* Depending on the next keyword, copy the appropriate data into parselist[]
  797.    and parselen[], setting i to the number of strings */
  798.                switch(lineptr++[0]){
  799.                   case ARG: for(i=0;args[i]!=cnull;i++){
  800.                             parselist[i]=args[i];
  801.                             if((parselen[i]=arglen[i])<0)parselen[i]=0;
  802.                      }
  803.                      break;
  804.                   case SOURCE: parselist[0]=psource,
  805.                      parselen[0]=strlen(psource);
  806.                      break;
  807.                   case PULL: /* first try the REXX data stack */
  808.                      if(write(rxstacksock,"G",1)<1)die(Esys);
  809.                      if(read(rxstacksock,pull,7)<7)die(Esys);
  810.                      if(memcmp(pull,"FFFFFF",6)){
  811.                         sscanf(pull,"%x",&l);
  812.                         mtest(pull,pulllen,l,l-pulllen);
  813.                         sllen=0;
  814.                         while(sllen<l)
  815.                            if((s=read(rxstacksock,pull,l))<1)die(Esys);
  816.                            else sllen+=s;
  817.                      }
  818.                      else if(exitlist[RXSIO]){ /* then try RXSIOTRD */
  819.                         RXSIOTRD_PARM inp;
  820.                         MAKERXSTRING(inp.rxsiotrd_retc,exitbuff,RXRESULTLEN);
  821.                         if(exitcall(RXSIO,RXSIOTRD,&inp)==RXEXIT_NOT_HANDLED)
  822.                            goto case_LINEIN; /* ugh! */
  823.                         parselist[0]=inp.rxsiotrd_retc.strptr;
  824.                         parselen[0]=inp.rxsiotrd_retc.strlength;
  825.                         if(parselist[0]!=exitbuff){
  826.                            /* string was user allocated.  Move it and free the
  827.                               storage. */
  828.                            stack(parselist[0],parselen[0]);
  829.                            free(parselist[0]);
  830.                            parselist[0]=delete(&parselen[0]);
  831.                         }
  832.                         break;
  833.                      }
  834.                      else{  /* then try an input line */
  835.                   case_LINEIN:
  836.                   case LINEIN: /* mirrors the linein() function */
  837.                         if(!(info=(struct fileinfo *)hashget(1,"stdin",&l))){
  838.                            /* If it was closed by the user, signal on notready
  839.                               or else just use an empty string */
  840.                            rcset(Eeof,Enotready,"stdin");
  841.                            l=0;
  842.                         }else{
  843.                            if(info->lastwr==0&&(filepos=ftell(info->fp))>=0&&filepos!=info->rdpos)
  844.                               info->rdpos=filepos,
  845.                               info->rdline=0; /* position has been disturbed */
  846.                            clearerr(info->fp);
  847.                            if(info->lastwr)fseek(info->fp,info->rdpos,0);
  848.                            info->lastwr=0;
  849.                            c=sgstack[interplev].callon&(1<<Ihalt) |
  850.                              sgstack[interplev].delay &(1<<Ihalt);
  851.                            if(!c)siginterrupt(2,1);
  852.                            l=0;
  853.                            while((s=getc(info->fp))!=EOF&&s!='\n'){
  854.                               mtest(pull,pulllen,l+1,256);
  855.                               pull[l++]=s;
  856.                            }
  857.                            siginterrupt(2,0);
  858.                            if(delayed[Ihalt] && !c)
  859.                               delayed[Ihalt]=0,
  860.                               fseek(info->fp,info->rdpos,0),   /* reset to */
  861.                               die(Ehalt);    /* start of line, if possible */
  862.                            if(info->rdline)info->rdline++;
  863.                            info->rdchars=0;
  864.                            if(s==EOF&&!l)rxseterr(info);
  865.                            if((info->rdpos=ftell(info->fp))<0)info->rdpos=0;
  866.                            if(info->errnum || setrcflag)rcset(info->errnum-Eerrno,Enotready,"stdin");
  867.                         }
  868.                      }
  869.                      parselist[0]=pull,
  870.                      parselen[0]=l;
  871.                      break;
  872.                   case VALUE: i=0;
  873.                      if(*lineptr==WITH)parselist[0]="",parselen[0]=0;
  874.                      else while(1){
  875.                         tmpchr=0,
  876.                         parselist[i]=scanning(lineptr,&tmpchr,&parselen[i]),
  877.                         lineptr+=tmpchr;
  878.                         if((c= *lineptr)== WITH)break;
  879.                         if(c!=','||i==maxargs)die(Eparse);
  880.                         while(*lineptr==',')lineptr++,parselist[++i]="",
  881.                            parselen[i]=0;
  882.                      }
  883.                      i++,
  884.                      lineptr++;
  885.                      break;
  886.                   case VAR: tmpchr=0,
  887.                      getvarname(lineptr,&tmpchr,varname,&varlen,maxvarname);
  888.                      lineptr+=tmpchr;
  889.                      if(varname[0]==0)die(Enosymbol);
  890.                      if((exp=varget(varname,varlen,&parselen[0]))==cnull){
  891.                         if((varname[0]&128)&&!memchr(varname,'.',varlen))
  892.                            varname[varlen++]='.'; /* Add dot to a stem */
  893.                         varname[0]&=127;
  894.                         varname[varlen]=0;
  895.                         if(sgstack[interplev].bits&(1<<Inovalue))
  896.                            errordata=varname,
  897.                            die(Enovalue);   /* A novalue error was caught */
  898.                         parselist[0]=varname,
  899.                         parselen[0]=strlen(varname);
  900.                      }
  901.                      else{/* Copy the variable's value to pull.  We can't
  902.                              use the value pointer itself because that might
  903.                              move while the template is being interpreted */
  904.                         mtest(pull,pulllen,parselen[0],parselen[0]-pulllen);
  905.                         memcpy(parselist[0]=pull,exp,parselen[0]);
  906.                      }
  907.                      break;
  908.                   case VERSION: parselist[0]=version,
  909.                      parselen[0]=strlen(version);
  910.                      break;
  911.                   case NUMERIC: /* Make details [len(pull)>25] */
  912.                      sprintf(pull,"%d %d %s",precision,fuzz-precision,
  913.                         numform?"ENGINEERING":"SCIENTIFIC");
  914.                      parselist[0]=pull,
  915.                      parselen[0]=strlen(pull);
  916.                      break;
  917.                   default: die(Eform); /* an invalid subkeyword was found */
  918.                }
  919.                parselist[i]=cnull;     /* terminate the list */
  920. /* Now would be a good time to uppercase, I think... */
  921.                if(*lineptr)                   /* if a template supplied, */
  922.                   tmpchr=0,
  923.                   parse(parselist,parselen,up,lineptr,&tmpchr),
  924.                   lineptr+=tmpchr;
  925.                break;
  926.             case EXIT: /* Get the value if any and jump back to the outermost
  927.                        level of interpretation in the current program. */
  928.                if(*lineptr){
  929.                   tmpchr=0;
  930.                   returnval=scanning(lineptr,&tmpchr,&returnlen);
  931.                   if(c=lineptr[tmpchr])die(Edata);
  932.                   returnfree=cstackptr;  /* this way the result doesn't get */
  933.                   cstackptr=allocm(cstacklen=returnlen+16);
  934.                                          /* destroyed if the calc stack is  */
  935.                                          /* freed by the following code     */
  936.                }
  937.                else returnval=0;
  938.                while(pstacklev){
  939.                   stype=unpstack();
  940.                   /* delete every program stack entry until an external call */
  941.                   if(!prog[ppc].num) /* if an error occurs during INTERPRET, */
  942.                      ppc=newppc;               /* blame the INTERPRET instr. */
  943.                   freestack(delpstack(),stype);
  944.                }
  945.                longjmp(sgstack[interplev].jmp,-1);
  946.             case RETURN: /* Just return, with the given value if any */
  947.                if(*lineptr){
  948.                   tmpchr=0;
  949.                   scanning(lineptr,&tmpchr,&len);
  950.                   if(c=lineptr[tmpchr])die(Edata);
  951.                   return delete(anslen);
  952.                }
  953.                if(calltype==RXFUNCTION)die(Ereturn);
  954.                return anslen[0]=0,cnull;
  955.             case CALL:
  956.                if((c= *lineptr)==ON||c==OFF){ /* set or clear a trap */
  957.                   findsigl(&istart);            /* find the start level */
  958.                   prog=oldprog,stmts=oldstmts;  /* number to affect */
  959.                   i=gettrap(&lineptr,c==ON,&l); /* Get the trap name */
  960.                   if(i==Isyntax||i==Inovalue)die(Etrap);
  961.                   if(c==ON){
  962.                      if(!l)
  963.                         if(prog[ppc].num)l=-ppc;
  964.                         else
  965.                            sprintf(workptr,": \'%s\'",varnamebuf),
  966.                            errordata=workptr,
  967.                            die(Elabel);
  968.                      for(e=istart;e<=interplev;e++)
  969.                         sgstack[e].bits   &=~(1<<i),
  970.                         sgstack[e].bitson &=~(1<<i),
  971.                         sgstack[e].delay  &=~(1<<i),
  972.                         sgstack[e].callon |= (1<<i),
  973.                         sgstack[e].ppc[i]=l;
  974.                   }
  975.                   else for(l=istart;l<=interplev;l++)
  976.                      sgstack[l].bits   &=~(1<<i),
  977.                      sgstack[l].bitson &=~(1<<i),
  978.                      sgstack[l].delay  &=~(1<<i),
  979.                      sgstack[l].callon &=~(1<<i);
  980.                   break;
  981.                }
  982.                tmpchr=0,          /* get details, then call rxcall() */
  983.                z=gettoken(lineptr,&tmpchr,varname,maxvarname,0)-1;
  984.                lineptr+=tmpchr;
  985.                /* so varname holds the routine name, z=0 if it wasn't quoted */
  986.                i=m=0;             /* i=arg count; m=last character was comma */
  987.                if(*lineptr==' ')
  988.                   lineptr++;                  /* A space may follow the name */
  989.                while(c= *lineptr){                 /* now loop for arguments */
  990.                   if(c==',')stacknull();
  991.                   else tmpchr=0,scanning(lineptr,&tmpchr,&len),lineptr+=tmpchr;
  992.                   i++;
  993.                   if(m=(*lineptr==','))lineptr++;
  994.                }
  995.                if(m)stacknull(),i++;
  996.                doconds();            /* Before calling, check for conditions */
  997.                if(rxcall(0,varname,i,z,RXSUBROUTINE)) /* call it */
  998.                   exp=delete(&len),     /* a result was given, so set RESULT */
  999.                   varset("RESULT",6,exp,len);
  1000.                else varset("RESULT",6,cnull,-1); /* no result, so drop RESULT*/
  1001.                timeflag&= (~2); /* in case of "call time" don't make a lasting
  1002.                                    timestamp */
  1003.                break;
  1004.             case SIGNAL:
  1005.                /* go down stack to find l=most recent nonzero line no */
  1006.                l=findsigl(&istart);
  1007.                prog=oldprog,stmts=oldstmts;
  1008.                if((c= *lineptr)==ON||c==OFF){   /* set or clear a trap */
  1009.                   i=gettrap(&lineptr,c==ON,&l); /* Get the trap name */
  1010.                   if(c==ON){
  1011.                      if(!l)
  1012.                         if(prog[ppc].num)l=-ppc; /* flag the stmt in error */
  1013.                         else
  1014.                            sprintf(workptr,": \'%s\'",varnamebuf),
  1015.                            errordata=workptr,
  1016.                            die(Elabel);        /* die if we are interpreted*/
  1017.                      sgstack[istart].ppc[i]=l;
  1018.                      sgstack[istart].bitson |=(1<<i);
  1019.                      for(l=istart;l<=interplev;l++)
  1020.                         sgstack[l].bits   |= (1<<i),
  1021.                         sgstack[l].callon &=~(1<<i),
  1022.                         sgstack[l].delay  &=~(1<<i);
  1023.                   }
  1024.                   else for(l=istart;l<=interplev;l++)
  1025.                      sgstack[l].bits   &= ~(1<<i),
  1026.                      sgstack[l].bitson &= ~(1<<i),
  1027.                      sgstack[l].callon &= ~(1<<i),
  1028.                      sgstack[l].delay  &= ~(1<<i);
  1029.                   break;
  1030.                } /* else signal to a given label name. Get the name, set the
  1031.                     source line number and clear the machine stack first */
  1032.                tmpchr=0;
  1033.                gettoken(lineptr,&tmpchr,varname,maxvarname,1);
  1034.                signalto=varname;
  1035.                if(lineptr[tmpchr])die(Edata);
  1036.                doconds();            /* Before going, check for conditions */
  1037.                ppc=l;
  1038.                if(istart!=interplev) /* Clear the stack if necessary */
  1039.                   longjmp(sgstack[istart].jmp,2);
  1040.                /* Code to transfer control to a label starts here */
  1041. signal:        while(pstacklev&&((stype=unpstack())<11||stype>13))
  1042.                   freestack(delpstack(),stype);
  1043.                   /* quit all current DO, SELECT, INTERPRET constructs */
  1044.                for(lptr=(int *)labelptr;
  1045.                   (l= *lptr)&&strcasecmp(signalto,(char *)(lptr+2));
  1046.                   lptr+=2+align(l+1)/four);
  1047.                if(!l) /* the label wasn't found */
  1048.                   sprintf(workptr,": \'%s\'",signalto),
  1049.                   errordata=workptr,
  1050.                   die(Elabel);  
  1051.                /* before jumping, save current ppc in variable SIGL */
  1052.                sprintf(varname,"%d",prog[ppc].num),
  1053.                varset("SIGL",4,varname,strlen(varname)),
  1054.                ppc=lptr[1],
  1055.                chkend=0;
  1056.                break;
  1057.             case ITERATE: /* Find the END and jump to it */
  1058.                tmpchr=epstackptr,
  1059.                istart=pstacklev,
  1060.                sllen=1;
  1061.                if (c= *lineptr){
  1062.                   if(rexxsymbol(c)<1)die(Enosymbol);
  1063.                   varref=lineptr;
  1064.                   reflen=0;
  1065.                   skipvarname(lineptr,&reflen);
  1066.                   if(c=lineptr[reflen])die(Edata);
  1067.                }
  1068.                else {
  1069.                   reflen=0;
  1070.                   if(*lineptr)
  1071.                      die(Enosymbol);/* symbol expected; we got something else*/
  1072.                }
  1073.                /* so (varref,reflen) is a control variable or a null string */
  1074.                while(1){ /* delete stack items until the right loop found. The
  1075.                          number of ENDs needed is counted in sllen */
  1076.                   while(pstacklev&&(stype=unpstack())<8) /* not a loop */
  1077.                      delpstack(),sllen++;
  1078.                   if(!pstacklev||stype>10&&stype!=15) /* function call */
  1079.                      epstackptr=tmpchr,pstacklev=istart,
  1080.                      die(Eleave); /* so the required loop is not active */
  1081.                   if(stype==8||stype==15) /* un-named DO loop */
  1082.                      if(!reflen)break;    /* OK if no name found */
  1083.                      else {delpstack(),sllen++;continue;}
  1084.                   /* otherwise the top stack entry is a DO with variable */
  1085.                   svar=pstackptr+epstackptr-4*four,
  1086.                   svar -= align(len= *(int *)svar); /* point to the name */
  1087.                   if(!(reflen&&(len-1!=reflen||memcmp(varref,svar,reflen))))
  1088.                      break; /* the correct DO loop has been found */
  1089.                   sllen++,delpstack();
  1090.                }
  1091.                stype= *((int *)(pstackptr+epstackptr)-1); /* the type of loop
  1092.                                                              being iterated */
  1093.                while(sllen--){ /* find the right number of ENDs */
  1094.                   findend();
  1095.                   if(sllen)
  1096.                      if(++ppc==stmts)die(Enoend);
  1097.                }
  1098.                /* now test the name following the END */
  1099.                if(stype==10){
  1100.                   svar=pstackptr+epstackptr-4*four,
  1101.                   svar -= align(len= *(int *)svar);
  1102.                   lineptr=prog[ppc].line+1;
  1103.                   testvarname(&lineptr,svar,len-1);
  1104.                }
  1105.                else if (c=prog[ppc].line[1])die(Edata);
  1106.                chkend=0;      /* Already at the start of a statement */
  1107.                break;
  1108.             case LEAVE: /* LEAVE is essentially the same as ITERATE, but it
  1109.                         goes past the END after finding it */
  1110.                tmpchr=epstackptr,
  1111.                istart=pstacklev,
  1112.                sllen=1;
  1113.                if (c= *lineptr){
  1114.                   if(rexxsymbol(c)<1)die(Enosymbol);
  1115.                   varref=lineptr;
  1116.                   reflen=0;
  1117.                   skipvarname(lineptr,&reflen);
  1118.                   if(c=lineptr[reflen])die(Edata);
  1119.                }
  1120.                else {
  1121.                   reflen=0;
  1122.                   if(*lineptr)die(Enosymbol);
  1123.                }
  1124.                while(1){
  1125.                   while(pstacklev&&((stype=unpstack())<8))
  1126.                      delpstack(),sllen++;
  1127.                   if(!pstacklev||stype>10&&stype!=15)
  1128.                      epstackptr=tmpchr,pstacklev=istart,
  1129.                      die(Eleave);
  1130.                   if(stype==8||stype==15)
  1131.                      if(!reflen)break;
  1132.                      else {delpstack(),sllen++;continue;}
  1133.                   svar=pstackptr+epstackptr-4*four,
  1134.                   svar -= align(len= *(int *)svar);
  1135.                   if(!(reflen&&(len-1!=reflen||memcmp(varref,svar,reflen))))
  1136.                      break;
  1137.                   sllen++,delpstack();
  1138.                }
  1139.             leaveit: /* find the "sllen"th END and jump past it */
  1140.                if(ppc+1==stmts)die(Enoend); /* Get past the LEAVE or, more */
  1141.                ppc++;                       /* importantly, the DO */
  1142.                stype= *((int *)(pstackptr+epstackptr)-1);
  1143.                while(sllen--){
  1144.                   findend();
  1145.                   if(sllen)
  1146.                      if(++ppc==stmts)die(Enoend);
  1147.                }
  1148.                lineptr=prog[ppc].line+1;
  1149.                if(stype==10){ /* test the name given after END */
  1150.                   svar=pstackptr+epstackptr-4*four,
  1151.                   svar -= align(len= *(int *)svar);
  1152.                   testvarname(&lineptr,svar,len-1);
  1153.                }
  1154.                else if (c= *lineptr)die(Edata);
  1155.                delpstack(); /* delete stack entry and continue past the END */
  1156.             case LABEL:     /* same as NOP */
  1157.             case NOP: break;/* do nothing, like it says... */
  1158.             case INTERPRET: /* Get the details and call rxinterp */
  1159.                tmpchr=0;
  1160.                exp=scanning(lineptr,&tmpchr,&len);
  1161.                lineptr+=tmpchr;
  1162.                if(trcflag&Tclauses){ /* trace the interpret data */
  1163.                   traceprefix(prog[ppc].num,"*~*");
  1164.                   for(i=0;i<traceindent*pstacklev;i++)tracechar(' ');
  1165.                   traceput(exp,len);
  1166.                   tracechar('\n');
  1167.                }
  1168.                exp=rxinterp(exp,len,anslen,callname,calltype,args,arglen);
  1169.                if(*anslen>=0)
  1170.                   return exp; /* "interpret 'return x'" causes x to be returned
  1171.                               from rxinterp.  Convey it back to the caller */
  1172.                break;
  1173.             case PROCEDURE: /* Make a new variable table, then examine the
  1174.                             instruction and copy or hide variables */
  1175.                if(epstackptr && *((int *)(pstackptr+epstackptr)-1)==11){
  1176.                   /* inside internal function: */
  1177.                   /* signal that PROCEDURE has been done */
  1178.                   (*((int *)(pstackptr+epstackptr)-1))++;
  1179.                   newlevel(); /* Make a complete new level of variables */
  1180.                }
  1181.                else if(epstackptr || !varstkptr || !exposeflag)
  1182.                   /* not inside a function or no 'options expose' */
  1183.                   die(Eprocedure);
  1184.                if (!(c= *lineptr))
  1185.                   break;   /* OK if no further data follows */
  1186.                lineptr++;
  1187.                i=1; /* i.e. start of data */
  1188.                if(c==EXPOSE){ /* Expose all the given variables with varcopy */
  1189.                   while(i||(c= *lineptr)==' '||c=='('){
  1190.                      if(!i&&c!='(')lineptr++; /* step over the space */
  1191.                      i=0;
  1192.                      if((c=*lineptr)=='(')lineptr++;
  1193.                      tmpchr=0;
  1194.                      getvarname(lineptr,&tmpchr,varname,&varlen,maxvarname);
  1195.                      lineptr+=tmpchr;
  1196.                      if(!varname[0])die(Enosymbol);
  1197.                      varcopy(varname,varlen);
  1198.                      if(c=='('){             /* Expose a list of variables */
  1199.                         if(lineptr++[0]!=')')die(Elpar);
  1200.                         if((c=*lineptr)&&c!=' ')
  1201.                                   /* space is not required, */
  1202.                            i=1;   /* but if omitted remember not to skip it */
  1203.                         exp=varget(varname,varlen,&len);
  1204.                         tmpchr=0; /* prepare to parse the list of symbols */
  1205.                         if(exp&&len>0){
  1206.                            mtest(workptr,worklen,len+1,len-worklen+1);
  1207.                            for(c=0,l=0;l<len;l++){ /* copy the list in uc */
  1208.                               if(!c&&((c2=exp[l])=='\''||c2=='\"'))c=c2;
  1209.                               else if((c2=exp[l])==c)c=0; /* c is quote flag */
  1210.                               workptr[l]=c?c2:uc(c2); /* uppercase and copy */
  1211.                            }
  1212.                            if(c)die(Equote);
  1213.                            workptr[len]=0;          /* Now add a terminator */
  1214.                            while(l||workptr[tmpchr]==' '){
  1215.                               if(!l)tmpchr++; /* step over the space */
  1216.                               l=0;
  1217.                               getvarname(workptr,&tmpchr,varname,&varlen,maxvarname);
  1218.                               if(!varname[0])die(Enosymbol);
  1219.                               varcopy(varname,varlen);
  1220.                            } /* should now have reached the end of the list */
  1221.                            if(tmpchr!=len)die(Enosymbol);
  1222.                         }
  1223.                      }
  1224.                   }
  1225.                }
  1226.                else if(c!= HIDE)die(Eform); /* invalid subkeyword */
  1227.                else { /* Copy the entire variable table, then delete the */
  1228.                   vardup(); /* named variables with vardel */
  1229.                   while(i||(c= *lineptr)==' '){
  1230.                      if(!i)lineptr++;
  1231.                      i=0;
  1232.                      tmpchr=0;
  1233.                      getvarname(lineptr,&tmpchr,varname,&varlen,maxvarname);
  1234.                      lineptr+=tmpchr;
  1235.                      if(!varname[0])die(Enosymbol);
  1236.                      vardel(varname,varlen);
  1237.                   }
  1238.                }
  1239.             break;
  1240.             case NUMERIC: /* get parameter, and set global variable */
  1241.                tmpchr=0;
  1242.                if((c=lineptr++[0])==FORM){
  1243.                   gettoken(lineptr,&tmpchr,varname,maxvarname,1);
  1244.                   lineptr+=tmpchr;
  1245.                   if(!strcmp(varname,"SCIENTIFIC"))numform=0;
  1246.                   else if(!strcmp(varname,"ENGINEERING"))numform=1;
  1247.                   else die(Eform); /* invalid subkeyword */
  1248.                   break;
  1249.                }
  1250.                if(c>0)die(Eform); /* a word must follow, not characters */
  1251.                if(c>=-1)die(Enosymbol); /* nothing followed */
  1252.                scanning(lineptr,&tmpchr,&len), /* an integer must follow */
  1253.                lineptr+=tmpchr;
  1254.                i=getint(1);
  1255.                if(i<0||i>maxdigits)die(Erange);
  1256.                if(c==DIGITS)
  1257.                   if(!i)die(Erange);
  1258.                   else precision=i,fuzz=i;
  1259.                else if(c== FUZZ){
  1260.                   if((i=precision-i)<1)die(Erange);
  1261.                   fuzz=i;
  1262.                }
  1263.                else die(Eform); /* invalid subkeyword */
  1264.                break;
  1265.             case THEN: /* can't have THEN in the middle of a program */
  1266.                die(Ethen);
  1267.             case TRACE: /* Get the data and set trcflag as appropriate */
  1268.                tmpchr=0;
  1269.                if(*lineptr)gettoken(lineptr,&tmpchr,varname,maxvarname,1),
  1270.                lineptr+=tmpchr;
  1271.                else varname[0]=0;
  1272.                if(!(trcflag&Tinteract)&&interact<0 ||
  1273.                    (interact==interplev-1 && interact>=0)){
  1274.                      /* if interactive trace is on, do not
  1275.                      interpret any trace instruction except in the actual
  1276.                      command.  Moreover, use the saved trace flag as the
  1277.                      initial value of trcflag. This trace instruction makes
  1278.                      the program continue operating (trclp=0). */
  1279.                   if (interact>=0)trclp=0,trcflag=otrcflag;
  1280.                   settrace(varname);
  1281.                }
  1282.                break;
  1283.             case DROP: /* Go along the list, setting each variable to a null */
  1284.                i=1;    /* value (with length -1).  varset() does the DROP.   */
  1285.                while(i||(c=*lineptr)==' '||c=='('){
  1286.                   if(!i&&c!='(')lineptr++;
  1287.                   i=0;
  1288.                   if((c= *lineptr)=='(')lineptr++;
  1289.                   tmpchr=0;
  1290.                   getvarname(lineptr,&tmpchr,varname,&varlen,maxvarname);
  1291.                   lineptr+=tmpchr;
  1292.                   if(!varname[0])die(Enosymbol);
  1293.                   if(c=='('){  /* drop a list of variables */
  1294.                      if(lineptr++[0]!=')')die(Elpar);
  1295.                      if((c= *lineptr)&&c!=' ')
  1296.                                /* space is not required, */
  1297.                         i=1;   /* but if omitted remember not to skip it */
  1298.                      exp=varget(varname,varlen,&len);
  1299.                      tmpchr=0; /* prepare to parse the list of symbols */
  1300.                      if(exp&&len>0){
  1301.                         mtest(workptr,worklen,len+1,len-worklen+1);
  1302.                         for(c=0,l=0;l<len;l++){ /* copy the list in uc */
  1303.                            if(!c&&((c2=exp[l])=='\''||c2=='\"'))c=c2;
  1304.                            else if((c2=exp[l])==c)c=0; /* c is quote flag */
  1305.                            workptr[l]=c?c2:uc(c2); /* uppercase and copy */
  1306.                         }
  1307.                         if(c)die(Equote);
  1308.                         workptr[len]=0;          /* Now add a terminator */
  1309.                         while(l||workptr[tmpchr]==' '){
  1310.                            l=0;
  1311.                            while(workptr[tmpchr]==' ')tmpchr++;
  1312.                            getvarname(workptr,&tmpchr,varname,&varlen,maxvarname);
  1313.                            if(!varname[0])die(Enosymbol);
  1314.                            varset(varname,varlen,cnull,-1);
  1315.                         } /* should now have reached the end of the list */
  1316.                         if(tmpchr!=len)die(Enosymbol);
  1317.                      }                     
  1318.                   }/* don't remove the following "else" */
  1319.                   else varset(varname,varlen,cnull,-1);
  1320.                }
  1321.                break;
  1322.             case ADDRESS: /* Get parameter; perhaps follwed by a command */
  1323.                if(*lineptr){ /* Something follows... */
  1324.                   tmpchr=0;
  1325.                   i=gettoken(lineptr,&tmpchr,varname,maxvarname,1);
  1326.                   lineptr+=tmpchr;
  1327.                   if(strlen(varname)>maxenviron)die(Elong);
  1328.                   env=envsearch(varname);
  1329.                   if(env<0)die(Emem);
  1330.                }
  1331.                else i=-1;
  1332.                if(*lineptr==' ')
  1333.                   lineptr++;   /* environment may be followed by a space */
  1334.                if(!*lineptr){                    /* Permanent env change */
  1335.                   l=address1,address1=address2,address2=l;/* Swap buffers */
  1336.                   if(i>=0)address1=env;          /* Copy given value */
  1337.                   break;
  1338.                }
  1339.                if(!i)break;     /* Error: No command follows "ADDRESS VALUE" */
  1340.                doaddress(&lineptr,env);    /* Do the following command
  1341.                                               in given environment */
  1342.                break;
  1343.             case PUSH: /* PUSH and QUEUE communicate with the stack.  The */
  1344.                        /* only difference between them is the command     */
  1345.                        /* letter: Q for QUEUE and S for PUSH.  We just    */
  1346.                        /* get the data to be stacked and write the        */
  1347.                        /* command, length and data down the socket.       */
  1348.                c='S';goto stack;
  1349.             case QUEUE:c='Q';
  1350.             stack: if(!*lineptr)len=0;
  1351.                else
  1352.                   tmpchr=0,
  1353.                   exp=scanning(lineptr,&tmpchr,&len),
  1354.                   lineptr+=tmpchr;
  1355.                sprintf(pull,"%c%06X\n",c,len);
  1356.                if(write(rxstacksock,pull,8)<8||
  1357.                   (len>0&&write(rxstacksock,exp,len)<len)) die(Esys);
  1358.                break;
  1359.             /* Anything else is a syntax error.  However, under normal
  1360.             circumstances we should never get here. */
  1361.             default:die(Esyntax);
  1362.          }
  1363.          else{ /* The instruction starts with a printable character.  Try an
  1364.                assignment, and then a command to the environment. */
  1365.             varname[0]=0;
  1366.             if(rexxsymbol(c= *lineptr)==1){       /* the character is the */
  1367.                tmpchr=0,                          /* start of a symbol    */
  1368.                getvarname(lineptr,&tmpchr,varname,&l,maxvarname);
  1369.                if(lineptr[tmpchr]=='=')    /* it is an assignment if the  */
  1370.                   tmpchr++,                /* next character is '='       */
  1371.                   exp=scanning(lineptr,&tmpchr,&len),
  1372.                   lineptr+=tmpchr,
  1373.                   varset(varname,l,exp,len);
  1374. /*             else if(curline[tmpchr]==EQU)die(Eassign); / * a == value */
  1375.                else varname[0]=0;
  1376.             } /* Next, if the character is not the start of a symbol, but is
  1377.             valid inside a symbol (i.e. a digit or dot), check to see whether
  1378.             it is an invalid assignment of the form 3=2+2 and reject if so. */
  1379. /*          else if(rexxsymboldot(c)){
  1380.                for(tmpchr=curchr;rexxsymboldot(curline[++tmpchr]););
  1381.                if(curline[tmpchr]=='=')die(Ename);
  1382.             } */
  1383.             /* Finally, if no assignment was found it must be a command */
  1384.             if(!varname[0]) doaddress(&lineptr,address1);
  1385.          }
  1386. /* End of processing for each clause.  Now if chkend is set, we need to check
  1387.    for a clause terminator and step to the next statement. If chkend is not
  1388.    set, we are already pointing to the next clause. */
  1389.       doconds();  /* Test and carry out any signals */
  1390.       if(chkend){
  1391.          if(c= *lineptr)die(Edata);  /* if end-of-line not found, error */
  1392.          if(trcflag&Tclauses)printstmt(ppc,1,0); /* Trace intervening comments */
  1393.          ppc++;
  1394.       }
  1395.    }
  1396.    return anslen[0]=-1,cnull; /* End of program, so return */
  1397. }
  1398. static void doaddress(lineptr,env) /* The lineptr points to a command to be */
  1399. char **lineptr;                    /* executed in an environment */
  1400. int env;
  1401. {
  1402.    char *cmd;
  1403.    char *cmdcopy;
  1404.    char *ans;
  1405.    int anslen;
  1406.    int len;
  1407.    int i;
  1408.    int code;
  1409.    if(trcflag&Tcommands)/* trace command before interpretation */
  1410.       printstmt(ppc,0,0);
  1411.    i=0;   
  1412.    cmdcopy=scanning(*lineptr,&i,&len); /* get a copy of the command for later*/
  1413.    anslen=cmdcopy-cstackptr;
  1414.    rxdup();
  1415.    cmdcopy=anslen+cstackptr;
  1416.    cmd=delete(&len);                   /* get the command */
  1417.    cmdcopy[len]=0;
  1418.    (*lineptr)+=i;
  1419.    if(   (trcflag&Tcommands)||  /* trace command before execution */
  1420.          (trcflag&~Tinteract)==(Tclauses|Tlabels)){
  1421.       traceprefix(prog[ppc].num,"*~*");
  1422.       for(i=0;i<traceindent*pstacklev;i++)tracechar(' ');
  1423.       traceput(cmd,len);
  1424.       tracechar('\n');
  1425.       interactive();
  1426.    }
  1427.    code=envcall(env,cmd,len,&ans,&anslen);
  1428.    if(   (code==Efailure&&(trcflag&Tfailures))||      /* Trace return code */
  1429.          (code&&(trcflag&(Tclauses|Terrors|Tcommands)))){
  1430.       if(!(trcflag&(Tcommands|Tclauses)))printstmt(ppc,0,0);
  1431.       tracestr("      +++ RC=");
  1432.       traceput(ans,anslen);
  1433.       tracestr(" +++\n");
  1434.       interactive();
  1435.    }
  1436.    rcstringset(code,ans,anslen,code,cmdcopy);  /* set RC unless this is an interactive command */
  1437. }
  1438. /* The arglist (each argument i of length arglen[i]) is parsed by the template
  1439.    written at line+ptr */
  1440. static void parse(arglist,arglen,up,line,ptr)
  1441. char *arglist[]; /* The list of strings to be parsed, ending with NULL */
  1442. int arglen[];    /* The lengths of all those strings */
  1443. int up;          /* whether UPPER was specified */
  1444. char *line;      /* The start of the line containing the parse template */
  1445. int *ptr;        /* The current character pointer positioned at the template */
  1446. {
  1447.    char *srch;        /* A string to search for */
  1448.    int srchlen;       /* The length of the search string */
  1449.    int i=0;           /* Which string is being parsed */
  1450.    int j;             /* The current position within the string (0-based) */
  1451.    int l;             /* The length of the string being parsed */
  1452.    int lastexpr;      /* The start position of the last expression */
  1453.    int startvar,lenvar; /* The position of a variable list */
  1454.    int k,m1,e1,z1,l1,pos;
  1455.    char c;
  1456.    while(1) {         /* loop for each template separated by commas */
  1457.       if(arglist[i]==cnull) /* no strings left, so parse a null string */
  1458.          l=0;
  1459.       else l=arglen[i]; /* l holds the string length */
  1460.       j=0;
  1461.       lastexpr=-1;
  1462.       while(1){
  1463.          if(line[*ptr]==' ')++*ptr; /* A space may separate the previous piece
  1464.                                        of template from the next */
  1465.          startvar=*ptr; /* collect space-separated list of symbols or dots */
  1466.          while(rexxsymbol(c=line[*ptr])==1
  1467.                || c=='.'&&!rexxsymboldot(line[*ptr+1])){
  1468.             if(c!='.')skipvarname(line,ptr);
  1469.             else (*ptr)++;
  1470.             if(line[*ptr]==' ')++*ptr;
  1471.          }
  1472.          lenvar=*ptr-startvar; /* we now have the list stored for later */
  1473.          if(c<=0||c==','){ /* parse rest of line */
  1474.             pset1(line+startvar,lenvar,arglist[i]+j,l-j,up);
  1475.             break;
  1476.          }
  1477.          if(c=='('){   /* parse expression */
  1478.             (*ptr)++,
  1479.             srch=scanning(line,ptr,&srchlen);
  1480.             if(line[(*ptr)++]!=')')die(Elpar);
  1481.          }
  1482.          else if(c=='\''||c=='\"'){  /* parse string literal */
  1483.             srch=line+ ++(*ptr);
  1484.             while(line[(*ptr)++]!=c||line[*ptr]==c)
  1485.                   if(line[*ptr-1]==c)(*ptr)++; /* search for close quote */
  1486.             srchlen= (*ptr+line)-srch-1;
  1487.             /* Stack the string, whether hex, binary or ordinary */
  1488.             if(line[*ptr]=='X'&&!rexxsymboldot(line[*ptr+1]))
  1489.                stackx(srch,srchlen),
  1490.                (*ptr)++;
  1491.             else if(line[*ptr]=='B'&&!rexxsymboldot(line[*ptr+1]))
  1492.                stackb(srch,srchlen),
  1493.                (*ptr)++;
  1494.             else stackq(srch,srchlen,c);
  1495.             srch=delete(&srchlen);
  1496.          }
  1497.          else { /* parse numeric. c holds the sign (+,-,=) if any. Stack the
  1498.             number; leave srchlen positive or else get the integer in pos and
  1499.             leave srchlen negative */
  1500.             if((c=='+'||c=='-'||c=='=')&&line[++*ptr]=='('){
  1501.                ++*ptr;
  1502.                scanning(line,ptr,&srchlen);
  1503.                if(line[(*ptr)++]!=')')die(Elpar);
  1504.                pos=getint(1);
  1505.                srchlen= -1;
  1506.             }
  1507.             else{
  1508.                for(k= *ptr;rexxsymboldot(line[*ptr]);(*ptr)++);
  1509.                if(k== *ptr)die(Eparse);
  1510.                stack(srch=line+k,srchlen= *ptr-k);
  1511.             }
  1512.             if(c=='='||c=='+'||c=='-'||num(&m1,&e1,&z1,&l1)>=0){
  1513.             /* A number has now been found.  It is used as an absolute
  1514.             position, or an offset from the last position, or from the
  1515.             *start* of the previous search string */
  1516.                if(srchlen>=0)pos=getint(1); /* now pos holds the number */
  1517.                k=lastexpr>=0?lastexpr:j;    /* k holds the old position */
  1518.                if(c=='+')j=k,k+=pos;
  1519.                else if(c=='-')j=k,k-=pos;
  1520.                else k=pos-1; /* Absolute positions are 1-based, so decrement */
  1521.                if(k<0)k=0; /* Make sure position is within the line */
  1522.                if(k>l)k=l;
  1523.             /* Now, j holds the old position (i.e. start position), and k holds
  1524.             the new (i.e. stop position). */
  1525.                if(k<=j) /* parse from j to end of line */
  1526.                   pset1(line+startvar,lenvar,arglist[i]+j,l-j,up);
  1527.                else /* parse from j to k */
  1528.                   pset1(line+startvar,lenvar,arglist[i]+j,k-j,up);
  1529.                j=k; /* In each case now move to the new position */
  1530.                lastexpr=-1; /* No previous search string */
  1531.                continue;
  1532.             }
  1533.             else die(Eparse); /* A non-numeric symbol was found */
  1534.          } /* Now, a search string has been found, and it is stored in
  1535.            srch, and has length srchlen. */
  1536.          if(srchlen==0) /* The null string matches the end of the line. */
  1537.             k=l;
  1538.          else for(k=j;k<=l-srchlen;k++){ /* Do the search */
  1539.             for(l1=0;l1<srchlen&&uc1(arglist[i][k+l1],up)==srch[l1];l1++);
  1540.             if(l1==srchlen)break;
  1541.          }
  1542.          if(k>l-srchlen)k=l; /* not found, so move to end of line */
  1543.          pset1(line+startvar,lenvar,arglist[i]+j,k-j,up);
  1544.          if(k==l)j=k,lastexpr=-1;
  1545.          else j=k+srchlen,lastexpr=k; /* Move to end of string, but save the */
  1546.       }                               /* start position */
  1547.       /* End of loop: continue round if a comma is found, otherwise break. */
  1548.       if(line[*ptr]!=',')break;
  1549.       (*ptr)++;
  1550.       if (arglist[i]) i++;
  1551.    }
  1552. }
  1553. static char uc1(c,up) /* Return the uppercase of c, only if up is true. */
  1554. char c;
  1555. int up;
  1556. {
  1557.    if(up)return uc(c);
  1558.    return c;
  1559. }
  1560. /* parse a value with a space-separated list of names */
  1561. static void pset1(list,listlen,val,len,up) 
  1562. char *list;   /* A pointer to the list of names */
  1563. int listlen;  /* The length of the list of names */
  1564. char *val;    /* A pointer to the value */
  1565. int len;      /* The length of the value */
  1566. int up;       /* Whether to uppercase the value */
  1567. {
  1568.    static char varname[maxvarname]; /* For storing variable names */
  1569.    int varlen;                      /* The length of a variable name */
  1570.    int ptr;
  1571.    if(!listlen)return; /* No names - nothing to do */
  1572.    if(!len)val="";   /* protect against NULL values (omitted arguments) */
  1573.    while(listlen){
  1574.       varname[0]=varlen=ptr=0;
  1575.       if(list[0]!='.') /* Get the next name, unless we are at "." */
  1576.          getvarname(list,&ptr,varname,&varlen,maxvarname);
  1577.       else ptr++;
  1578.       if(list[ptr]==' ')ptr++;
  1579.       list+=ptr;       /* Step past the name just encountered */
  1580.       if(listlen-=ptr){ /* not end of name list: return first token stripped */
  1581.          while(len&&val[0]==' ')val++,len--;
  1582.          for(ptr=0;ptr<len&&val[ptr]!=' ';ptr++);
  1583.       }
  1584.       else ptr=len; /* return remains of string, unstripped */
  1585.       pset(varname,varlen,val,ptr,up);
  1586.       val+=ptr;
  1587.       if(len-=ptr)val++,len--;/* absorb one space if necessary */
  1588.    }
  1589. }
  1590. /* trace and assign a result from the parse command */
  1591. static void pset(varname,namelen,val,len,up)
  1592. char *varname; /* The name to assign to; varname[0]==0 if the name was "." */
  1593. int namelen;   /* The length of the name */
  1594. char *val;     /* The value to assign */
  1595. int len;       /* The length of the value */
  1596. int up;        /* Whether to uppercase */
  1597. {
  1598.    char *sp;                  /* Some work space */
  1599.    static char what[4]=">>>"; /* Trace message prefix */
  1600.    static char buff[255];     /* A fixed length workspace */
  1601.    int x;
  1602.    if(trcflag&(Tresults|Tintermed)){ /* Trace the result */
  1603.       what[1]=(varname[0]?'>':'.');
  1604.       if(!(up&&len))traceline(what,val,len);
  1605.       else{
  1606.          sp=allocm((unsigned)len);
  1607.          for(x=0;x<len;x++)sp[x]=uc(val[x]);
  1608.          traceline(what,sp,len);
  1609.          free(sp);
  1610.       }
  1611.    }
  1612.    if(varname[0]){    /* Assign, unless the name was "." */
  1613.       if(!(up&&len))  /* Straightforward, unless it needs to be uppercased */
  1614.          varset(varname,namelen,val,len);
  1615.       else{
  1616.          sp=(len<256?buff:allocm((unsigned)len));/* Make some space */
  1617.          for(x=0;x<len;x++)sp[x]=uc(val[x]);     /* Uppercase into the space */
  1618.          varset(varname,namelen,sp,len);         /* Assign the uppercase val */
  1619.          if(len>255)free(sp);                    /* Now free the space */
  1620.       }
  1621.    }
  1622. }
  1623. static int findsigl(level)/* Save the current program, go down stack to find */
  1624. int *level;        /* the most recent non-interpreted instruction, and       */
  1625. {                  /* store the proper program in "prog".  "level" gets the  */
  1626.                    /* interplev of this instruction.                         */
  1627.    int sigl;
  1628.    int instr;
  1629.    int type;
  1630.    int len;
  1631.    char *ptr;
  1632.    int eptr;
  1633.    int lev=interplev;
  1634.    oldprog=prog;
  1635.    oldstmts=stmts;
  1636.    sigl=prog[instr=ppc].num;
  1637.    for(ptr=pstackptr+(eptr=epstackptr);!sigl&&eptr;){
  1638.       type=*((int *)ptr-1);
  1639.       ptr-=(len= *((int *)ptr-2)); /* point to start of entry */
  1640.       eptr-=len;
  1641.       if(type==14)
  1642.          prog=((struct interpstack *)ptr)->prg,
  1643.          stmts=((struct interpstack *)ptr)->stmts,
  1644.          lev--;
  1645.       sigl=prog[instr=((struct minstack *)ptr)->stmt].num;
  1646.    }
  1647.    return *level=lev,instr;
  1648. }
  1649. /* This function deletes argc arguments from the current calculator
  1650.    stack and stores their addresses and lengths in the given arrays */
  1651. static void getcallargs(args,arglen,argc)
  1652. int argc;     /* How many */
  1653. char *args[]; /* Where to put the pointers */
  1654. int arglen[]; /* Where to put the lengths */
  1655. {
  1656.    int i;
  1657.    for(i=argc-1;i>=0;i--)args[i]=delete(&arglen[i]);
  1658.    args[argc]=cnull;
  1659. }
  1660. /* A `call' command interpreter. The integer result is 1 if the call
  1661.    returned a value (placed on the calculator stack), 0 otherwise. */
  1662. int rxcall(stmt,name,argc,lit,calltype)
  1663. int stmt;      /* Where to call if this is a condition trap */
  1664. char *name;    /* What to call (as given in the CALL instruction) */
  1665. int argc;      /* How many args were given (on the calculator stack) */
  1666. long calltype; /* the calltype as in RexxStart() */
  1667. int lit;       /* whether or not the name was a quoted literal (if it was,  */
  1668. {              /* lit=1 and the internal label table is not searched */
  1669.    char *lptr;             /* A label pointer */
  1670.    struct procstack *sptr; /* A program stack item pointer */
  1671.    int l;
  1672.    char *result;           /* The result returned by the subroutine */
  1673.    int rlen;               /* The length of the result */
  1674.    char *args[maxargs+1];  /* The arguments given by the CALL instruction */
  1675.    int arglen[maxargs];    /* The lengths of the arguments */
  1676.    RXSTRING rxargs[maxargs]; /* more arguments (terribly inefficient) */
  1677.    RXSTRING rxresult;        /* and another result */
  1678.    short rxrc;
  1679.    int type=0;             /* The type of a program stack entry */
  1680.    void *dlhandle;         /* The handle of a dynamically loaded module */
  1681.    int (*dlfunc)();        /* The address of a function in same */
  1682.    dictionary *dldict;     /* The address of the dictionary in same */
  1683.    char file[maxvarname+5];/* The name of a program file to load */
  1684.    int ext=0;              /* Whether the subroutine is external or internal */
  1685.    funcinfo *data;         /* data about an already loaded function */
  1686.    char *callname;         /* By what name the subroutine was called */
  1687.    char **oldcarg=curargs; /* The saved parameters of the current program...*/
  1688.    int *oldcarglen=curarglen;
  1689.    char *oldcstackptr;
  1690.    char oldtrcres=trcresult;
  1691.    long oldsec=timestamp.tv_sec;
  1692.    long oldmic=timestamp.tv_usec;
  1693.    char *flname;           /* The file name to load */
  1694.    int w=0;                /* what kind of file it is */
  1695.    int saa=0;              /* whether func is registered as saa */
  1696.    char c;
  1697.    int delay=0;
  1698.    int sigl=0;             /* line to come from */
  1699.    int registerit=0;       /* whether this function should be hashed */
  1700.    static int donelibs=0;  /* whether the .rxlib files have been searched */
  1701.    int callflags=0;        /* flags for RexxStartProgram */
  1702.    while(argc&&isnull())argc--,delete(&w);/* The last arg should not be null */
  1703.    if(argc>maxargs)die(Emanyargs); /* Too much to handle */
  1704.    if(!name){/* called as a condition trap, so no need to search for a label */
  1705.       delay=lit; /* as a parameter-saving device, the delayed signal was
  1706.                     passed as the "lit" parameter. */
  1707.       name=conditions[delay];    /* the real name has been lost.  Use the
  1708.                                     condition name. */
  1709.       if(delay==Ihalt)sigl=haltline;
  1710.    }
  1711.    else{            
  1712. /* check for internal label */
  1713.       if(!lit){
  1714.          for(lptr=labelptr;(l= *(int *)lptr)&&strcasecmp(name,lptr+2*four);
  1715.              lptr+=align(l+1)+2*four);
  1716.          if(l)stmt=((int*)lptr)[1];
  1717.       }
  1718.       if(lit||!l){ /* no label, so try built-in and then external */
  1719.          if((l=rxfn(name,argc))>0)return 1; /* OK, builtin was executed */
  1720.          if(callname=strrchr(name,'/')) /* Get base name for "callname" */
  1721.             callname++;
  1722.          else callname=name;
  1723.          if(!donelibs)libsearch(),donelibs=1;
  1724.          if(data=(funcinfo *)hashget(2,callname,&w)){ /* function is hashed */
  1725.             if(data->dlfunc){   /* function has already been loaded */
  1726.                if(data->saa)                        /* saa calling sequence */
  1727.                   l=funccall((unsigned long(*)())data->dlfunc,callname,argc);
  1728.                else l=(data->dlfunc)(callname,argc);/* imc calling sequence */
  1729.                if(l<0)die(-l);
  1730.                return l;
  1731.             }
  1732.             else flname=data->name,saa=data->saa;
  1733.             if(saa&RXDIGITS)saa&=~RXDIGITS,callflags|=RXDIGITS;
  1734.          }
  1735.          else{ /* Make the file name in lower case in the workspace */
  1736.             ext=strlen(name);
  1737.             mtest(workptr,worklen,ext+1,worklen-ext+1);
  1738.             for(l=0;c=name[l];l++)workptr[l]=c>='A'&&c<='Z'?name[l]|32:name[l];
  1739.             workptr[l]=0;
  1740.             flname=workptr;
  1741.             if(flname[0]!='/')registerit=1;
  1742.          }
  1743.       /* if(w)strcpy(file,flname); else */
  1744.          if(!(w=which(flname,2,file)))  /* Search for the file, but... */
  1745.             sprintf(workptr,": \'%s\'",name),/* die if not found */
  1746.             errordata=workptr,
  1747.             die(Eundef);
  1748.          if(registerit)funcinit(name,(void*)file,(int(*)())0,saa);
  1749.          if(w==1){ /* The file is a Rexx program, so start it */
  1750.             for(l=argc-1;l>=0;l--){
  1751.                rxargs[l].strptr=delete(&w);
  1752.                if(w>=0)rxargs[l].strlength=w;
  1753.                else rxargs[l].strptr=0,rxargs[l].strlength=-1;
  1754.             }
  1755.             rxresult.strptr=0;
  1756.             l=RexxStartProgram((char*)0,(long)argc,rxargs,file,callname,
  1757.                (RXSTRING *)0,envtable[address0].name,calltype,
  1758.                callflags|RXEXITS,(PRXSYSEXIT)0,&rxrc,&rxresult);
  1759.             if(l==-Ehalt)die(Ehalt);
  1760.             else if(l==-Esig)longjmp(*exitbuf,Esig);
  1761.             else if(l)die(Eincalled);
  1762.             if(!rxresult.strptr)return 0;
  1763.             stack(rxresult.strptr,rxresult.strlength);
  1764.             free(rxresult.strptr);
  1765.             return 1;
  1766.          }
  1767.          else if(w==3){ /* The file is a Unix program */
  1768.             return unixcall(file,callname,argc);
  1769.          }
  1770.          else { /* executable function must be linked.  All functions from the
  1771.                    dictionary will be loaded and hashed.  Exactly one of these
  1772.                    will have a non-null dlhandle entry. */
  1773.             if(!(dlhandle=dlopen(file,1)))
  1774.                fputs(dlerror(),stderr),fputc('\n',stderr),die(Esys);
  1775. #ifdef _REQUIRED
  1776.             dlfunc=(int(*)())dlsym(dlhandle,"_rxfunction");
  1777.             dldict=(dictionary *)dlsym(dlhandle,"_rxdictionary");
  1778. #else
  1779.             dlfunc=(int(*)())dlsym(dlhandle,"rxfunction");
  1780.             dldict=(dictionary *)dlsym(dlhandle,"rxdictionary");
  1781. #endif
  1782.             if(dlfunc)funcinit(callname,dlhandle,dlfunc,saa),dlhandle=0;
  1783.             if(dldict)
  1784.                while(dldict->name){
  1785.                   funcinit(dldict->name,dlhandle,dldict->function,saa);
  1786.                   dlhandle=0;
  1787.                   if(!dlfunc&&!strcasecmp(dldict->name,callname))
  1788.                      dlfunc=dldict->function;  /* ...this is the required fn */
  1789.                   dldict++;
  1790.                }
  1791.             if(!dlfunc) /* Function wasn't found in the file */
  1792.                sprintf(workptr,": \'%s\' in file %s",name,file),
  1793.                errordata=workptr,
  1794.                die(Eundef);
  1795.             if (saa) l=funccall((unsigned long(*)())dlfunc,callname,argc);
  1796.             else l=dlfunc(callname,argc);  /* Call the required function. */
  1797.             if(l<0)die(-l);
  1798.             return l;
  1799.          }
  1800.       }
  1801.    }
  1802.    /* The subroutine is Rexx and stmt is the statement to go to */
  1803.    /* now set SIGL as appropriate */
  1804.    l=findsigl(&rlen);
  1805.    l=prog[l].num;    /* get the "real" program and find line */
  1806.    if(!sigl)sigl=l;  /* Set SIGL unless it was already given by a "halt" */
  1807.    sprintf(file,"%d",sigl),
  1808.    varset("SIGL",4,file,strlen(file)); /* ("file" is unused in this case) */
  1809.    getcallargs(args,arglen,argc),
  1810.    oldcstackptr=cstackptr,
  1811.    cstackptr=allocm(100);
  1812.    sptr=(struct procstack *) /* We now stack a program stack item... */
  1813.       pstack(11,sizeof(struct procstack2));
  1814.    sptr->csp=oldcstackptr,
  1815.    sptr->ecsp=ecstackptr,
  1816.    sptr->csl=cstacklen,
  1817.    sptr->trc=trcflag,
  1818.    sptr->tim=timeflag,
  1819.    sptr->mic=microsecs,
  1820.    sptr->sec=secs,
  1821.    sptr->address1=address1,
  1822.    sptr->address2=address2,
  1823.    sptr->form=numform,
  1824.    sptr->digits=precision,
  1825.    sptr->fuzz=fuzz;
  1826.    sptr->stmts=oldstmts,
  1827.    sptr->prg=oldprog;
  1828.    cstacklen=100, /* We allocated the new stack earlier (can't think why...) */
  1829.    ecstackptr=0;  /* Clear the stack now */
  1830.    if(++interplev>=sigstacklen) /* We might need more space on the sgstack */
  1831.       if(!(sgstack=(struct sigstruct *)
  1832.          realloc((char *)sgstack,sizeof(struct sigstruct)*(sigstacklen+=10))))
  1833.          die(Emem);
  1834.    trcresult=0;
  1835.    result=interpreter(&rlen,stmt,name,calltype,args,arglen,1,delay);
  1836.    /* Now, clean up, reclaim all the new structures, delete the program stack
  1837.    entry, replace the old values of certain things, etc */
  1838.    trcresult=oldtrcres,
  1839.    interplev--,
  1840.    oldcstackptr=cstackptr,
  1841.    timestamp.tv_sec=oldsec,
  1842.    timestamp.tv_usec=oldmic;
  1843.    while(type<11||type>12) /* Clear up all entries until ours */
  1844.       type=unpstack(),sptr=(struct procstack *)delpstack();
  1845.    cstackptr=sptr->csp,
  1846.    ecstackptr=sptr->ecsp,
  1847.    cstacklen=sptr->csl,
  1848.    trcflag=sptr->trc,
  1849.    timeflag=(timeflag&4)|(sptr->tim & 3),
  1850.    microsecs=sptr->mic,
  1851.    secs=sptr->sec,
  1852.    address1=sptr->address1,
  1853.    address2=sptr->address2,
  1854.    numform=sptr->form,
  1855.    precision=sptr->digits,
  1856.    fuzz=sptr->fuzz;
  1857.    if(result)stack(result,rlen);
  1858.    free(oldcstackptr); /* Now the result has been used, free the old stack */
  1859.    stmts=sptr->stmts,
  1860.    prog=(sptr->prg);
  1861.    if(type>11) /* reclaim procedural variables */
  1862.       varstkptr--;
  1863.    curargs=oldcarg,
  1864.    curarglen=oldcarglen;
  1865.    ppc=newppc;
  1866.    if(rlen<0){  /* the program fell off the end, so EXIT */
  1867.       returnfree=0;
  1868.       returnval=0;
  1869.       while(pstacklev){
  1870.          type=unpstack();
  1871.          freestack(delpstack(),type);
  1872.       }
  1873.       longjmp(sgstack[interplev].jmp,-1); /* interplev=0 I hope... */
  1874.    }
  1875.    return result!=cnull;
  1876. }
  1877. /* A function to execute the `interpret' command.  The return is either null,
  1878. or a pointer to a result string which was given in a RETURN instruction. */
  1879. char *rxinterp(exp,len,rlen,name,calltype,args,arglen)
  1880. char *exp;        /* The string to be interpreted */
  1881. int len;          /* The length of the string */
  1882. int *rlen;        /* The length of a value returned, if any */
  1883. char *name;       /* The name of the current routine */
  1884. long calltype;    /* How it was called */
  1885. char *args[];     /* The array of arguments to the current Rexx function */
  1886. int arglen[];     /* The array of lengths of arguments */
  1887. {
  1888.    void process();           /* The tokeniser used by load() */
  1889.    struct interpstack *sptr; /* A program stack item pointer */
  1890.    char *result;             /* The result to be returned, if any */
  1891.    int type=0;
  1892.    if(!len) {                /* interpret null string is OK immediately */
  1893.       *rlen=-1;
  1894.       return cnull;
  1895.    }
  1896.    result=allocm(len+1);
  1897.    memcpy(result,exp,len);
  1898.    result[len]='\n';
  1899. /* tokenise... */
  1900.    oldstmts=stmts;
  1901.    oldprog=prog;
  1902.    ippc=ppc;
  1903.    interpreting=1;
  1904.    tokenise(result,len+1,1,0);
  1905.    interpreting=0;
  1906.    ppc=ippc;
  1907. /* Fill in a program stack entry */
  1908.    sptr=(struct interpstack *)pstack(14,sizeof(struct interpstack));
  1909.    sptr->stmts=oldstmts;
  1910.    sptr->prg=oldprog;
  1911.    ecstackptr=0;
  1912.    if(++interplev>=sigstacklen)/* might need some more space for the sgstack*/
  1913.       if(!(sgstack=(struct sigstruct *)
  1914.          realloc((char *)sgstack,sizeof(struct sigstruct)*(sigstacklen+=10))))
  1915.          die(Emem);
  1916. /* This is where the string gets interpreted */
  1917.    result=interpreter(rlen,1,name,calltype,args,arglen,1,0);
  1918.    /* If it returned with RETURN it could be within DO structures, etc
  1919.       which should be removed from the stack. */
  1920.    type=unpstack();
  1921.    if (*rlen>=0)
  1922.       while (type!=14) {delpstack(); type=unpstack();}
  1923.    else /* otherwise all structures should be complete */
  1924.       if(type!=14)die(Enoend);
  1925.    interplev--;
  1926.    sptr=(struct interpstack *)delpstack(),
  1927.    ppc=newppc,
  1928.    free(prog[0].source),  /* the interpreted string */
  1929.    free(prog[0].line),    /* the tokenised string */
  1930.    free((char*)prog),     /* the statement table */
  1931.    stmts=((struct interpstack *)sptr)->stmts,
  1932.    prog=((struct interpstack *)sptr)->prg;
  1933.    return result;
  1934. }
  1935. static void doconds()   /* check for delayed conditions and trap them */
  1936. {
  1937.    int cond;
  1938.    struct errorstack *tmpptr;
  1939.    int len;
  1940.    for(cond=0;cond<Imax;cond++)
  1941.       if(delayed[cond]){
  1942.          if((sgstack[interplev].callon&(1<<cond)) &&
  1943.            !(sgstack[interplev].delay &(1<<cond))){
  1944.            delayed[cond]=0;
  1945.            if(sgstack[interplev].ppc[cond]<0){ /* report an undefined label */
  1946.               tmpptr=(struct errorstack *)pstack(20,sizeof(struct errorstack));
  1947.               tmpptr->prg=prog;
  1948.               tmpptr->stmts=stmts;
  1949.               ppc=-sgstack[interplev].ppc[cond];
  1950.               findsigl(&cond);
  1951.               errordata=0;
  1952.               die(Elabel);
  1953.            } /* now call the condition routine */
  1954.            if(rxcall(sgstack[interplev].ppc[cond],cnull,0,cond,RXSUBROUTINE))
  1955.               delete(&len);             /* Ignore the return value */
  1956.            cond--;                      /* check this signal again */
  1957.          }
  1958.          else if(cond!=Ihalt)delayed[cond]=0; /* Cancel delayed conditions */
  1959.       }
  1960.    /* check for interruption */  
  1961.    if(delayed[Ihalt] && !(sgstack[interplev].delay&(1<<Ihalt)))
  1962.       delayed[Ihalt]=0,die(Ehalt);
  1963. }
  1964. void settrace(option)   /* Sets the trace flag according to the given option */
  1965. char *option;
  1966. {
  1967.    char c;
  1968.    if(!*option){
  1969.       otrcflag=trcflag=Tfailures;
  1970.       return;
  1971.    }
  1972.    while((c=*option++)=='?')trcflag^=Tinteract;
  1973.    interactmsg=(trcflag&Tinteract);
  1974.    switch(c&0xdf){
  1975.       case 'A':c=Tclauses;               break;
  1976.       case 'C':c=Tcommands|Terrors;      break;
  1977.       case 'E':c=Terrors;                break;
  1978.       case 'F':c=Tfailures;              break;
  1979.       case 'I':c=Tclauses|Tintermed;     break;
  1980.       case 'L':c=Tlabels;                break;
  1981.       case 'N':c=Tfailures;              break;
  1982.       case 'O':c=trcflag=interactmsg=0;  break;
  1983.       case 'R':c=Tclauses|Tresults;      break;
  1984.       case 0:                            break;
  1985.       default:die(Etrace);
  1986.    }
  1987.    otrcflag=trcflag=(trcflag&Tinteract)|c;
  1988. }
  1989. int setoption(option,len)        /* Interpret an option from the OPTIONS */
  1990. char *option;                    /* instruction or a commandline parameter. */
  1991. int len;                         /* Return 1 if the option was processed */
  1992. {                                /* This routine does not raise errors. */
  1993.    static char buffer[maxvarname];
  1994.    char *ptr=memchr(option,'=',len);
  1995.    FILE *fp;
  1996.    int equals=ptr?ptr-option:0;
  1997.    if(len>=maxvarname)return 0;
  1998.    if(equals>=5 && !strncasecmp(option,"tracefile",equals)){
  1999.       option+= ++equals;
  2000.       len-=equals;
  2001.       if(!len || memchr(option,0,len))return 0;
  2002.       if(option[0]=='\'' || option[0]=='\"'){
  2003.          if(option[len-1]!=option[0])return 0;
  2004.          option++;
  2005.          len-=2;
  2006.       }
  2007.       memcpy(buffer,option,len);
  2008.       buffer[len]=0;
  2009.       if (!strcmp(buffer,"stdout")) fp=stdout;
  2010.       else if (!strcmp(buffer,"stderr")) fp=stderr;
  2011.       else if(!(fp=fopen(buffer,"a")))perror(buffer);
  2012.       if (fp) {
  2013.          if(traceout && traceout!=stderr && traceout!=stdout)fclose(traceout);
  2014.          traceout=fp;
  2015.          printf("Writing trace output to %s\n",buffer);
  2016.       }
  2017.       return 1;
  2018.    }
  2019.    if(len==5 && !strncasecmp(option,"setrc",len))
  2020.       return setrcflag=1;
  2021.    if(len==7 && !strncasecmp(option,"nosetrc",len))
  2022.       return setrcflag=0,1;
  2023.    if(len<=6 && len>=3 && !strncasecmp(option,"expose",len))
  2024.       return exposeflag=1;
  2025.    if(len<=8 && len>=5 && !strncasecmp(option,"noexpose",len))
  2026.       return exposeflag=0,1;
  2027.    if(len<=7 && len>=4 && !strncasecmp(option,"sigpipe",len))
  2028.       return sigpipeflag=1;
  2029.    if(len<=9 && len>=6 && !strncasecmp(option,"nosigpipe",len))
  2030.       return sigpipeflag=0,1;
  2031.    return 0;
  2032. }
  2033. static int gettrap(lineptr,on,stmt)/* Get a trap name after "call/signal on" */
  2034. char **lineptr;        /* pointer to the trap name */
  2035. int on;                /* whether "on" or "off" */
  2036. int *stmt;             /* the statement number to go to on error */
  2037. {                      /* Return the trap number */
  2038.    int l;
  2039.    int i;
  2040.    int *lptr;
  2041.    int tmpchr=1;
  2042.    gettoken(*lineptr,&tmpchr,varnamebuf,varnamelen,0);
  2043.    lineptr[0]+=tmpchr;
  2044.    for(i=0;i<Imax && strcasecmp(varnamebuf,conditions[i]);i++);
  2045.    if(i==Imax)die(Etrap);
  2046.    if(on && **lineptr==NAME){
  2047.       tmpchr=1,
  2048.       gettoken(*lineptr,&tmpchr,varnamebuf,varnamelen,0);
  2049.       if(!varnamebuf[0])die(Enostring);
  2050.       lineptr[0]+=tmpchr;
  2051.    }
  2052.    /* varnamebuf now holds the name to go to on error */
  2053.    if(on){
  2054.       for(lptr=(int *)labelptr;
  2055.       (l= *lptr)&&strcasecmp(varnamebuf,(char *)(lptr+2));
  2056.       lptr+=2+align(l+1)/four);
  2057.       if(l)l=lptr[1]; /* l holds the stmt to go to on error */
  2058.    }
  2059.    *stmt=l;
  2060.    return i;
  2061. }
  2062. static void testvarname(lineptr,var,len)/* Check that any symbol in the   */
  2063. char **lineptr;                  /* current line, pointed to by lineptr,  */
  2064. char *var;                       /* matches the stored control variable   */
  2065. int len;                         /* name, var, of length len.             */
  2066. {
  2067.    char c;
  2068.    char *varref;
  2069.    int reflen;
  2070.    if (c= **lineptr){                     /* if the symbol name is supplied: */
  2071.       if (c<0)die(Exend);                 /* die if it is a keyword [SELECT] */
  2072.       if(rexxsymbol(c)<1)die(Enosymbol);  /* or an invalid symbol            */
  2073.       varref= *lineptr;                   /* Save start addr of symbol       */
  2074.       reflen=0;
  2075.       skipvarname(*lineptr,&reflen);      /* go to end of symbol             */
  2076.       if(len!=reflen||memcmp(varref,var,len))
  2077.          die(Exend);                      /* die if it is the wrong symbol   */
  2078.       lineptr[0]+=reflen;
  2079.    }
  2080. }
  2081. static void skipstmt(){ /* Skips the current instruction */
  2082.    if (ppc==stmts) die(Enoend);
  2083.    switch(prog[ppc].line[0]){  /* Test for block instructions */
  2084.       case DO:    stepdo();     return; 
  2085.       case SELECT:stepselect(); return;
  2086.       case IF:    stepif();     return;
  2087.       case WHEN:  stepwhen();   return;
  2088.       default: ppc++;          /* Skip one statement */
  2089.          return;
  2090.    }
  2091. }
  2092. /* The following functions, stepdo(), stepselect(), stepif() and stepwhen(),
  2093.    do the work of skipstmt() in the special cases of DO, SELECT and IF
  2094.    instructions. */
  2095. static void stepdo()
  2096. {
  2097.    pstack(0,sizeof(struct minstack));
  2098.               /* in case of error, report loop start as well as end */
  2099.    if(++ppc==stmts)die(Enoend);             /* go past DO */
  2100.    while(prog[ppc].line[0]!=END)skipstmt(); /* find END */
  2101.    if(prog[ppc].line[1]<0)die(Exend);       /* report error for "END SELECT" */
  2102.    delpstack();
  2103.    ppc++;                                   /* go past END */
  2104. }
  2105. static void stepselect()
  2106. {
  2107.    char c;
  2108.    pstack(0,sizeof(struct minstack));
  2109.    if(++ppc==stmts)die(Enoend);             /* go past SELECT */
  2110.    while(prog[ppc].line[0]!=END)skipstmt(); /* find END */
  2111.    if((c=prog[ppc].line[1])&&c!=SELECT)die(Exend);/* report error for "END x"*/
  2112.    delpstack();
  2113.    if(++ppc==stmts)die(Enoend);             /* go past END */
  2114. }
  2115. static void stepif(){
  2116.    if(++ppc==stmts)die(Enoend);             /* go past IF */
  2117.    if(prog[ppc].line[0]!=THEN)die(Enothen); /* find THEN */
  2118.    if(++ppc==stmts)die(Enoend);             /* go past THEN */
  2119.    skipstmt();                              /* skip the statement after THEN */
  2120.    if(prog[ppc].line[0]==ELSE){             /* an ELSE clause is optional    */
  2121.       if(++ppc==stmts)die(Enoend);          /* go past ELSE */
  2122.       skipstmt();                           /* skip the statement after ELSE */
  2123.    }
  2124. }
  2125. static void stepwhen(){
  2126.    if(++ppc==stmts)die(Enoend);             /* go past WHEN */
  2127.    if(prog[ppc].line[0]!=THEN)die(Enothen); /* find THEN */
  2128.    if(++ppc==stmts)die(Enoend);             /* go past THEN */
  2129.    skipstmt();                              /* skip the statement after THEN */
  2130. }
  2131. static void findend(){ /* This function is called inside a SELECT, LEAVE or */
  2132.                       /* ITERATE to find the closing END statement.         */
  2133.    while (prog[ppc].line[0]!=END) skipstmt();
  2134. }
  2135. void on_halt(){  /* when a halt occurs, this function is called to set
  2136.                     the haltline variable. */
  2137.    int errstmt;
  2138.    int dummy;
  2139.    if(prog){
  2140.       errstmt=findsigl(&dummy);
  2141.       haltline=prog[errstmt].num;/* Find the line number at which halt occurred */
  2142.       prog=oldprog,stmts=oldstmts;
  2143.    }
  2144. }
  2145.