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