1 /* The calculating routines of REXX/imc (C) Ian Collier 1992 */
2
3 #include<stdio.h>
4 #include<memory.h>
5 #include<string.h>
6 #include<stdlib.h>
7 #include<setjmp.h>
8 #include<sys/types.h>
9 #include<sys/time.h>
10 #include"const.h"
11 #include"globals.h"
12 #include"functions.h"
13 #include"rexxsaa.h"
14
15 /* scanning() is the expression evaluator, called 30 times from various parts
16 of the interpreter to collect an expression from a program line. The
17 program line is given as the "line" parameter, and the character pointer
18 as "ptr". An expression will be evaluated and placed on the calculator
19 stack. In addition its address on the stack will be returned and its
20 length will be placed in len. On exit, ptr will point to the character
21 immediately following the expression (it will not point to a space). */
scanning(line,ptr,len)22 char *scanning(line,ptr,len)
23 char *line;
24 int *ptr,*len;
25 {
26 /* the following identifiers are arranged in order as defined by the
27 constants OPpower, OPmul, ... , OPggeq. binops contains the character
28 codes of all the binary operators, and binpri contains their priorities. */
29
30 static char binops[]={POWER,'*','/','+','-',' ',CONCAT,'=',EQU,'<',LEQ,'>',GEQ,NEQ,'&',LXOR,'|','%',MOD,NNEQ,LESS,GRTR,LLEQ, GGEQ};
31 static char binpri[]={ 10, 8, 8, 7, 7, 6, 6, 5, 5, 5, 5, 5, 5, 5, 3, 2, 2, 8, 8, 5 ,5 ,5 ,5 ,5};
32 void binplus();
33 void binmin();
34 void binmul();
35 void bindiv();
36 void bincat();
37 void binexp();
38 void binbool();
39 void binrel();
40 void unnot();
41 void unmin();
42 void unplus();
43 static void (*binprg[])() ={binexp, /* This array contains the addresses */
44 binmul, /* of all the functions which are */
45 bindiv, /* called to implement the various */
46 binplus,/* operators, in the order such that */
47 binmin, /* binprg(OPxyz) is the routine to */
48 bincat, /* implement the xyz operator */
49 bincat,
50 binrel,
51 binrel,
52 binrel,
53 binrel,
54 binrel,
55 binrel,
56 binrel,
57 binbool,
58 binbool,
59 binbool,
60 bindiv,
61 bindiv,
62 binrel,
63 binrel,
64 binrel,
65 binrel,
66 binrel,
67 unmin,
68 unplus,
69 unnot};
70 struct {char op;char pri;} opstack[maxopstack]; /* an operation stack */
71 int opptr=1; /* the operation stack pointer */
72 int lp;
73 char *exp;
74 int expn;
75 int explen;
76 int t;
77 int n;
78 int dot;
79 int endnum;
80 char quote;
81 char varname[maxvarname];
82 char *vg;
83 char op,pri;
84 char ch,c1;
85 int intermed=trcflag&Tintermed; /* whether to trace intermediate results */
86 static char what[4]=">>>"; /* the trace prefix to use */
87
88 opstack[0].pri=0; /* The bottom of stack marker */
89 trcresult++; /* count levels - trace result only on outer level */
90 while(1){ /* loop until expression has finished */
91 lp=1;
92 while(lp){ /* loop until a value has been stacked */
93 if(opptr>=maxopstack-1)die(Eopstk);
94 switch(line[*ptr]){
95 case ')': die(Erpar);
96 case ',': die(Ecomma);
97 case '(':(*ptr)++, /* parenthesised expressions are stacked by */
98 scanning(line,ptr,&explen); /* calling scanning recursively */
99 if(line[(*ptr)++]!=')')die(Elpar); /* it must end with ')' */
100 lp=0;
101 what[1]=0; /* Prevent the value from being traced, since */
102 break; /* scanning() already traced it */
103 case '+':(*ptr)++,/* for unary '+' stack code OPplus, priority 11 */
104 opstack[opptr].op=OPplus,
105 opstack[opptr++].pri=11;
106 break;
107 case '-':(*ptr)++, /* for unary '-' stack code OPneg, priority 11 */
108 opstack[opptr].op=OPneg,
109 opstack[opptr++].pri=11;
110 break;
111 case '\\':(*ptr)++, /* for '\' stack code OPnot, priority 11 */
112 opstack[opptr].op=OPnot,
113 opstack[opptr++].pri=11;
114 break;
115 case '\'': /* Quoted expression... */
116 case '\"':quote=line[(*ptr)++],
117 expn= *ptr;
118 while(line[expn++]!=quote||line[expn]==quote)
119 if(line[expn-1]==quote)expn++; /* search for close quote */
120 if(line[expn]=='X'&&!rexxsymboldot(line[expn+1]))
121 stackx(line+*ptr,expn-*ptr-1),expn++;/* stack hex */
122 else if(line[expn]=='B'&&!rexxsymboldot(line[expn+1]))
123 stackb(line+*ptr,expn-*ptr-1),expn++;/* stack bin */
124 else stackq(line+*ptr,expn-*ptr-1,quote); /* stack string */
125 /* A string constant has been found, but if
126 it is followed by '(' it is a function call which
127 bypasses the internal label search. */
128 if(line[expn]=='('){
129 (*ptr)=expn+1;
130 exp=delete(&n);
131 if(n>maxvarname-1)die(Elong); /* the function name is */
132 memcpy(varname,exp,n); /* stored in varname */
133 t=1;
134 goto rxfncall;
135 }
136 (*ptr)=expn; /* step past string constant in line. */
137 lp=0; /* signal "stacked a value" */
138 what[1]='L';
139 break;
140 default: /* stack a variable or literal or
141 call a function. */
142 if(line[*ptr]<0)die(Ebadexpr);
143 if(!(t=rexxsymbol(line[*ptr]))&&line[*ptr]!='.')die(Ebadexpr);
144 what[1]='L';
145 if(t!=1){ /* a constant symbol. Special processing
146 is required to ensure that if the symbol is a
147 number in exponential format then any "+" or "-"
148 in the number is treated as part of it */
149 n=1;dot=0; /* dot is the count of dots in the number; n is
150 a flag meaning: 0 an ordinary constant symbol,
151 1 an exponent is allowed, 2 this is the
152 character after "E". */
153 endnum=0; /* The position of any "+" or "-" in case the
154 exponent is badly formed (e.g. in 1e+23.4) */
155 for(expn= *ptr;;expn++){
156 c1=line[expn];
157 if(!n) /* stop whenever a non-symbol character is found */
158 if(!rexxsymboldot(c1)){ /* But remove a "+" or "-" if
159 the exponent was empty */
160 if(endnum&&endnum+1==expn)expn=endnum;
161 break;
162 }
163 else if(endnum&&(c1<'0'||c1>'9'))
164 {expn=endnum;break;} /* Remove a non-numeric */
165 else; /* exponent following a sign */
166 else {
167 if(alphanum(c1)<2){ /* not number or dot */
168 if(n==2&&(c1=='-'||c1=='+')){
169 n=0; /* OK to have + or - after an E */
170 endnum=expn;
171 continue;
172 }
173 if(n==1&&c1=='E')
174 {n=2;continue;}/* Expect an optional sign next */
175 n=0; /* it's not a number any more */
176 if(!rexxsymboldot(c1))
177 break; /* allow only symbol characters */
178 }
179 if(n==2)n=0; /* No sign after the 'E' */
180 else if(c1=='.'&&dot++>0)n=0; /* a second dot found */
181 }
182 }
183 if(expn==*ptr)die(Ebadexpr); /* The symbol has zero length */
184 stack(line+*ptr,expn-*ptr), /* Stack the constant symbol */
185 (*ptr)=expn; /* step past it. */
186 }else{ /* A symbol follows. If a '(' follows the symbol, then
187 it is a function call */
188 n=0,t=0; /* t=0 -> search internal definitions */
189 for(expn= *ptr;rexxsymboldot(varname[n++]=line[expn++]);)
190 if(n>=maxvarname-1)die(Elong);
191 /* the symbol has been copied to varname */
192 if(--n>0&&varname[n-1]!='.'&&varname[n]=='('){
193 *ptr=expn; /* Step past the symbol */
194 /* A function call has now been found. varname holds its name, and n holds
195 its length. t!=0 if the name was in quotes, t=0 otherwise. */
196 rxfncall: varname[n]=0; /* The name is nul-terminated (it cannot */
197 n=0; /* contain a nul character) */
198 if(line[*ptr]!=')') /* Unless no arguments given... */
199 while(1){ /* get each one by calling scanning */
200 if((ch=line[*ptr])==','||ch==')')stacknull();
201 else scanning(line,ptr,&explen);
202 n++;
203 if((ch=line[*ptr])==',')++*ptr;
204 else if(ch!=')')die(Elpar);
205 else break;
206 }
207 ++*ptr; /* Step past the ')'. n contains the arg count.*/
208 if(!rxcall(0,varname,n,t,RXFUNCTION)) /* This is where */
209 die(Enoresult); /* the function gets called */
210 lp=0;
211 what[1]='F';
212 break;
213 }
214 /* else ignore the result of the search for a function name
215 and try to get a variable instead */
216 getvarname(line,ptr,varname,&explen,maxvarname),
217 vg=varget(varname,explen,&expn);
218 if(vg==cnull){ /* See if novalue errors are caught */
219 if((varname[0]&128)&&!memchr(varname,'.',explen))
220 varname[explen++]='.';/* Add a dot to undefined stem */
221 varname[0]&=127; /* if OK stack the variable's name */
222 varname[explen]=0;
223 if((sgstack[interplev].bits&(1<<Inovalue)) &&
224 (interact<0 || interact+1!=interplev))
225 errordata=varname,
226 die(Enovalue);
227 stack(varname,explen);
228 }
229 else what[1]='V',stack(vg,expn); /* it was found */
230 }
231 lp=0;
232 }
233 }
234 if(intermed&&what[1])tracelast(what);
235 /* at this point a (possibly null) list of operators and their priorities
236 have been stacked, and a value has just been placed on the calculator
237 stack. The next character will either be a terminator or an (explicit
238 or implicit) binary operator. Special case: if it is a unary
239 operator (i.e. "logical not"), then it is a syntax error. */
240 ch=line[*ptr];
241 if(ch=='\\')die(Ebadexpr);
242 if((c1=line[*ptr])==-1||!c1||c1==')'||c1==','||c1<SYMBOL)pri=0;
243 /* terminators are ';', 'EOL', ')', ',' and all `words'. Priority 0
244 signals that a terminator was found. */
245 else{
246 (*ptr)++; /* Go past the op */
247 for(op=0;binops[op]!=ch&&op<24;op++); /* "op" holds its index */
248 if(op<24)pri=binpri[op]; /* "pri" holds its priority */
249 else (*ptr)--, /* The char is not a binary operator, so it must be */
250 op=OPcat, /* an implicit concatenation, priority 6. */
251 pri=6;
252 }
253 /* Having found the next operator and its priority (priority 16 highest,
254 0 meaning no further operators), we now examine previous operations
255 to see whether they should be done now. If not, another value is
256 stacked unless the priorities of both the current operator and the
257 top stacked operator are zero, in which case evaluation has finished.*/
258 while(opstack[opptr-1].pri>=pri&&opstack[opptr-1].pri){
259 opptr--,
260 eworkptr=0,
261 binprg[opstack[opptr].op](opstack[opptr].op); /* This does the op */
262 if(intermed)
263 what[1]=(opstack[opptr].op>23?'P':'O'), /* Trace the op's result */
264 tracelast(what);
265 }
266 if(!pri)break;
267 opstack[opptr].op=op, /* The binary operator just encountered is */
268 opstack[opptr++].pri=pri; /* stacked before finding the next value. */
269 } /* Evaluation has finished, so the top stack value is returned. */
270 (*len)= *((int *)(cstackptr+ecstackptr)-1);
271 if(!--trcresult &&(trcflag&Tresults)) /* trace the result */
272 tracelast(">>>");
273 if(!trcresult)timeflag&= (~2); /* clear timestamp after a result */
274 return cstackptr+ecstackptr-align(*len)-four;
275 }
276
tracelast(type)277 void tracelast(type) /* trace the last value on the stack */
278 char *type; /* The trace prefix to use */
279 {
280 char *exp=cstackptr+ecstackptr-four;
281 int len= *(int *)exp;
282 exp -=align(len);
283 traceline(type,exp,len);
284 }
285
traceline(type,exp,len)286 void traceline(type,exp,len) /* trace a result or other string */
287 char *type; /* the trace prefix to use */
288 char *exp; /* the string to be traced */
289 int len; /* the length of the string */
290 {
291 int i;
292 traceput(" ",6);
293 traceput(type,3);
294 traceput(" ",3);
295 for(i=0;i<traceindent*pstacklev;i++)tracechar(' ');
296 tracechar('"');
297 traceput(exp,len);
298 traceput("\"\n",2);
299 }
300
stack(exp,len)301 void stack(exp,len) /* stack a copy of exp whose length is explen */
302 char *exp;
303 int len;
304 {
305 int alen=align(len);
306 mtest(cstackptr,cstacklen,ecstackptr+alen+2*four,len+256);
307 memcpy(cstackptr+ecstackptr,exp,len), /* The string goes on first */
308 ecstackptr+=alen, /* it is padded into alignment */
309 (*(int *)(cstackptr+ecstackptr))=len, /* The length is then appended. */
310 ecstackptr+=four;
311 }
312
stackq(exp,len,quote)313 void stackq(exp,len,quote) /* stack a copy of exp whose length is explen, */
314 char *exp; /* reducing double quotes to single quotes */
315 int len;
316 char quote; /* The type of quote mark to reduce from double to single */
317 { /* It is guaranteed that this always occurs in pairs */
318 int i=0,l=0;
319 char *p;
320 char c;
321 mtest(cstackptr,cstacklen,ecstackptr+len+3*four,len+256);
322 for(p=cstackptr+ecstackptr;i<len;i++){ /* Copy the string */
323 p[l]=c=exp[i],
324 l++;
325 if(c==quote)i++; /* Omit the next character after a quote. */
326 }
327 ecstackptr+=align(l), /* Pad the string */
328 (*(int *)(cstackptr+ecstackptr))=l, /* and append the length. */
329 ecstackptr+=four;
330 }
331
stackx(exp,len)332 void stackx(exp,len) /* Interpret exp (whose length is len) as a hex
333 constant and stack it */
334 char *exp;
335 int len;
336 {
337 int l=0,o;
338 unsigned char m,n;
339 char d;
340 mtest(cstackptr,cstacklen,ecstackptr+len/2+3*four,len/2+256);
341 /* while(exp[0]==' '&&len)exp++,len--; */ /* leading spaces OK if uncommented*/
342 if(len&&(exp[0]==' '||exp[0]=='\t'))die(Ehex); /* leading spaces not OK */
343 for(o=0;o<len&&exp[o]!=' '&&exp[o]!='\t';o++);/* Find length of first chunk */
344 (o%2)?(o=1):(o=2); /* If odd, the first hex byte has 1 digit, otherwise 2 */
345 while(len){
346 while((exp[0]==' '||exp[0]=='\t')&&len)exp++,len--; /* Skip spaces */
347 /* if(len==0)break; */ /* OK for trailing blanks if uncommented */
348 if(len<o)die(Ehex); /* Error if less than a whole byte exists */
349 for(m=(n=0);m<o;m++){ /* for one byte... */
350 d=(*(exp++))-'0', /* convert a digit to hex */
351 len--;
352 if(d<0)die(Ehex);
353 if(d>9)if((d-=7)<10)die(Ehex);
354 if(d>15)if((d-=32)<10)die(Ehex);
355 if(d>15)die(Ehex);
356 n=n*16+d; /* and accumulate */
357 }
358 o=2, /* Each byte except the first has 2 digits*/
359 cstackptr[ecstackptr++]=n, /* Stack each byte */
360 l++;
361 }
362 ecstackptr+=toalign(l), /* pad the string */
363 (*(int *)(cstackptr+ecstackptr))=l, /* and append the length. */
364 ecstackptr+=four;
365 }
stackb(exp,len)366 void stackb(exp,len) /* Interpret exp as a binary constant and stack it */
367 char *exp;
368 int len;
369 {
370 int l;
371 int al=align(len/8+1); /* maximum amount of space needed */
372 unsigned char c=0,n,b,d;
373 if(!len){stack(exp,len);return;} /* ''b is allowed */
374 mtest(cstackptr,cstacklen,ecstackptr+al+2*four,al+256);
375 if(len && (exp[0]==' '||exp[0]=='\t'))
376 die(Ebin); /* leading spaces not OK */
377 for(l=b=0;l<len;l++)b+=(exp[l]!=' '&&exp[l]!='\t'); /* find number of digits (nonblanks)*/
378 l=0;
379 n=(((b-1)%8)>=4)+1; /* number of nybbles in first byte */
380 b=(b-1)%4+1; /* number of bits in first nybble */
381 while(len){
382 while((exp[0]==' '||exp[0]=='\t')&&len)exp++,len--; /* Skip spaces */
383 if(len<b)die(Ehex); /* Error if less than one nybble exists */
384 while(b--){ /* for each bit of the nybble... */
385 d=exp++[0]-'0';
386 if(d>1)die(Ebin);
387 c=(c<<1)|d; /* add to the current character */
388 len--;
389 }
390 b=4; /* next nybble has 4 bits */
391 if(!--n){ /* a byte was completed */
392 cstackptr[ecstackptr++]=c, /* Stack each byte */
393 l++;
394 n=2; /* next byte has 2 nybbles */
395 }
396 }
397 if(n!=2)die(Ebin); /* half a byte was encountered */
398 ecstackptr+=toalign(l), /* pad the string */
399 (*(int *)(cstackptr+ecstackptr))=l, /* and append the length. */
400 ecstackptr+=four;
401 }
stackint(i)402 void stackint(i) /* stack an integer i */
403 int i;
404 {
405 char num[20];
406 sprintf(num,"%d",i);
407 stack(num,strlen(num));
408 }
409
stacknull()410 void stacknull() /* Stack a null - i.e. a value with length -1 */
411 {
412 mtest(cstackptr,cstacklen,ecstackptr+2*four,256);
413 (*(int *)(cstackptr+ecstackptr))= -1,
414 ecstackptr+=four;
415 }
416
417 /* The various binary and unary operators follow. Each one operates on the
418 top 1 or 2 values on the calculator stack, deletes them, and stacks a
419 result. The single parameter to each routine is the operator number
420 (e.g. OPplus), which serves to distinguish between two or more operators
421 implemented by the same routine. Some routines do not use the operator
422 number. Formatting of the result of arithmetic operators, including
423 rounding to the required precision, is handled by stacknum(). */
424
binplus(op)425 void binplus(op) /* Implements OPadd - the binary + operator */
426 char op;
427 {
428 int n1,n2,n3;
429 int m1,m2;
430 int z1,z2;
431 int e1,e2,e3;
432 int l1,l2,l3;
433 int i;
434 int c=0;
435 int d1,d2;
436 if((n2=num(&m2,&e2,&z2,&l2))<0)die(Enum); /* The two numbers are fetched */
437 delete(&l3); /* and deleted from the stack */
438 if((n1=num(&m1,&e1,&z1,&l1))<0)die(Enum);
439 delete(&l3);
440 if(z1&&z2){stack("0",1);return;}
441 if(z1){stacknum(workptr+n2,l2,e2,m2);return;}
442 if(z2){stacknum(workptr+n1,l1,e1,m1);return;}
443 if(e1<e2)n3=n2,n2=n1,n1=n3,n3=m2,m2=m1,m1=n3,
444 e3=e2,e2=e1,e1=e3,l3=l2,l2=l1,l1=l3; /* now e1>=e2 always */
445 n3=eworkptr+1,e3=e1; /* Initialise a third number. */
446 if(m1==m2){ /* add two numbers; the sign of the result is m1 */
447 l3=(l1>l2+e1-e2)?l1:(l2+e1-e2);
448 if(l3>precision+2)l3=precision+2;
449 mtest(workptr,worklen,eworkptr+l3+2,l3+256); /* Make space for 3rd num */
450 for(i=l3-1;i>=0;i--){
451 if(i>=l1)d1=0;
452 else d1=workptr[n1+i]-'0'; /* Get each digit from n1 */
453 d2=i+e2-e1; /* this gives the position of the */
454 if(d2<0||d2>=l2)d2=0; /* corresponding digit in n2 */
455 else d2=workptr[n2+d2]-'0'; /* Get the digit from n2 */
456 d2+=d1+c; /* add with carry */
457 c=d2/10,d2%=10;
458 workptr[n3+i]=d2+'0'; /* Store the answer */
459 }
460 if(c)n3--,workptr[n3]='0'+c,l3++,e3++; /* carry to the left */
461 }
462 else{ /* subtract the smaller from the larger. The sign of n1-n2 is m1 */
463 if(e1==e2){ /* compare to see which is the largest */
464 for(i=0;i<l1&&i<l2;i++){
465 if(workptr[n1+i]<workptr[n2+i]){ /* swap numbers */
466 n3=n2,n2=n1,n1=n3,l3=l2,l2=l1,l1=l3,m1=m2;
467 break;
468 }
469 if(workptr[n1+i]>workptr[n2+i])break; /* order OK */
470 }
471 if((i==l1&&i==l2)||i>=precision){ /* numbers are equal; return zero */
472 stack("0",1);
473 return;
474 }
475 if(i==l1)n3=n2,n2=n1,n1=n3,l3=l2,l2=l1,l1=l3,m1=m2;
476 /* n1 is an initial segment of n2; swap since n1<n2 */
477 }/* at this point, n1>n2. Now the subtraction goes exactly like the
478 earlier addition. */
479 l3=(l1>l2+e1-e2)?l1:(l2+e1-e2);
480 if(l3>precision+2)l3=precision+2;
481 mtest(workptr,worklen,eworkptr+precision,precision+256);
482 n3=eworkptr;
483 for(i=l3;i>=0;i--){
484 if(i>=l1)d1='0';
485 else d1=workptr[n1+i];
486 d2=i+e2-e1;
487 if(d2<0||d2>=l2)d2='0';
488 else d2=workptr[n2+d2];
489 d1-=d2+c;
490 if(d1<0)d1+=10,c=1;
491 else c=0;
492 if(i<precision)workptr[n3+i]=d1+'0';
493 }
494 if(l3>precision)l3=precision;
495 while(l3&&workptr[n3]=='0')l3--,n3++,e3--;
496 }
497 stacknum(workptr+n3,l3,e3,m1);/* After the operation the result is stacked*/
498 }
499
binmin(op)500 void binmin(op) /* OPsub, the binary - operator, is implemented by */
501 char op; /* negating and adding. */
502 {
503 unmin(op),
504 binplus(op);
505 }
506
binmul(op)507 void binmul(op) /* OPmul, the binary * operator */
508 char op;
509 {
510 int n1,n2,m1,m2,e1,e2,z1,z2,l1,l2;
511 int n3,l3;
512 int i,j,k;
513 int c,d,d1;
514 if((n1=num(&m1,&e1,&z1,&l1))<0)die(Enum); /* Get each number and delete */
515 delete(&l3); /* from the stack */
516 if((n2=num(&m2,&e2,&z2,&l2))<0)die(Enum);
517 delete(&l3);
518 if(l1>precision+2)l1=precision+2;
519 if(l2>precision+2)l2=precision+2;
520 l3=l1+l2;
521 if(z1||z2){stack("0",1);return;} /* zero times x is zero */
522 if(l1<l2)i=l2,l2=l1,l1=i,i=n2,n2=n1,n1=i; /* make sure n2 is the shorter */
523 mtest(workptr,worklen,eworkptr+l3,l3+256);/* Make room for the answer */
524 n3=eworkptr; /* this is where it goes */
525 for(i=0;i<l3;workptr[n3+(i++)]='0'); /* Initially it is zero */
526 for(i=l2-1;i>=0;i--){ /* Now a long multiplication */
527 c=0,
528 d1=workptr[n2+i]-'0';
529 for(j=l1-1;j>=0;j--){
530 k=i+j+1,
531 d=(workptr[n1+j]-'0')*d1+c+workptr[n3+k]-'0',
532 c=d/10,
533 d%=10,
534 workptr[n3+k]=d+'0';
535 }
536 workptr[n3+i]+=c;
537 }
538 if(abs(e1+=e2+1)+2>maxexp)die(Eoflow); /* Calculate the exponent */
539 for(;l3>0&&workptr[n3]=='0';e1--,n3++,l3--); /* Remove leading zeros */
540 stacknum(workptr+n3,l3,e1,m1^m2); /* Stack the answer */
541 }
542
bindiv(op)543 void bindiv(op) /* OPdiv, the binary / operator;
544 OPidiv, the binary % operator, and
545 OPmod, the binary // operator are all handled here */
546 char op;
547 {
548 int n1,n2,m1,m2,e1,e2,z1,z2,l1,l2;
549 int n3,l3;
550 int i,j;
551 int c,d,mul;
552 if((n2=num(&m2,&e2,&z2,&l2))<0)die(Enum);
553 delete(&l3);
554 if((n1=num(&m1,&e1,&z1,&l1))<0)die(Enum);
555 delete(&l3);
556 if(z2)die(Edivide); /* anything divided by zero */
557 if(z1){stack("0",1);return;} /* zero divided by anything */
558 if(l1>precision+2)l1=precision+2;
559 if(l2>precision+2)l2=precision+2;
560 l3=precision+2; /* The number of digits in the quotient */
561 if(op!=OPdiv)l3=e1-e2+1; /* For % and //, the number of digits in
562 the integer quotient. */
563 if(l3<=0){ /* The integer result is a fraction */
564 if(op==OPidiv)stack("0",1); /* integer quotient is zero */
565 else {
566 while(l1>0&&workptr[n1+l1-1]=='0')l1--; /* remove trailing zeros */
567 stacknum(workptr+n1,l1,e1,m1); /* remainder result is n1 */
568 }
569 return;
570 }
571 if(l3>precision+2)l3=precision+2;
572 if(op==OPmod&&l3>precision){
573 stack("0",1);
574 return;/* if l3>precision, return remainder 0 */
575 }
576 /* Now extend n1 to length l2+l3-1 with zeros */
577 mtest(workptr,worklen,eworkptr+l3+l3+l2,l3+l3+l2+256);
578 if(l1<l2+l3)n3=eworkptr+l2+l3-l1;
579 else n3=eworkptr;
580 for(i=l1;i<l2+l3-1;i++)workptr[n1+i]='0';
581 for(i=0;i<l3;i++){ /* loop for each digit of result */
582 workptr[n3+i]='0'; /* Start each result digit at zero */
583 while(1){
584 c=0;
585 z1=1;
586 if(i)d=workptr[n1+i-1]*10+workptr[n1+i]-'0'*11;
587 else d=workptr[n1+i]-'0';
588 mul=d/(workptr[n2]-'0'+1);/* The next digit can't be lower than this*/
589 if(mul==0)mul=1; /* continue until subtraction fails */
590 for(j=l2-1;j>= -i;j--){ /* do a subtraction */
591 if(j>=0)d=workptr[n2+j]-'0';
592 else d=0;
593 d=workptr[n1+i+j]-d*mul-c-'0';
594 if(d)z1=0;
595 c=0;
596 while(d<0)d+=10,c++;
597 workptr[n1+i+j]=d+'0';
598 }
599 if(z1){workptr[n3+i]+=mul;break;} /* Exactly zero resulted */
600 if(!c){workptr[n3+i]+=mul;continue;} /* A positive value resulted */
601 c=0;
602 for(j=l2-1;j>= -i;j--){ /* add back a failed subtraction */
603 if(j>=0)d=workptr[n2+j]-'0';
604 else d=0;
605 d+=workptr[n1+i+j]+c;
606 if(d>'9')d-=10,c=1;
607 else c=0;
608 workptr[n1+i+j]=d;
609 }
610 break; /* This result digit is found */
611 }
612 if(z1&&i>=l1-l2) { /* exact division */
613 l3=i+1;
614 if(op==OPmod){stack("0",1);return;} /* zero remainder */
615 break; /* The entire result is found */
616 }
617 }/* End of division: the result can be stacked */
618 if(op==OPmod){ /* stack the remainder */
619 if(l1<l2+l3)l1=l2+l3-1;
620 for(;l1&&workptr[n1]=='0';l1--,e1--,n1++);
621 for(;l1>0&&workptr[n1+l1-1]=='0';l1--);
622 stacknum(workptr+n1,l1,e1,m1);
623 }
624 else { /* stack the quotient */
625 for(;l3>0&&workptr[n3]=='0';e2++,n3++,l3--);
626 while(l3>0&&workptr[n3+l3-1]=='0')l3--;
627 if(abs(e1-=e2)>maxexp)die(Eoflow);
628 stacknum(workptr+n3,l3,e1,m1^m2);
629 }
630 }
631
binexp(op)632 void binexp(op) /* OPpower, the binary ** operator */
633 char op;
634 {
635 int pow,n,m,e,z,l,pm=0,c=four*8-1; /* Ahem! 8 bits per byte here */
636 char *ptr;
637 pow=getint(1); /* The exponent must be an integer. */
638 if(pow<0)pow= -pow,pm=1; /* find x**(abs(y)) first, then calculate x**y */
639 if((n=num(&m,&e,&z,&l))<0)die(Enum); /* A copy of the first operand */
640 if(pow==0){
641 delete(&l);
642 stack("1",1); /* x ** 0 is 1 */
643 return;
644 }
645 if(z)return; /* 0 ** x is 0 - note the zero operand is still stacked */
646 while(pow>0)pow<<=1,c--;/* Get the MSB of the num into the MSB of the int */
647 precision+=2; /* Temporarily increase precision for good result */
648 while((c--)>0){ /* For each bit of the exponent */
649 rxdup(), /* Square the intermediate result */
650 binmul(op);
651 if((pow<<=1)<0) /* If the next bit of the exponent is set, */
652 stacknum(workptr+n,l,e,m),binmul(op); /* multiply the number in */
653 }
654 if(pm){ /* The exponent was negative, so invert the number */
655 mtest(cstackptr,cstacklen,ecstackptr+2*four,256);
656 ptr=cstackptr+ecstackptr-four,
657 l= align(*(int *)ptr),
658 ptr-=l, /* ptr points to the stack entry containing the result */
659 l+=four, /* l contains its whole length */
660 n=four+align(1);
661 for(c=l-1;c>=0;c--)ptr[c+n]=ptr[c]; /* Make two ints-worth of space */
662 ptr[0]='1',
663 *(int *)(ptr+align(1))=1, /* Store the stack entry "1" in the space */
664 ecstackptr+=n,
665 bindiv(2); /* Now divide 1 by the result. */
666 }
667 precision-=2; /* Restore the old precision */
668 n=num(&m,&e,&z,&l), /* Prepare to reformat the number to the new */
669 delete(&c), /* precision by unstacking and restacking */
670 eworkptr=0;
671 while(l>0&&workptr[n+l-1]=='0')l--; /* first remove trailing zeros */
672 stacknum(workptr+n,l,e,m);
673 }
674
rxdup()675 void rxdup() /* Duplicate the top stack entry */
676 {
677 char *mtest_old;
678 long mtest_diff;
679 char *ptr=cstackptr+ecstackptr;
680 int len= align(*((int *)ptr-1))+four;
681 if dtest(cstackptr,cstacklen,ecstackptr+len,len+256)
682 ptr+=mtest_diff;
683 memcpy(ptr,ptr-len,len), /* Simple, really... */
684 ecstackptr+=len;
685 }
686
binrel(op)687 void binrel(op) /* Implements all the comparison operators. */
688 char op;
689 {
690 int len1,len2;
691 int i;
692 int ans=0;
693 unsigned char *ptr1,*ptr2;
694 int n,m,m2,e1,e2,z,l;
695 n=num(&m2,&e2,&z,&l), /* Test to see whether the top value is a number */
696 ptr2=(unsigned char *)delete(&len2), /* Delete the top value */
697 n=(n<0||num(&m,&e1,&z,&l)<0); /* Test to see whether both are numbers */
698 if(op==OPeequ||op>=OPnneq){ /* The strict comparison operators */
699 ptr1=(unsigned char *)delete(&len1);
700 /* Now see which one is greater, before calculating the required result */
701 if(op>OPnneq||len1==len2){
702 for(i=0;i<len1&&i<len2&&ptr1[i]==ptr2[i];i++);
703 if(i==len1)ans= -!(i==len2); /* string1 is a prefix of string2 */
704 else if(i==len2)ans=1; /* string2 is a prefix of string1 */
705 else ans=ptr1[i]-ptr2[i]; /* strings differ at this character */
706 }
707 else ans=1; /* for == and \== with lengths different, report not equal */
708 switch(op){
709 case OPeequ: ans=!ans; break;
710 case OPnneq: ans=(ans!=0);break;
711 case OPlless:ans=(ans<0); break;
712 case OPggrtr:ans=(ans>0); break;
713 case OPlleq: ans=(ans<=0);break;
714 case OPggeq: ans=(ans>=0);
715 }
716 }
717 else {
718 if (!n) { /* both numeric */
719 if (!n && (m^m2)) /* different signs: */
720 {z=0; delete(&l);} /* sign of result = sign of num1 */
721 else {
722 ecstackptr+=align(len2)+four;/* restack string2 */
723 i=precision,precision=fuzz, /* add fuzz */
724 binmin(op), /* compare using binary - */
725 precision=i,
726 n=num(&m,&i,&z,&l), /* get flags, then discard the result */
727 delete(&l);
728 }
729 }
730 else { /* string comparison; first strip spaces */
731 ecstackptr+=align(len2)+four;/* restack string2 */
732 strip(),
733 ptr2=(unsigned char *)delete(&len2), /* Get pointers and lengths of */
734 strip(), /* the stripped strings and */
735 ptr1=(unsigned char *)delete(&len1); /* delete them from the stack. */
736 for(i=0;i<len1&&i<len2&&ptr1[i]==ptr2[i];i++); /* Compare */
737 if(i==len1)while(i<len2&&ptr2[i]==' ')i++; /* Act as if the shorter */
738 if(i==len2)while(i<len1&&ptr1[i]==' ')i++; /* were padded wth spaces*/
739 if(i>=len1) /* now set flags as for numeric comp. */
740 if(i>=len2)z=1,m=0;
741 else z=0,m=(ptr2[i]>' ');
742 else if(i>=len2)z=0,m=(ptr1[i]<' ');
743 else z=0,m=(ptr1[i]<ptr2[i]);
744 }
745 if(z){if(op==OPequ||op==OPleq||op==OPgeq)ans=1;} /* This gives the */
746 else if(op==OPgrtr&&!m || op==OPneq)ans=1; /* correct result for */
747 if(m){if(op==OPless||op==OPleq)ans=1;} /* the required op */
748 else if(op==OPgeq)ans=1;
749 }
750 ptr1=(unsigned char *)(cstackptr+ecstackptr), /* The result is stacked */
751 ecstackptr+=align(1)+four;
752 (*ptr1)='0'+ans,
753 (*(int *)(ptr1+align(1)))=1;
754 }
binbool(op)755 void binbool(op) /* OPand, OPxor, OPor - binary &, |, && operators */
756 char op;
757 {
758 int z1;
759 int minus,exp,zero,len;
760 if(num(&minus,&exp,&z1,&len)<0)die(Enum); /* Get the two numbers and */
761 delete(&len); /* delete the second */
762 if(num(&minus,&exp,&zero,&len)<0)die(Enum);
763 switch(op){
764 case OPand:if(z1)delete(&len),stack("0",1);
765 break;
766 case OPxor:if(!z1)unnot(op);
767 break;
768 case OPor:if(!z1)delete(&len),stack("1",1);
769 }
770 }
bincat(op)771 void bincat(op) /* OPcat, OPspc - concatenation without/with a space */
772 char op;
773 {
774 int len1,len2,alen1,alen2,count;
775 char *ptr=cstackptr+ecstackptr-four;
776 char *aptr;
777 char *ptr1,*ptr2;
778 alen1=align(len1= *(int *)ptr);
779 ptr1=ptr-alen1;
780 ptr2=ptr1-four;
781 alen2=align(len2= *(int*)ptr2);
782 ptr2-=alen2;
783 aptr=ptr2+len2;
784 if(op==OPspc)*(aptr++)=' ',len2++;
785 for(count=len1;count--;aptr++[0]=ptr1++[0]);
786 ptr2+=align(len1+len2);
787 *(int *)ptr2=len1+len2;
788 ecstackptr=ptr2-cstackptr+four;
789 }
790
unnot(op)791 void unnot(op) /* OPnot, unary \ operator */
792 char op;
793 {
794 int minus,exp,zero,len;
795 if(num(&minus,&exp,&zero,&len)<0)die(Enum);
796 delete(&len);
797 if(zero)stack("1",1);
798 else stack("0",1);
799 }
unmin(op)800 void unmin(op) /* OPneg, unary - */
801 char op;
802 {
803 int a,b;
804 int minus,exp,zero,len;
805 if((a=num(&minus,&exp,&zero,&len))<0)die(Enum);
806 delete(&b);
807 if(zero)stack("0",1);
808 else stacknum(workptr+a,len,exp,!minus); /* restack with opposite sign */
809 }
unplus(op)810 void unplus(op) /* OPplus, unary + -just unstack and restack, thus checking */
811 char op; /* that it is numeric and reformatting it */
812 {
813 int a,b;
814 int minus,exp,zero,len;
815 if((a=num(&minus,&exp,&zero,&len))<0)die(Enum);
816 delete(&b);
817 if(zero)stack("0",1);
818 else stacknum(workptr+a,len,exp,minus);
819 }
820
strip()821 void strip() /* Strip leading and trailing spaces from the top stack value */
822 {
823 char *ptr=cstackptr+ecstackptr-four;
824 char *ptr1;
825 int len= *(int *)ptr;
826 int i;
827 ptr-=align(len), /* Point to the value */
828 ptr1=ptr, /* save the original pointer */
829 ecstackptr-=align(len); /* discount the original length */
830 for(;len>0&&ptr[0]==' ';len--,ptr++); /* Skip leading spaces */
831 for(;len>0&&ptr[len-1]==' ';len--); /* Remove trailing spaces */
832 if(ptr==ptr1)ptr1+=len; /* If no leading spaces leave the value in place */
833 else for(i=0;i<len;i++,(*(ptr1++))=(*(ptr++))); /* else move it back */
834 (*(int *)(ptr1+toalign(len)))=len,
835 ecstackptr+=align(len);
836 }
837
num(minus,exp,zero,len)838 int num(minus,exp,zero,len)
839 int *minus,*exp,*zero,*len;
840 { /* examines the `last value' on the calculator stack to determine whether
841 it is numeric (always leaves the number stacked). If not, then the answer
842 is -1, otherwise the answer is an offset within the workspace where a
843 sequence of digits is to be found. In this case, the sequence of digits,
844 when a decimal point is added between the 1st and 2nd digits and the
845 result is multiplied by 10**exp, is equal to the magnitude of the number.
846 `minus' is 1 if the number is negative; `zero' is 1 if the number is zero,
847 and `len' is the length of the sequence of digits. */
848 register char *ptr1=cstackptr+ecstackptr-four;
849 register int ptr2=eworkptr;
850 int ans=ptr2;
851 register int len1= *(int *)ptr1;
852 int dot=0;
853 int etmp,emin;
854 register int myzero=1; /* fast-access copy of "*zero" */
855 register int myexp=-1; /* and of *exp */
856 register int ch;
857 if(len1<0)die(Ecall); /* doing any numeric operation whatsoever on a 'null'
858 is strictly forbidden! */
859 ptr1-=align(len1); /* ptr1 points to the value, len1 holds its length */
860 mtest(workptr,worklen,ptr2+len1,len1+256);
861 (*minus)=0; /* Assume positive; set negative if '-' found */
862 for(;ptr1[0]==' '&&len1>0;len1--,ptr1++); /* Skip leading spaces */
863 for(;len1>0&&ptr1[len1-1]==' ';len1--); /* and trailing spaces */
864 if((ch=ptr1[0])=='-')ptr1++,len1--,(*minus)=1; /* Deal with leading sign */
865 else if(ch=='+')ptr1++,len1--;
866 for(;ptr1[0]==' '&&len1>0;len1--,ptr1++); /* and spaces after it */
867 if(len1<=0||(ch=ptr1[0])>'9'||ch=='.'&&(len1==1||ptr1[1]>'9'))
868 return -1; /* initial check for validity */
869 for(;len1>0;ptr1++,len1--){ /* Now, examine each character of the number */
870 if((ch=ptr1[0])=='0'&&myzero){
871 if(dot)myexp--; /* Each leading 0 after the dot divides by 10 */
872 continue;
873 }
874 if(ch>='0'&&ch<='9'){
875 myzero=0; /* Either zero was false already, or a non-zero digit was
876 found. */
877 if(!dot)myexp++; /* Each figure before the dot multiplies by 10 */
878 workptr[ptr2++]=ch;
879 }
880 else if(ch=='.'){
881 if(dot)return -1; /* Count the number of dots */
882 dot=1;
883 }
884 else if((ch&0xdf)=='E'){ /* Now deal with an exponent */
885 ptr1++,len1--;
886 emin=etmp=0;
887 if((ch=ptr1[0])=='-')emin=1,ptr1++,len1--;
888 else if(ch=='+')ptr1++,len1--;
889 if(len1<=0)return -1;
890 for(;len1>0;ptr1++,len1--){
891 if((ch=ptr1[0]-'0')<0||ch>9)return -1; /* Must contain digits */
892 etmp=etmp*10+ch;
893 if(etmp>maxexp)die(Eoflow);
894 }
895 *len=ptr2-ans;
896 eworkptr=ptr2;
897 if(*zero=myzero) return *exp=*minus=0,ans; /* No exponent if zero */
898 if(emin)etmp= -etmp; /* Otherwise set the exponent and return. */
899 (*exp)=myexp+etmp;
900 return ans;
901 }
902 else return -1; /* Each character must be a digit or "E" or "." */
903 }
904 *len=ptr2-ans;
905 if(*zero=myzero) *exp=*minus=0; /* no exponent or sign if zero */
906 else *exp=myexp;
907 eworkptr=ptr2; /* Protect this number from being overwritten, */
908 return ans; /* and return it. */
909 }
910
getint(flg)911 int getint(flg)
912 int flg;
913 { /* get an integer from the calculator stack. Error if overflow.
914 if flg=1 and the number was non-integral an error is raised */
915 int n,minus,exp,zero,len,d;
916 unsigned ans=0;
917 if((n=num(&minus,&exp,&zero,&len))<0)die(Enum); /* First get the number */
918 delete(&d); /* and delete it */
919 if(zero)return 0;
920 for(;len>0&&workptr[n+len-1]=='0';len--); /* remove trailing zeros */
921 if(flg&&len>exp+1)die(Enonint); /* not an integer */
922 for(;len>0&&exp>=0;exp--,len--,n++){ /* now collect all the digits */
923 ans=ans*10+workptr[n]-'0';
924 if((int)ans<0)die(Erange);
925 } /* Take account of the exponent. */
926 for(;exp>=0;exp--,ans*=10)if((int)ans<0)die(Erange);
927 if(minus)ans= -ans; /* and finally, give the correct sign. */
928 return ans;
929 }
930
isint(num,len,exp)931 int isint(num,len,exp) /* Given components of a number obtained by num(), */
932 int num,len,exp; /* tell whether it represents an integer. */
933 {
934 for(;len>0&&workptr[num+len-1]=='0';len--);
935 return len<=exp+1&&exp<precision&&(exp<9||exp==9&&workptr[num]<'2');
936 }
937
delete(len)938 char *delete(len) /* Delete an item from the calculator stack, returning */
939 int *len; /* its position and setting "len" to its length. The */
940 { /* item is not actually deleted from memory, so it can */
941 /* still be examined, but it will probably soon be */
942 /* overwritten by new values on the stack. */
943 char *ptr=cstackptr+ecstackptr-four;
944 (*len)= *(int *)ptr;
945 if(*len>=0)ptr-= align(*len),
946 ecstackptr-= align(*len);
947 else ptr=(char *)-1; /* I don't think this value is ever used */
948 ecstackptr-=four;
949 return ptr;
950 }
951
isnull()952 int isnull() /* Tell whether the top value on the stack is null, i.e. */
953 { /* has length = -1 */
954 char *ptr=cstackptr+ecstackptr-four;
955 return (*(int *)ptr)<0;
956 }
957
stacknum(num,len,exp,minus)958 void stacknum(num,len,exp,minus)
959 char *num;
960 int exp,len,minus;
961 { /* stack the number given by sequence of digits `num' of length `len'
962 and exponent `exp'. minus=0 if the number is positive, 1 if negative. */
963 char *ptr1;
964 int len1=0;
965 int i;
966 mtest(cstackptr,cstacklen,ecstackptr+len+30,len+256);
967 ptr1=cstackptr+ecstackptr;
968 if(len<=0)num="0",len=1,exp=0,minus=0;
969 if(len>precision) /* Round to the correct number of digits */
970 if(num[len=precision]>='5'){
971 for(i=len-1;i>=0;i--){
972 if(++num[i]<='9')break;
973 num[i]='0';
974 }
975 if(i<0){ /* change 999995 to 10000E+1 (or whatever) */
976 for(i=len-2;i>=0;i--)num[i+1]=num[i];
977 num[0]='1',
978 exp++;
979 }
980 } /* Now stack the digits, starting with a sign if negative */
981 if(minus)ptr1[len1++]='-';
982 if(len-exp-1<=2*precision&&exp<precision){ /* stack with no exponent */
983 if(exp<0){ /* begin with 0.00...0 */
984 ptr1[len1++]='0',
985 ptr1[len1++]='.';
986 for(i= -1;i>exp;i--)ptr1[len1++]='0';
987 }
988 while(len>0){ /* stack the digits */
989 ptr1[len1++]=num[0],
990 num++,
991 len--,
992 exp--;
993 if(len&&exp==-1)ptr1[len1++]='.'; /* remembering the decimal point */
994 }
995 while(exp>-1)ptr1[len1++]='0',exp--; /* Add zeros up to the decimal pt */
996 }
997 else{ /* stack floating point in appropriate form with exponent */
998 ptr1[len1++]=num++[0],len--; /* The (first) digit before the "." */
999 if(numform)while(exp%3) /* For engineering, up to two more */
1000 exp--, /* digits are required before "." */
1001 ptr1[len1++]=(len-->0 ? (num++)[0] : '0');
1002 if(len>0){ /* Now the "." and the rest of the */
1003 ptr1[len1++]='.'; /* digits. */
1004 while(len--)ptr1[len1++]=(num++)[0];
1005 }
1006 if(exp){ /* Add the exponent */
1007 ptr1[len1++]='E',
1008 ptr1[len1++]= exp<0 ? '-' : '+',
1009 exp=abs(exp);
1010 if(exp>maxexp)die(Eoflow);
1011 for(i=1;i<=exp;i*=10);
1012 i/=10;
1013 for(;i>=1;i/=10)
1014 ptr1[len1++]=exp/i+'0',
1015 exp%=i;
1016 }
1017 }
1018 *(int *)(ptr1+align(len1))=len1; /* Finish off the stack entry. */
1019 ecstackptr+=align(len1)+four;
1020 }
1021
getvarname(line,ptr,varname,namelen,maxlen)1022 void getvarname(line,ptr,varname,namelen,maxlen) /* Go along a program line,
1023 accumulating characters to form a variable name. If
1024 it is a compound symbol, the substitution in the tail
1025 is performed here also. If the character pointer
1026 does not point to a valid symbol, then on exit
1027 varname[0]=namelen=0. */
1028 char *line; /* the program line */
1029 int *ptr; /* the current character pointer */
1030 char *varname; /* where to put the variable name */
1031 int *namelen; /* the length of the returned variable name */
1032 int maxlen; /* the amount of space allocated to varname */
1033 {
1034 char *exp,*exp1,*vg;
1035 char c;
1036 int expn;
1037 int explen;
1038 int disp=trcflag&Tintermed; /* whether to trace compound symbols */
1039 char quote;
1040 maxlen-=2; /* a safety margin :-) */
1041 if(rexxsymbol(line[*ptr])<1) /* Test the starting character */
1042 {varname[0]=0;(*namelen)=0;return;}
1043 for(exp=varname;rexxsymbol(line[*ptr]);exp++,(*ptr)++){
1044 if(exp-varname>maxlen)die(Elong); /* Copy the stem or simple symbol */
1045 (*exp)=line[*ptr];
1046 }
1047 if(line[*ptr]=='.'){
1048 varname[0]|=128; /* flag: not a simple symbol */
1049 if((c=line[*ptr+1])<=' '||!(rexxsymboldot(c)||c=='('||c=='\''||c=='\"'))
1050 (*ptr)++; /* stem - step past the final dot */
1051 else disp|=4; /* compound symbol (so display it) */
1052 }
1053 while(line[*ptr]=='.'){/* Loop to interpret the qualifiers of a comp.symb.*/
1054 (*ptr)++,
1055 (*(exp++))='.'; /* Step past and copy the dot */
1056 if(line[*ptr]<=' ')break; /* Stop if at a space, terminator, or token */
1057 switch(line[*ptr]){ /* What kind of qualifier is it? */
1058 case '.':break; /* null qualifier */
1059 case '(':(*ptr)++, /* parenthesised expression e.g. stem.(a+b) */
1060 exp1=scanning(line,ptr,&explen), /* Get the expression */
1061 ecstackptr=exp1-cstackptr; /* delete the expression */
1062 if(exp+explen-varname>maxlen)die(Elong);
1063 memcpy(exp,exp1,explen), /* Copy to the varname */
1064 exp+=explen;
1065 if(line[(*ptr)++]!=')')die(Elpar);/* Expect ')' */
1066 break;
1067 case '\'': /* Quoted expression e.g. stem.'tail' */
1068 case '\"':quote=line[(*ptr)++];
1069 for(expn= *ptr;(line[expn++])!=quote;);/*Find the matching quote */
1070 if(exp+expn-*ptr-varname>maxlen)die(Elong);
1071 memcpy(exp,line+*ptr,expn-*ptr-1), /* Copy the string */
1072 exp+=expn-*ptr-1,
1073 (*ptr)=expn;
1074 break;
1075 default: exp1=exp; /* The usual qualifier - a symbol */
1076 while(rexxsymbol(line[*ptr])){ /* append the symbol to the name */
1077 if(exp-varname>maxlen)die(Elong);
1078 (*(exp++))=line[(*ptr)++];
1079 }
1080 if(exp1!=exp&&rexxsymbol(exp1[0])==1){/* non-null non-constant */
1081 (*exp)=0,
1082 vg=varget(exp1,exp-exp1,&explen); /* See if the sym has a val */
1083 if(vg!=cnull){ /* if so, substitute */
1084 exp=exp1;
1085 if(exp+explen-varname>maxlen)die(Elong);
1086 memcpy(exp,vg,explen),
1087 exp+=explen;
1088 }
1089 }
1090 }
1091 }
1092 if(disp==12){ /* tracing compound symbols */
1093 c=varname[0];
1094 varname[0]&=0x7f; /* Don't print the "stem" flag */
1095 traceline(">C>",varname,exp-varname);
1096 varname[0]=c;
1097 }
1098 (*exp)=0,
1099 (*namelen)=exp-varname;
1100 }
1101
skipvarname(line,ptr)1102 void skipvarname(line,ptr) /* Skip a variable name in a program line */
1103 /* It is guaranteed to start with a valid char */
1104 char *line; /* the program line */
1105 int *ptr; /* the current character pointer */
1106 {
1107 char quote;
1108 int paren;
1109 while(rexxsymbol(line[*ptr])) (*ptr)++;
1110 while(line[*ptr]=='.'){/* Loop to skip the qualifiers of a compound symbol*/
1111 (*ptr)++; /* step past the dot */
1112 if(line[*ptr]<=' ')break; /* Stop if at a space, terminator, or token */
1113 switch(line[*ptr]){ /* What kind of qualifier is it? */
1114 case '.':break; /* null qualifier */
1115 case '(':(*ptr)++; /* parenthesised expression e.g. stem.(a+b) */
1116 for(paren=1;paren&&line[*ptr]&&line[*ptr]!=-1;(*ptr)++)
1117 if(line[*ptr]=='(')paren++; /* Find matching ')' */
1118 else if(line[*ptr]==')')paren--;
1119 if(paren)die(Elpar);
1120 break;
1121 case '\'': /* Quoted expression e.g. stem.'tail' */
1122 case '\"':quote=line[(*ptr)++];
1123 while((line[(*ptr)++])!=quote); /* Find the matching quote */
1124 break;
1125 default: /* The usual qualifier - a symbol */
1126 while(rexxsymbol(line[*ptr]))(*ptr)++;
1127 }
1128 }
1129 }
1130
gettoken(line,ptr,varname,maxlen,ex)1131 int gettoken(line,ptr,varname,maxlen,ex) /* Go along a program line and form
1132 a token, i.e. a sequence of characters which are valid in symbols - such
1133 as the word coming after SIGNAL. The token may be quoted, in which case
1134 the return value is 2, or a symbol, in which case 1 is returned. If ex
1135 is non-zero and the token is obviously not a symbol or a quoted string,
1136 then it may be an entire expression, perhaps preceded by VALUE - as in
1137 SIGNAL VALUE x. In that case 0 is returned. The token is terminated
1138 with a null after it has been collected. */
1139 char *line; /* the program line */
1140 int *ptr; /* the character pointer */
1141 char *varname; /* where to put the token */
1142 int maxlen; /* the amount of space available in varname */
1143 int ex; /* whether or not an entire expression is allowed */
1144 {
1145 char *exp;
1146 int i;
1147 int explen;
1148 char quote;
1149 if(rexxsymboldot(line[*ptr])){ /* it's just a simple symbol */
1150 for(i=0;rexxsymboldot(line[*ptr]);varname[i++]=line[(*ptr)++])
1151 if(i>=maxlen-2)die(Elong);
1152 varname[i]=0;
1153 return 1;
1154 }
1155 if((quote=line[(*ptr)++])=='\''||quote=='\"'){ /* it's a string constant */
1156 for(i=0;(varname[i++]=line[(*ptr)++])!=quote;) if(i>=maxlen-1)die(Elong);
1157 varname[--i]=0;
1158 /* if(!i)die(Enostring); We allow null strings except where checked individually */
1159 return 2;
1160 }
1161 if(!ex)die(Enostring); /* it must be an expression; is that allowed? */
1162 if(line[--*ptr]==VALUE)(*ptr)++; /* VALUE is optional here */
1163 if(!line[*ptr])die(Enostring);
1164 scanning(line,ptr,&explen); /* get the expression */
1165 exp=delete(&explen);
1166 if(explen>maxlen-1)die(Elong);
1167 memcpy(varname,exp,explen); /* and copy it */
1168 varname[explen]=0;
1169 if(line[*ptr]==')')die(Erpar); /* save some work by flagging extra ')'s
1170 now. This must be the end of a clause. */
1171 return 0;
1172 }
1173