1 /* The Utility functions of REXX/imc (C) Ian Collier 1992 */
2
3 #include<stdio.h>
4 #include<unistd.h>
5 #include<stdlib.h>
6 #include<dirent.h>
7 #include<errno.h>
8 #include<memory.h>
9 #include<string.h>
10 #include<setjmp.h>
11 #include<sys/types.h>
12 #include<sys/time.h>
13 #include<sys/stat.h>
14 #include<sys/file.h>
15 #include<sys/param.h>
16 #include"const.h"
17 #include"globals.h"
18 #include"functions.h"
19 #define INCL_REXXSAA
20 #include "rexxsaa.h"
21 #ifdef Solaris
22 # include<sys/uio.h>
23 # include<sys/filio.h>
24 # include<sys/fcntl.h>
25 #endif
26
27 char *words[]= /* Keywords in order of their values */
28 {"SAY", "SAYN", "DO", "END", "IF", "ELSE", "SELECT", "WHEN",
29 "OPTIONS", "PARSE", "PUSH", "QUEUE", "EXIT", "RETURN", "CALL",
30 "SIGNAL", "ITERATE", "LEAVE", "INTERPRET", "TRACE", "OTHERWISE",
31 "NOP", "PROCEDURE", "ADDRESS", "NUMERIC", "DROP", "THEN", "PULL",
32 "ARG", "SOURCE", "VAR", "VERSION", "LINEIN", "VALUE", "WITH",
33 "UPPER", "TO", "BY", "FOR", "FOREVER", "WHILE", "UNTIL", "ON", "OFF",
34 "DIGITS", "FUZZ", "FORM", "EXPOSE", "HIDE", "NAME"};
35
message(rc)36 char *message(rc) /* Return errortext(rc) */
37 int rc;
38 {
39 char *sys_err;
40 if (rc== -3 && fname[0]!=0) perror(fname);
41 switch (rc){
42 case -3: return "Error loading program";
43 case Einit: return "Initialisation error";
44 case Ehalt: return "Program interrupted";
45 case Emem: return "Machine storage exhausted";
46 case Equote: return "Unmatched \'/*\' or quote";
47 case Enowhen: return "Expected WHEN/OTHERWISE";
48 case Ethen: return "Unexpected THEN/ELSE";
49 case Ewhen: return "Unexpected WHEN/OTHERWISE";
50 case Eend: return "Unexpected or unmatched END";
51 case Echar: return "Invalid character in program";
52 case Enoend: return "Incomplete DO/SELECT/IF";
53 case Ehex: return "Invalid binary or hexadecimal string";
54 case Elabel: return "Label not found";
55 case Eprocedure:return "Unexpected PROCEDURE";
56 case Enothen: return "Expected THEN";
57 case Enostring: return "String or symbol expected";
58 case Enosymbol: return "Symbol expected";
59 case Exend: return "Invalid data on end of clause";
60 case Etrace: return "Invalid TRACE request";
61 case Etrap: return "Invalid subkeyword found";
62 case Erange: return "Invalid whole number";
63 case Exdo: return "Invalid DO syntax";
64 case Eleave: return "Invalid LEAVE or ITERATE";
65 case Elong: return "Symbol > 250 characters";
66 case Ename: return "Name starts with number or \'.\'";
67 case Ebadexpr: return "Invalid expression";
68 case Elpar: return "Unmatched \'(\'";
69 case Ecomma: return "Unexpected \',\' or \')\'";
70 case Eparse: return "Invalid template";
71 case Eopstk: return "Evaluation stack overflow (> 30 pending operations)";
72 case Ecall: return "Incorrect call to routine";
73 case Enum: return "Bad arithmetic conversion";
74 case Eoflow: return "Arithmetic overflow or underflow";
75 case Eundef: return "Routine not found";
76 case Enoresult: return "Function did not return data";
77 case Ereturn: return "No data specified on function RETURN";
78 case Exlabel: return "Unexpected label";
79 case Esys: return "Failure in system service";
80 case Elost: return "Implementation error";
81 case Eincalled: return "Error in called routine";
82 case Enovalue: return "No-value error";
83 case Eexist: return "Use of an un-implemented feature!";
84 case Esyntax: return "Syntax error";
85 case Elabeldot: return "Label ends with \'.\'";
86 case Ercomm: return "Unexpected \'*/\'";
87 case Emanyargs: return "Too many arguments (> 30)";
88 case Eerror: return "ERROR condition occurred";
89 case Efailure: return "FAILURE condition occurred";
90 case Eerrno: return "Unknown error occurred during I/O";
91 case Ebounds: return "File position was out of bounds";
92 case Eseek: return "Reposition attempted on transient stream";
93 case Eaccess: return "Write attempted on a read-only stream";
94 case Eread: return "Read attempted on a write-only stream";
95 case Eeof+Eerrno:return"End of file";
96 }
97 if(rc>Eerrno && (sys_err=strerror(rc-Eerrno))) return sys_err;
98 return "";
99 }
100
rcset(rc,type,desc)101 void rcset(rc,type,desc)/* set rc on return from system call */
102 int rc; /* What to set rc to */
103 int type; /* What error to die with if the error is trapped */
104 char *desc; /* Description for condition(d) */
105 {
106 char rcbuf[20]; /* just turn rc into a string and call the */
107 sprintf(rcbuf,"%d",rc);/* next function... */
108 rcstringset(rc,rcbuf,strlen(rcbuf),type,desc);
109 }
110
rcstringset(rc,rcval,rclen,type,desc)111 void rcstringset(rc,rcval,rclen,type,desc)/* set rc on return from system call */
112 int rc; /* numeric value of rc if appropriate */
113 char *rcval; /* Pointer to what to set rc to */
114 int rclen; /* Length of what to set rc to */
115 int type; /* What error to die with if the error is trapped */
116 char *desc; /* Description for condition(d) */
117 {
118 int bit=type==Eerror?Ierror:type==Efailure?Ifailure:Inotready;
119 int catch=rc&&(sgstack[interplev].bits&(1<<bit));
120 int call=rc&&(sgstack[interplev].callon&(1<<bit));
121 if(interact>=0 && interact+1==interplev)
122 return; /* no action for interactive commands */
123 if(rc && call==0 && catch==0 && (type==Efailure||type==Enotready&&setrcflag))
124 type=Eerror,
125 bit=Ierror,
126 catch=sgstack[interplev].bits&(1<<bit),
127 call=sgstack[interplev].callon&(1<<bit);
128 if(type!=Enotready || setrcflag) /* set rc after a command */
129 varset("RC",2,rcval,rclen);
130 if(rc && type==Enotready)lasterror=rc; /* save an I/O error */
131 if(call||catch){
132 if(sigdata[bit])free(sigdata[bit]);
133 strcpy(sigdata[bit]=allocm(1+strlen(desc)),desc);
134 }
135 if(call)delayed[bit]=1;
136 else if(catch)die(type);
137 }
138
printrc(i)139 void printrc(i) /* Print a trace line showing the return code */
140 int i;
141 {
142 tracestr(" +++ RC=");
143 tracenum(i,1);
144 tracestr(" +++\n");
145 }
146
147 /* An exit handling routine */
exitcall(main,sub,parm)148 int exitcall(main,sub,parm)
149 long main;
150 long sub;
151 PEXIT parm;
152 { /* very simple. */
153 long exrc=exitlist[main](main,sub,parm);
154 if(exrc==RXEXIT_RAISE_ERROR)die(Esys);
155 return exrc;
156 }
157
158 /* Variable handling routines */
159 /* The following routines are low-level and serve to abstract from the
160 variables' actual representation. As long as the following routines
161 are correct, the representation may be changed without affecting
162 the rest of the program. */
163
164 /* These routines maintain a multiple-level variable table, containing
165 names and values of variables. The names of simple symbols and stems
166 are kept in a binary tree arrangement, in the format of a varent
167 structure followed by a name (padded to a multiple of 4 bytes) and a
168 value. Symbols which have been DROPped still exist, but have a value
169 length of -1. Symbols which are copies of variables in earlier levels
170 have a negative "valalloc" value indicating the level number (starting
171 at -1, which means level 0).
172 Stems have no trailing dot, but have bit 7 of the first character
173 inverted, and the value of a stem is a structure containing a default
174 value (an allocated,length,value triple) followed by a binary
175 tree of tails associated with values as in the main table
176 The binary tree structure should allow access in O(log n) time, except
177 when the value pointers need to be updated (when lengthening or
178 shortening a value). However no fancy balancing tricks are used, so
179 O(n) time is possible in the worst case. A special order is imposed
180 which should minimise the possibility of a very unbalanced tree. In
181 particular, assigning the letters a-i or the numbers 0-9 in order
182 should produce an optimal depth tree (whereas with the usual ordering
183 a linear depth tree results).
184 The less and grtr fields contain offsets from the start of the level, and
185 the next field contains the length of one variable entry. When a variable
186 is lengthened or shortened, its own next field is updated, and the less
187 and grtr fields of all variables in the same level are updated. All other
188 pointers, except for the pointers to each level, remain the same.
189 */
less(s1,s2,n1,n2)190 int less(s1,s2,n1,n2)/* the ordering - compare s1,len n1 with s2,len n2*/
191 char *s1,*s2; /* return -ve (s1<s2), 0 (s1=s2) or +ve (s1>s2). */
192 int n1,n2;
193 {
194 static char xlate[]={4,7,3,11,1,5,9,13,0,2,6,8,10,12,15,14};
195 /* the translation table for ordering */
196 char x,y;
197 int r;
198 if(n1!=n2)return n1-n2; /* Order on lengths first (it's faster) */
199 if(!n1)return 0; /* "" == "" */
200 while(n1--&&s1++[0]==s2++[0]); /* find first non-match character */
201 x=s1[-1],y=s2[-1];
202 r=(x&0xf0)-(y&0xf0); /* compare last characters */
203 if (r) return r;
204 return xlate[x&0xf]-xlate[y&0xf]; /* use translation for last 4 bits */
205 }
206
varsearch(name,len,level,exist)207 char *varsearch(name,len,level,exist)
208 char *name;
209 int len;
210 int *level;
211 int *exist;
212 /* search for name `name' of length `len' in the variable table for `level'.
213 The answer is the address of the entry which matches, with `exist'
214 non-zero, or, if the name does not exist, exist=0 and the answer
215 is the address of the slot where the new branch of the tree is to
216 be added. If there are no names in the table, 0 is returned.
217 On exit, level contains the level number where the variable was actually
218 found, which may be different from the given level due to exposure */
219 {
220 char *data=varstk[*level]+vartab;
221 char *ans=data;
222 int *slot;
223 int c;
224 *exist=0;
225 if(varstk[*level]==varstk[*level+1])return cnull;
226 while((c=less(name,ans+sizeof(varent),len,((varent *)ans)->namelen))
227 && (*(slot= &(((varent *)ans)->less)+(c>0)))>=0)
228 ans=data+*slot; /* Go down the tree */
229 if(!c){ /* Equality resulted from the compare */
230 *exist=1;
231 if((c=((varent *)ans)->valalloc)<0){ /* An exposed variable */
232 *level= -(c+1);
233 return varsearch(name,len,level,exist);
234 }
235 else return ans;
236 }
237 return (char *)slot;
238 }
239
tailsearch(stem,name,len,exist)240 char *tailsearch(stem,name,len,exist)/* like varsearch, but searches for the */
241 char *stem,*name; /* tail of a compound variable. */
242 int len,*exist;
243 {
244 char *data=stem+sizeof(varent)+align(((varent *)stem)->namelen);
245 char *tails=data+2*four+*(int *)data; /* start of tail information */
246 char *ans=tails;
247 int *slot;
248 int c;
249 *exist=0;
250 if(((varent *)stem)->vallen==tails-data)return cnull;
251 while((c=less(name,ans+sizeof(varent),len,((varent *)ans)->namelen))
252 && (*(slot= &(((varent *)ans)->less)+(c>0)))>=0)
253 ans=tails+*slot;
254 if(c)return (char* )slot;
255 *exist=1;
256 return ans;
257 }
258
valuesearch(name,namelen,level,exist,stem)259 char *valuesearch(name,namelen,level,exist,stem) /* search for any variable */
260 char *name; /* if a simple symbol, the result is like varsearch*/
261 int namelen; /* and stem=0. If a compound symbol, level ends up */
262 int *level,*exist; /* with the level containing the whole symbol and */
263 char **stem; /* stem points to the stem containing it. exist is */
264 /* non-zero if the whole symbol was found; stem is */
265 /* non-zero if a stem was found, even if it does */
266 /* not contain the required tail. The return value */
267 /* is the variable entry (if exist), or a slot in */
268 /* which to put the new tail (if stem && !exist), */
269 /* or a slot in which to put the new stem (if */
270 /* !stem). The answer is zero if there are no */
271 /* entries in the stem (if stem) or if there are no*/
272 /* entries in the vartable (if !stem). */
273 /* If the variable name is an existing stem, 0 is */
274 { /* returned with exist=0 and stem pointing to it */
275 char *ans;
276 char *tail;
277 int stemlen;
278 int taillen;
279 register int l;
280 if(!(name[0]&128)) /* if a simple symbol, the result is like varsearch */
281 return *stem=0,varsearch(name,namelen,level,exist);
282 stemlen=(tail=memchr(name,'.',namelen))-name;
283 if(!tail)stemlen=namelen,taillen=0;
284 else tail++,taillen=namelen-stemlen-1;
285 while(1){
286 if(!(*stem=varsearch(name,stemlen,level,exist))) return 0; /* no vars */
287 if(!*exist) return ans= *stem,*stem=0,ans; /* no stem */
288 if(!tail) return (*exist=0),cnull; /* name is a stem */
289 if(!(ans=tailsearch(*stem,tail,taillen,exist)))return 0; /* no tails */
290 if(!*exist)return ans; /* no tail */
291 if((l=((varent *)ans)->valalloc)>=0)return ans; /* it's here */
292 *level=-(l+1); /* it's elsewhere */
293 }
294 }
295
printtree(lev)296 void printtree(lev) /* for testing */
297 int lev;
298 {
299 varent *v;
300 char *c,*d;
301 int level=lev;
302 int i;
303 if(level<0||level>varstkptr)level=varstkptr; /* guard against parameterless
304 call */
305 v=(varent *)(vartab+varstk[level]),c=vartab+varstk[level+1];
306 while((char *)v<c){
307 printf("Offset:%d\n",((char *)v)-vartab-varstk[level]),
308 printf(" next=%d\n",v->next),
309 printf(" less=%d\n",v->less),
310 printf(" grtr=%d\n",v->grtr),
311 printf(" namelen=%d\n",v->namelen),
312 printf(" valalloc=%d\n",v->valalloc),
313 printf(" vallen=%d\n",v->vallen),
314 printf(" name="),
315 i=v->namelen,
316 d=sizeof(varent)+(char *)v;
317 while(i-->0)putchar(d++[0]&127);
318 putchar('\n');
319 v=(varent *)(v->next+(char *)v);
320 }
321 }
322
printtails(stem)323 void printtails(stem) /* for testing */
324 varent *stem;
325 {
326 varent *v;
327 char *c,*d,*e;
328 int i;
329 c=(char *)(stem+1)+align(stem->namelen);
330 printf("Default value alloc %d len %d value %s\n",*(int*)c,*((int *)c+1),
331 *((int *)c+1)<0?"":c+2*four);
332 d=c+*(int *)c+2*four,
333 v=(varent *)d,c+=stem->vallen;
334 while((char *)v<c){
335 printf("Offset:%d\n",((char *)v)-d),
336 printf(" next=%d\n",v->next),
337 printf(" less=%d\n",v->less),
338 printf(" grtr=%d\n",v->grtr),
339 printf(" namelen=%d\n",v->namelen),
340 printf(" valalloc=%d\n",v->valalloc),
341 printf(" vallen=%d\n",v->vallen),
342 printf(" name="),
343 i=v->namelen,
344 e=sizeof(varent)+(char *)v;
345 while(i-->0)putchar(e++[0]&127);
346 putchar('\n');
347 v=(varent *)(v->next+(char *)v);
348 }
349 }
350
update(value,amount,level)351 void update(value,amount,level)
352 int value,amount,level;
353 { /* update all the less/grtr fields of level `level' by `amount' if greater
354 than `value'; adjust the level pointers also. This routine is called
355 *after* the space has been created or reclaimed. */
356 register varent *ptr;
357 int l=level;
358 while(l++<=varstkptr)varstk[l]+=amount;
359 for( ptr=(varent *)(vartab+varstk[level]);
360 (char *)ptr<vartab+varstk[level+1];
361 ptr=(varent *)((char *)ptr+ptr->next))
362 {
363 if(ptr->less>value)ptr->less+=amount;
364 if(ptr->grtr>value)ptr->grtr+=amount;
365 }
366 }
367
makeroom(var,amount,level)368 long makeroom(var,amount,level) /* var points to a (complete) variable entry */
369 int var,amount,level; /* which is to be enlarged by amount. var is */
370 { /* an integer offset from the start of level */
371 register char *i; /* the return is the difference from dtest */
372 register char *j;
373 varent *k;
374 char *mtest_old;
375 long mtest_diff;
376 if(!dtest(vartab,vartablen,varstk[varstkptr+1]+amount+2,amount+512))
377 mtest_diff=0;
378 k=((varent *)(j=vartab+varstk[level]+var)); /* the variable's address */
379 j+=(k->next); /* the end of the variable */
380 for(i=vartab+varstk[varstkptr+1]-1;i>=j;i--)i[amount]=i[0]; /* make room */
381 k->next+=amount;
382 update(var,amount,level);
383 return mtest_diff;
384 }
385
reclaim(var,amount,level)386 void reclaim(var,amount,level) /* var points to a (complete) variable entry */
387 int var,amount,level; /* which is to be reduced by amount. var is */
388 { /* an integer offset from the start of level */
389 register char *i;
390 register char *j=vartab+varstk[varstkptr+1]-amount;
391 varent *k=(varent *)(vartab+varstk[level]+var);
392 for(i=(char *)k+(k->next)-amount;i<j;i++)i[0]=i[amount];
393 k->next-=amount;
394 update(var,-amount,level);
395 }
396
tailupdate(stem,value,amount)397 void tailupdate(stem,value,amount)
398 varent *stem; /* update all the grtr/less fields of the variable pointed */
399 int value,amount; /* to by stem by amount if greater than value. Updates the */
400 { /* vallen field of the stem also. */
401 register varent *ptr;
402 int len;
403 char *data=(char *)stem+sizeof(varent)+align(stem->namelen);
404 len=(stem->vallen+=amount);
405 for( ptr=(varent *)(data+*(int *)data+2*four);
406 (char *)ptr<data+len;
407 ptr=(varent *)((char *)ptr+ptr->next))
408 {
409 if(ptr->less>value)ptr->less+=amount;
410 if(ptr->grtr>value)ptr->grtr+=amount;
411 }
412 }
413
tailroom(stem,var,amount,level)414 long tailroom(stem,var,amount,level) /* make room in the tail of a stem */
415 varent *stem; /* var is a tail offset value, or -1 meaning the default */
416 int var,amount,level;
417 {
418 register char *i;
419 register char *j;
420 varent *k;
421 char *data;
422 char *def;
423 long diff=0;
424 int ext;
425 if(stem->vallen+amount>stem->valalloc) /* Not enough space allocated */
426 ext=align(stem->vallen/3+amount*4/3),
427 diff=makeroom((char *)stem-vartab-varstk[level],ext,level),
428 stem=(varent *)((char *)stem+diff),
429 stem->valalloc+=ext; /* It is now! */
430 def=data=(char *)stem+sizeof(varent)+align(stem->namelen);
431 data+=*(int *)data+2*four;
432 if(var>=0)k=(varent *)(j=data+var), /* find the tail, and its end */
433 j+=(k->next);
434 else k=(varent *)(j=data); /* or use the default value */
435 for(i=def+stem->vallen-1;i>=j;i--)i[amount]=i[0];
436 if(var>=0)k->next+=amount,
437 tailupdate(stem,var,amount);
438 else *(int *)def +=amount;
439 return diff;
440 }
441
tailreclaim(stem,var,amount)442 void tailreclaim(stem,var,amount) /* Reduce the size of a tail element */
443 int var,amount; /* var is a tail offset value */
444 varent *stem;
445 {
446 register char *i;
447 register char *j;
448 varent *k;
449 char *data;
450 data=(char *)stem+sizeof(varent)+align(stem->namelen);
451 j=data+stem->vallen-amount;
452 data+=*(int *)data+2*four;
453 k=(varent *)(data+var);
454 for(i=(char *)k+(k->next)-amount;i<j;i++)i[0]=i[amount];
455 k->next-=amount;
456 tailupdate(stem,var,-amount);
457 }
458
tailhookup(stem)459 void tailhookup(stem) /* hook up the tree structure within a stem */
460 varent *stem; /* i.e. fill in the grtr & less fields in a list */
461 { /* of tail elements */
462 int *slot;
463 int exist;
464 register char *k;
465 char *data=(char *)(stem+1)+align(stem->namelen);/*address of stem's value*/
466 char *tails=data+*(int *)data+2*four; /* address of first tail */
467 char *end=data+stem->vallen; /* end of last tail */
468 for(k=tails;k<end;k+=((varent *)k)->next){
469 if(k==tails)continue;
470 slot=(int *)tailsearch/* should always tell where to hook the new tail */
471 ((char*)stem,k+sizeof(varent),((varent *)k)->namelen,&exist);
472 if(!exist) /* should always be true! */ slot[0]=k-tails;
473 }
474 }
475
varcreate(varptr,name,value,namelen,len,lev)476 void varcreate(varptr,name,value,namelen,len,lev)
477 char *varptr,*name,*value; /* create a new variable (used in varset */
478 int namelen,len,lev; /* and varcopy) with given value. */
479 /* varptr is the result of a failed */
480 /* search, i.e. if non-null points to an */
481 /* integer slot to store the address. */
482 /* if lev=0, place in the top level. If */
483 /* lev=1, place one level down. */
484 {
485 int alloc=len/4;
486 int ext;
487 register char *i;
488 register char *v;
489 long mtest_diff;
490 char *mtest_old;
491 if(alloc<20)alloc=20; /* The extra amount of space to allocate */
492 alloc+=len,
493 alloc=align(alloc); /* The total amount of space to allocate */
494 if dtest(vartab,
495 vartablen,
496 varstk[varstkptr+1]+1+(ext=align(alloc+namelen+sizeof(varent))),
497 namelen+alloc+256)
498 if(varptr)varptr+=mtest_diff;
499 v=vartab+varstk[varstkptr+!lev]; /* where to put the new variable */
500 if(lev) /* move up the entire top level to make room */
501 for(i=vartab+varstk[varstkptr+1];i>=v;i--)i[ext]=i[0];
502 memcpy(v+sizeof(varent),name,namelen),/* copy the variable's name */
503 ((varent *)v)->next=ext, /* now fill in the fields... */
504 ((varent *)v)->less= -1,
505 ((varent *)v)->grtr= -1,
506 ((varent *)v)->namelen=namelen,
507 ((varent *)v)->valalloc=alloc,
508 ((varent *)v)->vallen=len;
509 if(varptr) /* make the new variable a part of the tree */
510 *(int *)varptr=varstk[varstkptr+!lev]-varstk[varstkptr-lev];
511 if(len>0) /* copy the new variable's value */
512 memcpy(v+sizeof(varent)+align(namelen),value,len);
513 varstk[varstkptr+1]+=ext; /* and finally update the level pointers */
514 if(lev)varstk[varstkptr]+=ext;
515 }
516
stemcreate(varptr,name,value,namelen,len,lev)517 void stemcreate(varptr,name,value,namelen,len,lev)
518 char *varptr,*name,*value; /* similar to varcreate(), but a whole */
519 int namelen,len,lev; /* stem is created with the given default*/
520 /* name does not include the dot */
521 {
522 int alloc=align(len*5/4+256);
523 int ext;
524 register char *i,*v;
525 long mtest_diff;
526 char *mtest_old;
527 if dtest(vartab,
528 vartablen,
529 varstk[varstkptr+1]+1+(ext=align(alloc+namelen+sizeof(varent)+2*four)),
530 namelen+alloc+256)
531 if(varptr)varptr+=mtest_diff;
532 v=vartab+varstk[varstkptr+!lev];
533 if(lev)for(i=vartab+varstk[varstkptr+1];i>=v;i--)i[ext]=i[0];
534 memcpy(v+sizeof(varent),name,namelen);
535 if(varptr) *(int *)varptr=varstk[varstkptr+!lev]-varstk[varstkptr-lev];
536 ((varent *)v)->next=ext,
537 ((varent *)v)->less= -1,
538 ((varent *)v)->grtr= -1,
539 ((varent *)v)->namelen=namelen,
540 ((varent *)v)->valalloc=alloc,
541 ((varent *)v)->vallen=(alloc=align(len))+2*four;
542 v+=sizeof(varent)+align(namelen),
543 ((int *)v)[0]=alloc,
544 ((int *)v)[1]=len;
545 if(len>0)memcpy(v+2*four,value,len);
546 varstk[varstkptr+1]+=ext;
547 if(lev)varstk[varstkptr]+=ext;
548 }
549
tailcreate(stem,tailptr,name,value,namelen,len,level)550 void tailcreate(stem,tailptr,name,value,namelen,len,level)
551 char *stem,*tailptr,*name,*value; /* create new tail within a stem with */
552 int namelen,len,level; /* a given value. Stem is the address */
553 /* of the stem structure, tailptr is */
554 /* the equivalent of varptr in earlier*/
555 /* functions. Level is the actual */
556 /* level number. */
557 {
558 long diff;
559 int alloc=len/4;
560 int ext;
561 char *v=stem+sizeof(varent)+align(((varent *)stem)->namelen);
562 char *e=v+((varent *)stem)->vallen; /* end of last tail */
563 v+=*(int *)v+2*four; /* start of first tail */
564 if(len<0)alloc=0;
565 else {
566 if(alloc<20)alloc=20;
567 alloc=align(alloc+len);
568 }
569 if( (ext=alloc+align(namelen)+sizeof(varent))
570 + ((varent *)stem)->vallen
571 > ((varent *)stem)->valalloc){
572 if(diff=makeroom(stem-vartab-varstk[level],ext+256,level)){
573 if(tailptr)tailptr+=diff;
574 stem+=diff,e+=diff,v+=diff;
575 }
576 ((varent *)stem)->valalloc+=ext+256;
577 }
578 if(tailptr)*(int *)(tailptr)=e-v; /* Save the offset in the parent's slot */
579 memcpy(e+sizeof(varent),name,namelen), /* Make the new tail at e */
580 ((varent *)e)->next=ext,
581 ((varent *)e)->less= -1,
582 ((varent *)e)->grtr= -1,
583 ((varent *)e)->namelen=namelen,
584 ((varent *)e)->valalloc=alloc,
585 ((varent *)e)->vallen=len;
586 if(len>0)memcpy(e+sizeof(varent)+align(namelen),value,len);
587 ((varent *)stem)->vallen+=ext;
588 }
589
varset(name,varlen,value,len)590 void varset(name,varlen,value,len) /* set variable `name' of namelength */
591 char *name,*value; /* `varlen' equal to the value `value' */
592 int len,varlen; /* which has length `len' */
593 {
594 int varalloc,varoff,ext,newlen,exist;
595 register char *i;
596 register varent *v1,*v2;
597 int level=varstkptr;
598 char *valptr;
599 char *varptr;
600 char *oldptr;
601 char *stemptr;
602 long diff;
603 int compound=name[0]&128;
604 int isstem=compound&&!memchr(name,'.',varlen);/* stems do not contain dots*/
605 char varname[maxvarname];
606 if(isstem){ /* Set the default value of a whole stem. */
607 varptr=varsearch(name,varlen,&level,&exist);
608 if(exist){ /* stem exists. Set default and clear all non-exposed tails */
609 valptr=varptr+sizeof(varent)+align(((varent *)varptr)->namelen);
610 /* valptr points to the default value */
611 if((ext=align(len-*(int *)valptr))>0)/* extra mem needed for default*/
612 if(diff=tailroom((varent *)varptr,-1,ext,level))
613 varptr+=diff,
614 valptr+=diff;
615 ((int *)valptr)[1]=len; /* now copy the default value */
616 if(len>0)memcpy(valptr+2*four,value,len);
617 ext= *(int *)valptr;
618 i=((varent *)varptr)->vallen+valptr; /* the end of the last tail */
619 v2=(varent *)(valptr+2*four+ext); /* the start of the first tail */
620 oldptr=valptr;
621 valptr+= (*(int *)valptr=align(len))+2*four; /* new start of tails */
622 v1=(varent *)valptr; /* pointer to "current" new tail */
623 /* now copy all exposed tails from v2 to v1. upper bound of v2 = i */
624 while((char *)v2<i){
625 if(v2->valalloc<0) /* It is exposed */
626 memcpy((char*)v1,(char*)v2,v2->next),
627 v1->grtr= -1,
628 v1->less= -1,
629 v1=(varent *)((char *)v1+v1->next);
630 v2=(varent *)((char *)v2+v2->next);
631 }
632 ((varent *)varptr)->vallen=ext=((char *)v1)-oldptr; /* new length */
633 ext=align(ext); /* The amount of space to leave in this stem */
634 if(len>=0)ext+=256; /* Leave some extra space for future tails */
635 if((ext-=((varent *)varptr)->valalloc)<0) /* Shrink the stem */
636 reclaim(varptr-varstk[level]-vartab,-ext,level),
637 ((varent *)varptr)->valalloc+=ext;
638 /* hook up the tree of tails */
639 tailhookup((varent*)varptr);
640 /* assign the given string to each remaining tail */
641 memcpy(varname,name,varlen); /* varname holds each compund symbol */
642 varname[varlen]='.';
643 for(v2=(varent *)valptr;v2<v1;v2=(varent *)((char *)v2+v2->next))
644 memcpy(varname+varlen+1,(char*)(v2+1),v2->namelen),
645 varset(varname,1+varlen+v2->namelen,value,len);
646 return;
647 }
648 /* a stem which does not exist is being initialised */
649 if(len>=0)stemcreate(varptr,name,value,varlen,len,0);
650 return;
651 }
652 if(compound){ /* A compound symbol is being assigned to */
653 varptr=valuesearch(name,varlen,&level,&exist,&stemptr);
654 if(exist){ /* change an existing compound variable */
655 valptr=stemptr+sizeof(varent)+align(((varent *)stemptr)->namelen),
656 valptr+=*(int *)valptr+2*four;
657 varoff=varptr-valptr, /* now varoff contains the offset within stem */
658 varalloc= ((varent *)varptr)->valalloc;
659 if(len>varalloc){ /* need some more memory */
660 ext=len/4;
661 if(ext<20)ext=20;
662 newlen=align(len+ext), /* the total amount of memory */
663 ext=newlen-varalloc; /* the extra amount */
664 varptr+=tailroom((varent*)stemptr,varoff,ext,level);
665 ((varent *)varptr)->valalloc=newlen;
666 }
667 else if(len<0&&varalloc>10) /* variable is being dropped - reclaim */
668 tailreclaim((varent*)stemptr,varoff,varalloc),
669 ((varent *)varptr)->valalloc=0;
670 if(len>0) /* Copy the value */
671 memcpy(varptr+sizeof(varent)+align(((varent *)varptr)->namelen),
672 value,len);
673 ((varent *)varptr)->vallen=len; /* and copy the length */
674 return;
675 }
676 if(!stemptr){/* the stem does not exist. Create then continue */
677 if(len<0)return; /* Do not bother to DROP from a nonexistent stem */
678 stemcreate(varptr,name,cnull,strchr(name,'.')-name,-1,0),
679 /* create stem with no default (the above line) */
680 level=varstkptr,
681 varptr=valuesearch(name,varlen,&level,&exist,&stemptr);
682 /* the search is guaranteed to find a stem with no tail */
683 }
684 /* the stem exists but the tail does not */
685 /* Even if the variable is being dropped, it is necessary to create it
686 in case of e.g. "a.=5; drop a.1; say a.1" (should say "A.1") */
687 oldptr=name,
688 varlen-=((name=1+strchr(name,'.'))-oldptr);
689 tailcreate(stemptr,varptr,name,value,varlen,len,level);
690 return;
691 } /* So now it is a simple symbol. */
692 varptr=varsearch(name,varlen,&level,&exist);
693 if(exist){ /* variable exists, so reset */
694 varoff= varptr-vartab-varstk[level],
695 varalloc= ((varent *)varptr)->valalloc;
696 if(len>varalloc){
697 ext=len/4;
698 if(ext<20)ext=20;
699 newlen=align(len+ext),
700 ext=newlen-varalloc;
701 varptr+=makeroom(varoff,ext,level);
702 ((varent *)varptr)->valalloc=newlen;
703 }
704 else if(len<0&&varalloc>10) /* variable is being dropped - reclaim */
705 reclaim(varoff,varalloc,level),
706 ((varent *)varptr)->valalloc=0;
707 if(len>0)
708 memcpy(varptr+sizeof(varent)+align(((varent *)varptr)->namelen),
709 value,len);
710 ((varent *)varptr)->vallen=len;
711 }
712 else if(len>=0) /* variable does not exist, so create */
713 varcreate(varptr,name,value,varlen,len,0);
714 }
715
varget(name,varlen,len)716 char *varget(name,varlen,len)/* get value and length of variable `name'. */
717 char *name; /* Value is returned, length is placed in `len' */
718 int varlen;
719 int *len;
720 {
721 int level=varstkptr;
722 char *stem;
723 char *varptr=valuesearch(name,varlen,&level,len,&stem);
724 if(!(*len||stem))return 0; /* does not exist at all */
725 if(*len&&stem&&((varent *)varptr)->vallen<0)
726 return (*len=0),cnull; /* compound symbol has "null" value */
727 if(!*len){
728 /* compound variable doesn't exist; try default value */
729 stem+=sizeof(varent)+align(((varent *)stem)->namelen);
730 if((*len= *((int *)stem+1))>=0) return stem+2*four;
731 else return (*len=0),cnull;
732 }
733 if((*len= ((varent *)varptr)->vallen)>=0) /* exists */
734 return varptr+align(((varent *)varptr)->namelen)+sizeof(varent);
735 else return (*len=0),cnull;
736 }
737
newlevel()738 void newlevel() /* increment variable level, making a clean environment */
739 {
740 char *charvarstk=(char *)varstk;
741 mtest(charvarstk,varstklen,four*(++varstkptr+2),four*25);
742 varstk=(int *)charvarstk;
743 varstk[varstkptr+1]=varstk[varstkptr];
744 }
745
varcopy(name,varlen)746 void varcopy(name,varlen) /* copy a variable (as in procedure expose) */
747 int varlen;
748 char *name; /* when this procedure is called, varstkptr has already */
749 { /* been incremented to point to the level in which the new
750 copy of the variable is required. The old copy of the
751 variable will be in level varstkptr-1. */
752 int ext,l;
753 register char *i;
754 char *oldptr;
755 int level=varstkptr-1;
756 int compound=name[0]&128;
757 int isstem=compound&&!memchr(name,'.',varlen);
758 char *varptr;
759 char *stemptr;
760 char *endvar;
761 char *mtest_old;
762 long mtest_diff;
763 if(compound&&!isstem){ /* An individual compound symbol */
764 varptr=valuesearch(name,varlen,&level,&l,&stemptr);
765 if(!l){ /* compound variable does not exist, so create before exposing */
766 if(!stemptr) /* stem does not exist, so create with no default */
767 stemcreate(varptr,name,cnull,strchr(name,'.')-name,-1,1),
768 level=varstkptr-1,
769 varptr=valuesearch(name,varlen,&level,&l,&stemptr);
770 oldptr=1+strchr(name,'.'),
771 tailcreate(stemptr,varptr,oldptr,cnull,varlen-(oldptr-name),-1,level);
772 }
773 /* now copy the variable, which is in level `level' */
774 ext=varstkptr;
775 varptr=valuesearch(name,varlen,&ext,&l,&stemptr);
776 if(!l){/* not already exposed, so go ahead */
777 /* make sure there is a stem to hold the new variable */
778 if(!stemptr)
779 stemcreate(varptr,name,cnull,strchr(name,'.')-name,-1,0),
780 /* create stem with no default */
781 ext=varstkptr,
782 varptr=valuesearch(name,varlen,&ext,&l,&stemptr);
783 if(ext==varstkptr&&((varent *)stemptr)->valalloc>=0){
784 /* stem is not already exposed, so go ahead */
785 oldptr=name,name=1+strchr(name,'.'),varlen-=name-oldptr,
786 ext=sizeof(varent)+align(varlen),
787 oldptr=vartab;
788 if(((varent *)stemptr)->valalloc<((varent *)stemptr)->vallen+ext){
789 if(mtest_diff
790 =makeroom(stemptr-vartab-varstk[varstkptr],ext+256,varstkptr)){
791 if(varptr)varptr+=mtest_diff;
792 stemptr+=mtest_diff;
793 }
794 ((varent *)stemptr)->valalloc+=ext+256;
795 } /* There is now enough room to place the new tail at the end
796 of the stem. */
797 i=stemptr+sizeof(varent)+align(((varent *)stemptr)->namelen),
798 endvar=i+((varent *)stemptr)->vallen,
799 i+= *(int*)i+2*four,
800 ((varent *)stemptr)->vallen+=ext;
801 if(varptr)*(int *)varptr=endvar-i;
802 memcpy(endvar+sizeof(varent),name,varlen),
803 ((varent *)endvar)->next=ext,
804 ((varent *)endvar)->less= -1,
805 ((varent *)endvar)->grtr= -1,
806 ((varent *)endvar)->namelen=varlen,
807 ((varent *)endvar)->valalloc= -(level+1),
808 ((varent *)endvar)->vallen=0;
809 }
810 }
811 return;
812 }
813 /* stems are like ordinary symbols; both are treated here. */
814 varptr=varsearch(name,varlen,&level,&l);
815 if(!l) /* create in old level before exposing to new level */
816 if(isstem) stemcreate(varptr,name,cnull,varlen,-1,1);
817 else varcreate(varptr,name,cnull,varlen,-1,1);
818 ext=varstkptr;
819 varptr=varsearch(name,varlen,&ext,&l);
820 if(!l){ /* not already exposed, so go ahead */
821 if dtest(vartab,vartablen,varstk[varstkptr+1]+1+(ext=sizeof(varent)+align(varlen)),varlen+256)
822 if(varptr)varptr+=mtest_diff;
823 ((varent *)(i=vartab+varstk[varstkptr+1]))->less= -1,
824 ((varent *)i)->grtr= -1,
825 ((varent *)i)->next=ext,
826 ((varent *)i)->namelen=varlen,
827 ((varent *)i)->valalloc= -(level+1),
828 ((varent *)i)->vallen=0;
829 if(varptr)*(int *)varptr=varstk[varstkptr+1]-varstk[varstkptr];
830 varstk[varstkptr+1]+=ext;
831 memcpy(i+sizeof(varent),name,varlen);
832 }
833 }
834
vardup()835 void vardup() /* make an exact copy of the variables to pass into the
836 next procedure */
837 {
838 int ext=varstk[varstkptr]-varstk[varstkptr-1];
839 int exist;
840 int *slot;
841 register char *i,*j,*k;
842 /* test for memory. The new level requires no more memory than the
843 previous one */
844 mtest(vartab,vartablen,varstk[varstkptr+1]+ext+1,ext+10);
845 /* Compress the old variables into the new level */
846 i=vartab+varstk[varstkptr-1],
847 j=k=vartab+varstk[varstkptr];
848 while(i<j){
849 memcpy(k,i,ext=sizeof(varent)+align(((varent *)i)->namelen));
850 if(((varent *)k)->valalloc>=0)((varent *)k)->valalloc= -varstkptr;
851 ((varent *)k)->next= ext,
852 ((varent *)k)->less= -1,
853 ((varent *)k)->grtr= -1,
854 ((varent *)k)->vallen= 0,
855 k+=ext;
856 i+=((varent *)i)->next;
857 }
858 varstk[varstkptr+1]=k-vartab;
859 /* hook up the tree structure */
860 for(i=k,k=j;k<i;k+=((varent *)k)->next){
861 if(k==j)continue;
862 ext=varstkptr;
863 slot=(int *)varsearch(k+sizeof(varent),((varent *)k)->namelen,&ext,&exist);
864 if(!exist) /* should always be true! */ slot[0]=k-j;
865 }
866 }
867
vardel(name,len)868 void vardel(name,len) /* delete name (as in procedure hide) */
869 int len;
870 char *name; /* the name is not deleted, rather given a new */
871 { /* undefined value (to avoid massive restructuring)*/
872 int compound=name[0]&128;
873 int isstem=compound&&!memchr(name,'.',len);
874 int *slot;
875 int c;
876 char *ans=vartab+varstk[varstkptr];
877 if(compound&&!isstem)die(Ebadexpr);
878 while((c=less(name,ans+sizeof(varent),len,((varent *)ans)->namelen))&&(*(slot=(int *)ans+1+(c>0)))>=0)ans=vartab+varstk[varstkptr]+*slot;
879 if(!c){
880 ((varent *)ans)->valalloc=0;
881 if(isstem)
882 ans+=tailroom((varent*)ans,-1,2*four,varstkptr),
883 slot=(int *)(ans+sizeof(varent)+align(((varent *)ans)->namelen)),
884 slot++[0]=0,
885 slot[0]=-1,
886 ((varent *)ans)->vallen=2*four;
887 else ((varent *)ans)->vallen= -1;
888 }
889 }
890
uc(c)891 char uc(c) /* return the upper case of c */
892 char c;
893 {
894 if(c<'a'||c>'z')return c;
895 return c&0xdf;
896 }
897
pstack(type,len)898 void *pstack(type,len) /* stack current position on the program stack,*/
899 int type,len; /* returning the address of a stack item to be */
900 { /* filled in */
901 register int *answer,*ptr;
902 mtest(pstackptr,pstacklen,epstackptr+len+16,256+len);
903 *(ptr=answer=(int *)(pstackptr+epstackptr))=ppc, /* Store the first elmnt */
904 *(ptr=(int *)(pstackptr+(epstackptr+=len))-1)=type,/* Store the type, and */
905 *--ptr=len, /* the length before it */
906 pstacklev++; /* Record the extra entry*/
907 return (void *)answer;
908 }
909
unpstack()910 int unpstack() /* examine an entry from the program stack */
911 /* without deleting it. The type is returned. */
912 {
913 int type;
914 register char *ptr=pstackptr+epstackptr;
915 type= *((int *)ptr-1);
916 ptr-= *((int *)ptr-2); /* ptr points to the start of the entry */
917 newppc=((struct minstack *)ptr)->stmt;
918 return type;
919 }
920
delpstack()921 void *delpstack() /* Delete the top program stack entry; return its address */
922 {
923 if(!pstacklev)return (void *)(pstackptr+(epstackptr=0));
924 pstacklev--;
925 return (void *)(pstackptr+(epstackptr-=*((int *)(pstackptr+epstackptr)-2)));
926 }
927
strcmpi(s1,s2)928 int strcmpi(s1,s2) /* compare s1 & s2 with case independence */
929 char *s1,*s2; /* return 1 if s2 is an initial substring of s2 */
930 {
931 int i;
932 for(i=0;s2[i]&&!((s1[i]^s2[i])&0xDF);i++);
933 return !s2[i];
934 }
935 #if 0
936 void printstmt(line,st,error) /* print the source statement indicated */
937 int line,st,error; /* if error=1 then precede with +++ */
938 {
939 int i=line; /* temporary */
940 char c;
941 int spc=0;
942 char quote=0;
943 char *st1=stmts(&line,st); /* Find the start and end of the statemtent */
944 char *st2=stmts(&i,st+1); /* in the source code */
945 char *st3;
946 static char *symwords[]= /* the symbolic tokens */
947 {"||","&&","==","<=",">=","<>","\\==","//","<<",">>","<<=",">>=","**"};
948 char *what=error?"+++":"*-*"; /* The trace prefix */
949 if(!st)st++;
950 if(!line){ /* interpreted ... un-parse the line */
951 printf(" --- %s ",what);
952 for(i=0;i<traceindent*pstacklev;i++)putchar(' '); /* indent */
953 for(st1=interp;--st;){ /* find statement */
954 while((c=st1[0])&&c!=THEN&&c!=-1)st1++; /* (easy!) */
955 if(c&&st1[1]==THEN)st1++;
956 if(c)st1++;
957 }
958 if(!st1[0]){puts("<EOL>");return;} /* statement doesn't exist */
959 while((c=st1[0])&&c!=-1&&c!=THEN){ /* Print up to next terminator */
960 if(c<SYMBOL){ /* Print a word */
961 if(spc)putchar(' ');
962 for(st2=words[c+128];st2[0];st2++)putchar(st2[0]|0x20);
963 putchar(' ');
964 spc=0;
965 }
966 else if(c<0){ /* Print a symbolic token */
967 if(spc)putchar(' ');
968 printf("%s",symwords[c-(SYMBOL+1)]);
969 putchar(' ');
970 spc=0;
971 }
972 else { /* Print a character; lowercase it if outside quotes */
973 if(quote&&c==quote)quote=0;
974 else if((c=='\''||c=='\"')&&!quote)quote=c;
975 if((c>='A'&&c<='Z')&&!quote)c|=0x20;
976 putchar(c);
977 spc=(c!=' ');
978 }
979 st1++;
980 }
981 if(c==THEN){ /* Print a terminating THEN */
982 if(spc)putchar(' ');
983 puts("then");
984 }
985 else putchar('\n');
986 return;
987 } /* Print a regular source line (or lines) */
988 if(st2)if(st2[-1]==';')st2--; /* Remove a final semicolon */
989 if(st1&&st2) /* calculate column at which the stmt starts */
990 for(spc=0,st3=(*source)[line];
991 st3<st2&&(c=st3[0],st3<st1||c==' '||c=='\t');st3++)
992 if(c=='\t')spc=8+(spc&~7);
993 else spc++;
994 do{
995 printf("%5d %s ",line,what);
996 for(i=0;i<traceindent*pstacklev;i++)putchar(' '); /* indent */
997 if(st1&&st2){ /* Both ends of the statement found, so print */
998 for(i=0;i<spc&&st1<st2&&((c=st1[0])==' '||c=='\t');st1++)
999 if(c=='\t')i=8+(i&~7); /* Remove leading spaces */
1000 else i++;
1001 while(i>spc)putchar(' '),i--; /* Print part of a tab if necessary */
1002 for(;st1<st2&&st1[0];st1++)
1003 printf("%c",st1[0]); /* Print the statement, up to EOL */
1004 if(st1<st2&&line<lines)st1=(*source)[++line]; /* Go to next line */
1005 }
1006 else if(line>lines)fputs("<EOF>",stdout); /* Line wasn't found */
1007 else fputs("<EOL>",stdout); /* statement wasn't found */
1008 putchar('\n');
1009 } while(st1&&st2&&st1<st2&&line<=lines);
1010 }
1011 #endif
1012
freestack(ptr,i)1013 void freestack(ptr,i) /* free areas indicated by program stack type i */
1014 void *ptr; /* stack entry starts at ptr */
1015 int i;
1016 {
1017 extern int address1,address2;
1018 register struct procstack2 *sptr=(struct procstack2 *)ptr;
1019 if(i==11||i==12) /* internal call */
1020 interplev--,
1021 free(cstackptr),
1022 cstackptr=sptr->csp,
1023 cstacklen=sptr->csl,
1024 ecstackptr=sptr->ecsp,
1025 prog=sptr->prg,
1026 stmts=sptr->stmts,
1027 timeflag=(timeflag&4)|(sptr->tim &1),
1028 trcflag=sptr->trc,
1029 microsecs=sptr->mic,
1030 secs=sptr->sec,
1031 address1=sptr->address1,
1032 address2=sptr->address2,
1033 numform=sptr->form,
1034 precision=sptr->digits,
1035 fuzz=sptr->fuzz;
1036 else if(i==14) /* interpret */
1037 interplev--,
1038 free(prog[0].source), /* the interpreted string */
1039 free(prog[0].line), /* the tokenised string */
1040 free((char*)prog), /* the statement table */
1041 stmts=((struct interpstack *)sptr)->stmts,
1042 prog=((struct interpstack *)sptr)->prg;
1043 else if(i==16) /* interactive() stored calculator stack */
1044 free(cstackptr),
1045 cstackptr=sptr->csp,
1046 cstacklen=sptr->csl,
1047 ecstackptr=sptr->ecsp,
1048 interact=-1;
1049 else if(i==20) /* saved traceback line */
1050 prog=((struct errorstack *)sptr)->prg,
1051 stmts=((struct errorstack *)sptr)->stmts;
1052 if(i==12) /* reclaim procedural variables */
1053 varstkptr--;
1054 if(i>=11&&i<=14 && sgstack[interplev+1].data) /* reclaim condition data */
1055 free(sgstack[interplev+1].data);
1056 }
1057
1058 static char tracebuff[maxtracelen+1];
1059 static int tracepos=0;
1060
tracestr(str)1061 void tracestr(str) /* like traceput but length parameter is not needed */
1062 char *str;
1063 {
1064 traceput(str,strlen(str));
1065 }
1066
traceput(str,len)1067 void traceput(str,len) /* like fputs to the trace output stream. */
1068 char *str; /* The line is output if the last char is \n. */
1069 int len;
1070 {
1071 char c;
1072 static RXSIOTRC_PARM sio;
1073 int cr;
1074 if(!len)return;
1075 if((cr=str[len-1]=='\n'))len--;
1076 while(len--)
1077 if(tracepos<maxtracelen)
1078 tracebuff[tracepos++]=(((c=str++[0])&127)<' '||c==127)?'?':c;
1079 if(!cr)return;
1080 if(tracepos==maxtracelen)
1081 tracebuff[maxtracelen-1]='.',
1082 tracebuff[maxtracelen-2]='.',
1083 tracebuff[maxtracelen-3]='.';
1084 tracebuff[tracepos]=0;
1085 sio.rxsio_string.strptr=tracebuff;
1086 sio.rxsio_string.strlength=tracepos;
1087 tracepos=0;
1088 if(exitlist[RXSIO] && exitcall(RXSIO,RXSIOTRC,&sio)==RXEXIT_HANDLED)
1089 return;
1090 fputs(tracebuff,traceout);
1091 putc('\n',traceout);
1092 }
1093
tracechar(ch)1094 void tracechar(ch)
1095 char ch;
1096 {
1097 if(ch=='\n')traceput("\n",1);
1098 else if(tracepos<maxtracelen)
1099 tracebuff[tracepos++]=(ch&=127)<' '||ch==127?'?':ch;
1100 }
1101
tracenum(num,len)1102 void tracenum(num,len) /* print a number to the trace output stream. */
1103 int num,len;
1104 {
1105 static char buff[20];
1106 sprintf(buff,"%*d",len,num);
1107 traceput(buff,strlen(buff));
1108 }
1109
traceprefix(num,prefix)1110 void traceprefix(num,prefix) /* print a trace prefix */
1111 int num;
1112 char *prefix;
1113 {
1114 static char buff[20];
1115 if(num)sprintf(buff,"%5d %s ",num,prefix);
1116 else sprintf(buff," %s ",prefix);
1117 traceput(buff,strlen(buff));
1118 }
1119
traceget(len)1120 char *traceget(len) /* get input for interactive trace */
1121 int *len; /* space must be freed by caller */
1122 {
1123 char *inbuf=allocm(RXRESULTLEN);
1124 int inlen;
1125 RXSIODTR_PARM rxio;
1126 if(exitlist[RXSIO]){
1127 MAKERXSTRING(rxio.rxsiodtr_retc,inbuf,RXRESULTLEN);
1128 if(exitcall(RXSIO,RXSIODTR,&rxio)==RXEXIT_HANDLED){
1129 if(rxio.rxsiodtr_retc.strptr!=inbuf)free(inbuf);
1130 *len=rxio.rxsiodtr_retc.strlength;
1131 return rxio.rxsiodtr_retc.strptr;
1132 }
1133 }
1134 fputs(">trace>",ttyout),fflush(ttyout);
1135 clearerr(ttyin);
1136 if(!(fgets(inbuf,RXRESULTLEN,ttyin)))inlen=0;
1137 else inlen=strlen(inbuf)-1;
1138 *len=inlen;
1139 return inbuf;
1140 }
1141
interactive()1142 void interactive() /* interactive tracing - called whenever the tracer might */
1143 { /* want to stop for input */
1144 char *inbuf;
1145 int inlen;
1146 char **ocurargs=curargs; /* Save the arguments to the current procedure */
1147 int *ocurarglen=curarglen; /* in case of a trap from a lower procedure */
1148 int oppc=ppc; /* save also the current position */
1149 int i;
1150 struct interactstack *entry;
1151 if((!(trcflag&0x80)) || interact>=0)
1152 return; /* Continue only in interactive mode */
1153 if(interactmsg)
1154 interactmsg=0,
1155 fputs(" +++ Interactive trace. TRACE OFF to end debug, ENTER to continue. +++",ttyout),
1156 putc('\n',ttyout);
1157 entry=(struct interactstack *)pstack(16,sizeof(struct interactstack));
1158 entry->csp=cstackptr, /* Now fill in a program stack entry for the */
1159 entry->csl=cstacklen, /* commands typed in */
1160 entry->ecs=ecstackptr;
1161 otrcflag=trcflag;
1162 cstackptr=allocm(cstacklen=200); /* Make a new calculator stack. */
1163 ecstackptr=0;
1164 trclp=1; /* signal "do wait for more input" */
1165 while(trclp){ /* Until the user restarts the program ...*/
1166 returnlen=-1; /* signal that a RETURN was not executed */
1167 inbuf=traceget(&inlen); /* input a line */
1168 returnval=0;
1169 if(!inlen)break; /* No input -> continue with program */
1170 interact=interplev; /* signal "interactive mode" */
1171 trcflag=Terrors; /* turn tracing "off" while interpreting input */
1172 if(setjmp(interactbuf)) /* Save the context in case of an error */
1173 curargs=ocurargs, /* error! restore the correct context */
1174 curarglen=ocurarglen,
1175 ppc=oppc,
1176 returnlen=-1;
1177 else returnval=rxinterp(inbuf,inlen,&returnlen, /* Interpret */
1178 "TRACE",RXSUBROUTINE,curargs,curarglen);
1179 free(inbuf);
1180 if(trclp==1)trcflag=otrcflag; /* Unless the input contained a trace
1181 command, restore the old trace flag. */
1182 if(returnlen>=0)break; /* Continue with program if a RETURN occurred */
1183 }
1184 interact= -1; /* signal "not interactive mode" */
1185 if(returnval)returnfree=cstackptr; /* The result's user will free it */
1186 else free(cstackptr); /* Nothing of value was on the stack */
1187 while(i=*((int *)(pstackptr+epstackptr)-1)!=16)/* Clear the program stack */
1188 freestack(delpstack(),i);
1189 entry=(struct interactstack *)delpstack();/* delete interactive()'s entry */
1190 cstackptr=entry->csp, /* and restore the old stack */
1191 ecstackptr=entry->ecs,
1192 cstacklen=entry->csl;
1193 if(returnlen>=0) /* if a RETURN occurred, jump back to do the return */
1194 longjmp(sgstack[interplev].jmp,-1);
1195 }
1196
1197 /* The following function loads a source file from disk and returns the
1198 block of memory allocated to hold it. The return value is null if
1199 an error occurred. */
load(name,sourcelen)1200 char *load(name,sourcelen)
1201 char *name; /* The path name of the program */
1202 int *sourcelen; /* The length of the source (to be returned) */
1203 {
1204 struct stat buf; /* For finding the size of the program */
1205 int f= -1; /* A file descriptor */
1206 unsigned size; /* The size of the program */
1207 char *store; /* The memory allocated to hold the source */
1208
1209 /* find size of file */
1210 if (stat(name,&buf)==-1)return 0;
1211 size=buf.st_size,
1212 /* get mem for the file */
1213 store=allocm(size+2);
1214 /* read file */
1215 if((f=open(name,O_RDONLY))==-1){
1216 free(store);
1217 return 0;
1218 }
1219 if(read(f,store,size)!=size){
1220 free(store);
1221 return 0;
1222 }
1223 close(f);
1224 if(store[size-1]!='\n')store[size++]='\n'; /* terminate last line */
1225 store[size]=0;
1226 *sourcelen=size; /* Ahem! */
1227 return store;
1228 }
1229
1230 /* The following function preprocesses a block of source passed to it.
1231 Space for the preprocessed program and the label tabel is allocated
1232 and assigned to global variables. Also, the source is broken into
1233 lines and a source line table is allocated. The 0th line of source
1234 is usually its file name. However this will be inserted by the caller. */
tokenise(input,ilen,interpret,line1)1235 void tokenise(input,ilen,interpret,line1)
1236 char *input; /* the source code */
1237 int ilen; /* length of the source code */
1238 int interpret; /* if nonzero, ignore labels and do not make a source
1239 line table */
1240 int line1; /* if nonzero, the first line is a comment */
1241 {
1242 static char msg[20];/* For reporting invalid chars */
1243 int type; /* Type of a character */
1244 int comment=0; /* Comment nesting level */
1245 int commentstart; /* Start stmt number of a comment */
1246 int comma=0; /* Continuation character is in force */
1247 int start=1; /* the start of a statement */
1248 char first=0; /* the first word in this statement */
1249 char last=0; /* the most recent word in this statement */
1250 char token=0; /* candidate token number */
1251 int spc=0; /* a space just occurred */
1252 int wordlen=0; /* length of a stored word */
1253 #define word varnamebuf /* "word" seems a better name just now */
1254 int spcbefore=0; /* Put a space before the word */
1255 int gobble=1; /* whether a character gobbles spaces */
1256 int sourcelen=100;/* lines allocated in source line table */
1257 int proglen=100; /* statements allocated in program line table */
1258 int plen=ilen+2; /* length allocated for program */
1259 char*srcptr=input;/* pointer into the source */
1260 char *prgptr; /* pointer into the program */
1261 char *prevptr; /* source address for the stored word */
1262 int lablen; /* Length allocated to labels */
1263 int elabptr; /* Length of labels so far */
1264 char c;
1265 char *ptr;
1266 int i;
1267 int ch;
1268
1269 if(!interpret)source=(char**)allocm(sourcelen*sizeof(char*));
1270 prog=(program*)allocm(proglen*sizeof(program));
1271 prgptr=prog[0].line=allocm(plen);/* plen=ilen+2 is a guaranteed upper
1272 bound (the 2 extra are a line terminator and program terminator) */
1273 prog[0].source=input;
1274 prog[0].num=!interpret;
1275 if(!interpret)
1276 source[0]=cnull,
1277 labelptr=allocm(lablen=200),
1278 elabptr=0;
1279 stmts=0;
1280 if(!interpret)lines=0;
1281 if(!interpret && (line1 || ilen>2&&srcptr[0]=='#'&&srcptr[1]=='!')){
1282 source[++lines]=srcptr;
1283 while(ilen--&&srcptr++[0]!='\n');
1284 if(ilen<0)ilen++;
1285 else srcptr[-1]=0;
1286 }
1287 prog[0].sourcend=srcptr;
1288 if(ilen){
1289 if(!interpret)source[++lines]=srcptr;
1290 prog[++stmts].line=prgptr,
1291 prog[stmts].num=(interpret?0:lines),
1292 prog[stmts].source=srcptr,
1293 prog[stmts].sourcend=0,
1294 prog[stmts].related=0;
1295 }
1296 ppc=0; /* this must be a signal that no ppc is available */
1297 while(ilen-- || !interpret&&srcptr>source[lines] || wordlen || !start){
1298 if(ilen<0){ /* we repeat the loop to finish off the source */
1299 ilen++; /* This happens when the last line is unterminated */
1300 /* The last byte of source will be overwritten with
1301 \0. This only fails if input was an empty string. */
1302 c='\n';
1303 if(comment)die(Elcomm);
1304 }
1305 else c=srcptr++[0];
1306 if(c=='\n'){
1307 srcptr[-1]=0;
1308 if(!interpret){
1309 if(sourcelen-1<=++lines)
1310 if(ptr=(char*)realloc((char*)source,(sourcelen+=50)*sizeof(char*)))
1311 source=(char**)ptr;
1312 else die(Emem);
1313 source[lines]=srcptr;
1314 if(comma){
1315 if(!ilen)die(Ecomma); /* Last line ended with comma */
1316 prgptr--,
1317 gobble--, /* restore gobble to previous val */
1318 comma=0,
1319 c=' ';
1320 }
1321 else c=';'; /* line ends terminate statements. Note:
1322 this is ineffective within comments */
1323 }
1324 else
1325 if(!ilen)
1326 if(comma)die(Ecomma); /* interpreted line ends with comma */
1327 else c=';'; /* terminate the interpreted line */
1328 else /* do nothing. \n will be rejected later. */ ;
1329 }
1330 if(c=='^')c='\\'; /* Translate "^" into the real "not" character */
1331 if(c=='*'&&ilen&&srcptr[0]=='/'){
1332 /* if(--comment<0)die(Ercomm); Not an error really. */
1333 if(--comment<0)comment=0;
1334 else srcptr++,ilen--,
1335 c=' '; /* Comment equals space. This should be changed. */
1336 }
1337 if(c=='/'&&ilen&&srcptr[0]=='*'){
1338 if(comment++==0)commentstart=stmts;
1339 srcptr++,ilen--;
1340 }
1341 if(comment)continue;/* all characters within comments are ignored. */
1342 if((type=whattype(c))==-2){ /* Invalid character */
1343 if(c<127&&c>' ')sprintf(errordata=msg,": \'%c\'",c);
1344 else sprintf(errordata=msg,": \'%02x\'x",(int)(unsigned char)c);
1345 die(Echar);
1346 }
1347 if(c==' '||c=='\t'||c=='\r'){
1348 spc=1;
1349 continue;
1350 }
1351 /* A non-blank source character has been found within a line */
1352 /* Time to emit the stored word (if any) */
1353 comma=0;
1354 if(c==':'&&start&&wordlen){ /* the stored word is a label */
1355 if(word[wordlen-1]=='.')die(Elabeldot); /* Ends with dot */
1356 if(interpret)die(Exlabel);
1357 /* Add the label to the label table */
1358 mtest(labelptr,lablen,elabptr+wordlen+4*four,256+wordlen);
1359 *((int *)(labelptr+elabptr))=wordlen,
1360 *((int *)(labelptr+elabptr)+1)=stmts,
1361 memcpy(labelptr+(elabptr+=2*four),word,wordlen),
1362 *(labelptr+elabptr+wordlen)=0,
1363 elabptr+=align(wordlen+1);
1364 /* Add a LABEL clause to the program */
1365 if(stmts+2>proglen)
1366 if(ptr=(char*)realloc((char*)prog,(proglen+=50)*sizeof(program)))
1367 prog=(program*)ptr;
1368 else die(Emem);
1369 prgptr++[0]=LABEL;
1370 prgptr++[0]=0;
1371 prog[stmts].source=prevptr;
1372 prog[stmts].sourcend=srcptr;
1373 prog[stmts].num=lines;
1374 prog[++stmts].line=prgptr;
1375 prog[stmts].num=lines;
1376 prog[stmts].source=srcptr;
1377 prog[stmts].sourcend=0;
1378 prog[stmts].related=0;
1379 wordlen=spcbefore=spc=0;
1380 gobble=1;
1381 continue;
1382 }
1383 /* as it is not a label, the word is uppercased */
1384 for(i=wordlen,ptr=word;i--;ptr++)ptr[0]=uc(ptr[0]);
1385 if(c=='='&&wordlen&&(start||last==DO)){ /* the stored word is a symbol */
1386 if(rexxsymbol(word[0])<1)die(Ename); /* Starts with number or dot */
1387 memcpy(prgptr,word,wordlen),
1388 prgptr+=wordlen,
1389 prgptr++[0]=c,
1390 wordlen=spcbefore=spc=0;
1391 gobble=1;
1392 start=0;
1393 last=0;
1394 continue;
1395 }
1396 /* the word may now be a token. */
1397 if(wordlen){
1398 for(i=0;i<numwords&&strcmp(word,words[i]);i++);
1399 if(i<numwords)token=(i-128);
1400 else token=0;
1401 if(token<Command&&!start){ /* "Commands" must be at the start, */
1402 if(token==NUMERIC&&last==PARSE); /* except NUMERIC & SELECT */
1403 else if(token==SELECT&&first==last&&last==END);
1404 else token=0;
1405 }
1406 else if(token>=Command&&start){ /* at the start must be a "command" */
1407 if(token==THEN||token==UPPER); /* except THEN, UPPER, PULL and ARG */
1408 else if(token==ARG||token==PULL)
1409 prgptr++[0]=PARSE,
1410 prgptr++[0]=UPPER,
1411 first=last=PARSE,
1412 start=0;
1413 else token=0;
1414 } /* Now some special case checking... */
1415 if(!token); /* no need to check if there is no token */
1416 else if(token==VALUE)if(last==ADDRESS||last==FORM||last==TRACE
1417 ||last==PARSE||last==SIGNAL);else token=0;
1418 else if(token==UPPER)if(start||last==PARSE);else token=0;
1419 else if(token>=PULL&&token<=LINEIN)if(last==PARSE);else token=0;
1420 else if(token==WITH)if(first==VALUE);else token=0;
1421 else if(token==ON||token==OFF)if(last==SIGNAL||last==CALL)
1422 first=token;/* allow NAME */ else token=0;
1423 else if(token==NAME)if(first==ON)first=token;else token=0;
1424 else if(token>=TO&&token<=FOR)if(first==DO);else token=0;
1425 else if(token==FOREVER)if(last==DO);else token=0;
1426 else if(token==WHILE||token==UNTIL)if(first==DO||first==WHILE)
1427 first=WHILE; /* disable TO, BY, FOR */ else token=0;
1428 else if(token==EXPOSE||token==HIDE)if(last==PROCEDURE);else token=0;
1429 else if(token>=DIGITS&&token<=FORM)if(first==last&&last==NUMERIC);
1430 else token=0;
1431 else if(token==THEN)if(start||first==IF||first==WHEN);else token=0;
1432 if(start)first=token; /* Save first token in each line */
1433 if(token!=UPPER)last=token; /* Save the previous token */
1434 if(token==VALUE&&first==PARSE)first=token; /* allow WITH */
1435 if(token==WITH)first=token; /* disallow WITH */
1436 if(token)wordlen=0;
1437 }
1438 else token=0;
1439 if(wordlen){ /* If there is still a word, it is a symbol */
1440 if(spcbefore)prgptr++[0]=' ';
1441 memcpy(prgptr,word,wordlen),
1442 prgptr+=wordlen,
1443 wordlen=0,
1444 start=0,
1445 gobble=0;
1446 }
1447 /* Check for space in case we add a new statement or two */
1448 if(token==THEN || token==ELSE || token==OTHERWISE || c== ';')
1449 if(stmts+3>=proglen)
1450 if(ptr=(char*)realloc((char*)prog,(proglen+=50)*sizeof(program)))
1451 prog=(program*)ptr;
1452 else die(Emem);
1453 if(token==THEN || token==ELSE || token==OTHERWISE){
1454 /* these tokens start new statements */
1455 if(!start){
1456 prgptr++[0]=0;
1457 prog[stmts].sourcend=prevptr,
1458 prog[++stmts].line=prgptr,
1459 prog[stmts].source=prevptr,
1460 prog[stmts].num=(interpret?0:lines),
1461 prog[stmts].related=0;
1462 }
1463 prgptr++[0]=token,
1464 prgptr++[0]=0;
1465 prog[stmts].sourcend=srcptr-1;
1466 prog[++stmts].line=prgptr,
1467 prog[stmts].num=(interpret?0:lines),
1468 prog[stmts].source=srcptr-1,
1469 prog[stmts].sourcend=0,
1470 prog[stmts].related=0;
1471 token=0;
1472 start=gobble=1;
1473 first=last=0;
1474 }
1475 else if(token){
1476 prgptr++[0]=token;
1477 gobble=1;
1478 start=0;
1479 }
1480 if(c==';'){
1481 if(start){
1482 prog[stmts].source=srcptr, /* delete the source of the */
1483 prog[stmts].num=(interpret?0:lines); /* null statement, but */
1484 continue; /* don't make an extra line */
1485 }
1486 prgptr++[0]=0;
1487 prog[stmts].sourcend=srcptr-1,
1488 prog[++stmts].line=prgptr,
1489 prog[stmts].source=srcptr,
1490 prog[stmts].sourcend=0,
1491 prog[stmts].num=(interpret?0:lines),
1492 prog[stmts].related=0;
1493 start=gobble=1;
1494 first=last=0;
1495 continue;
1496 }
1497 if(c==','){
1498 comma=1,
1499 gobble++, /* this saves the previous value of gobble */
1500 spc=0, /* and also makes gobble true */
1501 prgptr++[0]=c;
1502 continue;
1503 }
1504 /* Proceed to insert some non-blank characters. Gobble any previous
1505 spaces if necessary. */
1506 if(gobble)gobble=spc=0;
1507 if(type<=0 && c!='\'' && c!='\"'){ /* non-alpha and non-quote char */
1508 if(c!='(')spc=0; /* all except "(" gobble on left */
1509 if(c!=')')gobble=1; /* all except ")" gobble on right */
1510 }
1511 if(c=='\"'||c=='\''){
1512 if(spc)prgptr++[0]=' ',spc=0;
1513 prgptr++[0]=c;
1514 while(ilen--&&srcptr[0]!=c&&srcptr[0]!='\n')prgptr++[0]=srcptr++[0];
1515 if(srcptr++[0]!=c)die(Equote);
1516 }
1517 if(!type){ /* Can't be a token. Just insert it */
1518 if(spc)prgptr++[0]=' ',spc=0;
1519 prgptr++[0]=c;
1520 start=last=0;
1521 continue;
1522 }
1523 if(type<0){ /* might be a multi-char operator */
1524 ptr=srcptr;
1525 i=ilen;
1526 wordlen=0;
1527 ch=c;
1528 while(wordlen<3){
1529 while(i&&(ptr[0]==' '||ptr[0]=='\t'))i--,ptr++;
1530 if(whattype(ptr[0])!=-1)break;
1531 ch=(ch<<8)+ptr[0];
1532 ptr++,i--,wordlen++;
1533 }
1534 token=0;
1535 while(!token&&wordlen)
1536 switch(ch){
1537 case Cconcat: token=CONCAT; break; /* || */
1538 case Cxor: token=LXOR; break; /* && */
1539 case Cequ: token=EQU; break; /* == */
1540 case Cleq1: /* <= */
1541 case Cleq2: token=LEQ; break; /* \> */
1542 case Cgeq1: /* >= */
1543 case Cgeq2: token=GEQ; break; /* \> */
1544 case Cneq1: /* \= */
1545 case Cneq2: /* <> */
1546 case Cneq3: token=NEQ; break; /* >< */
1547 case Cnneq: token=NNEQ; break; /* \== */
1548 case Cmod: token=MOD; break; /* // */
1549 case Cless: token=LESS; break; /* << */
1550 case Cgrtr: token=GRTR; break; /* >> */
1551 case Clleq1: /* <<= */
1552 case Clleq2: token=LLEQ; break; /* \>> */
1553 case Cggeq1: /* >>= */
1554 case Cggeq2: token=GGEQ; break; /* \<< */
1555 case Cpower: token=POWER; break; /* ** */
1556 default: ch>>=8,wordlen--;
1557 }
1558 if(token)ch=token;
1559 prgptr++[0]=ch;
1560 while(wordlen){
1561 while(ptr[0]==' '||ptr[0]=='\t')ilen--,srcptr++;
1562 ilen--,srcptr++,wordlen--;
1563 }
1564 gobble=1;
1565 start=0;
1566 continue;
1567 }
1568 /* We have an alphanumeric character. Store a word. */
1569 prevptr=srcptr-1;
1570 spcbefore=spc;
1571 spc=gobble=0;
1572 ptr=srcptr-1;
1573 while(ilen--&&rexxsymboldot(srcptr++[0]));
1574 if(++ilen>0)srcptr--;
1575 wordlen=srcptr-ptr;
1576 mtest(word,varnamelen,wordlen+1,wordlen+1-varnamelen);
1577 memcpy(word,ptr,wordlen),
1578 word[wordlen]=0;
1579 }
1580 /* All characters considered; ilen was zero and the source was terminated */
1581 prgptr++[0]=0;
1582 prog[stmts].sourcend=srcptr-1;
1583 if(!interpret)lines--; /* Discount the new line started at the last '\n' */
1584 /* It will remain in the line table, however. */
1585 /* Now shrink all areas to their correct sizes */
1586 if(ptr=realloc((char*)prog,(1+stmts)*sizeof(program)))
1587 prog=(program*)ptr;
1588 if(!interpret && (ptr=realloc((char*)source,(2+lines)*sizeof(char*))))
1589 source=(char**)ptr;
1590 if(ptr=realloc(prog[0].line,prgptr-prog[0].line))
1591 if(ptr!=prog[0].line)
1592 /* Oops, the program moved! */
1593 for(i=stmts;i--;prog[i].line+=ptr-prog[0].line);
1594 if(!interpret){
1595 if(ptr=realloc(labelptr,elabptr+four))
1596 labelptr=ptr;
1597 (*(int *)(labelptr+elabptr))=0;
1598 }
1599 if(comment)stmts=commentstart,die(Elcomm);
1600 }
1601 #undef word
1602
1603 /* This function prints the source associated with a particular statement.
1604 If "after" is non-zero, it prints the source (if any) occurring between
1605 this statement and the next. It prefixes the source with "*-*" unless
1606 "error" is non-zero, in which case the prefix is "+++". */
printstmt(stmt,after,error)1607 void printstmt(stmt,after,error)
1608 int stmt,after,error;
1609 {
1610 int line=prog[stmt].num; /* source line number */
1611 char *start,*end; /* start and end of the source */
1612 char *what=error?"+++":"*-*"; /* The trace prefix */
1613 int spc; /* How much indentation there is */
1614 char *ptr;
1615 int i;
1616 if(stmt>stmts){ /* This never happens, I hope... */
1617 traceprefix(lines+1,what);
1618 tracestr("<EOF>\n");
1619 return;
1620 }
1621 else if(after){
1622 for(start=prog[stmt].source;start<prog[stmt].sourcend;start++)
1623 if(line&&start+1==source[line+1])
1624 ++line; /* find the line number of the source end */
1625 end=prog[stmt+1].source;
1626 }
1627 else start=prog[stmt].source,end=prog[stmt].sourcend;
1628 if(!end){ /* This never happens, I hope... */
1629 traceprefix(line,what);
1630 tracestr("<EOL>\n");
1631 return;
1632 }
1633 while(start<end&&
1634 (start[0]==0||start[0]==';'||start[0]==' '|start[0]=='\t')){
1635 if(line&&start+1==source[line+1])
1636 ++line;
1637 start++; /* step past uninteresting chars */
1638 }
1639 while(start<end&&
1640 (end[-1]==0||end[-1]==';'||end[-1]==' '|end[-1]=='\t'))
1641 end--; /* delete uninteresting trailing chars */
1642 if(start>=end)return; /* Nothing to print. */
1643 if(line)
1644 for(spc=0,ptr=source[line];ptr<start;ptr++)
1645 if(ptr[0]=='\t')spc=8+(spc&~7);/* This calculates the column within */
1646 else spc++; /* the line in which the statement starts */
1647 else spc=0;
1648 do{
1649 traceprefix(line,what);
1650 for(i=0;i<traceindent*pstacklev;i++)tracechar(' '); /* indent */
1651 for(i=0;i<spc&&start<end&&(start[0]==' '||start[0]=='\t');start++)
1652 if(start[0]=='\t')i=8+(i&~7); /* Remove leading spaces */
1653 else i++;
1654 while(i>spc)tracechar(' '),i--;/* Print part of a tab if necessary */
1655 for(;start<end&&(!line||start<source[line+1]-1);start++)
1656 if((i=start[0]&127)<' '||i==127)tracechar('?');
1657 else tracechar(i); /* Print statement */
1658 if(start<end&&line<lines)start=source[++line]; /* Go to next line */
1659 tracechar('\n');
1660 if(!error)what="*,*"; /* new ANSI prefix for continuations */
1661 } while(start<end&&line<=lines);
1662 }
1663 #if 0
1664 void expand(c) /* this is an old test routine. */
1665 char c;
1666 {
1667 static char *symwords[]={"||","&&","==","<=",">=","<>","\\==","//","<<",">>","<<=",">>=","**"};
1668 static char invvideo[]={27,'[','1','m',0};
1669 static char truevideo[]={27,'[','m',0};
1670 if(c==-1){printf("%s;%s",invvideo,truevideo);return;}
1671 printf("%s ",invvideo);
1672 if(c>SYMBOL)printf("%s",symwords[c-(SYMBOL+1)]);
1673 if(c<numwords-128)printf(words[c+128]);
1674 printf(" %s",truevideo);
1675 }
1676
1677 void display(line,ptr) /* so is this */
1678 int line,ptr;
1679 {
1680 char *s=((*prog)[line]);
1681 char c;
1682 int i=0;
1683 printf(" +++ %d +++ ",ppc);
1684 if(s==cnull)puts("(null)");
1685 while(c=s[i++]){
1686 if(c<0)expand(c);
1687 else putchar(c);
1688 if(i==ptr)printf("[*]");
1689 }
1690 putchar('\n');
1691 }
1692 #endif /* end of the old tokenisation routines which are commented out */
1693
1694 /* Return the default file extension (e.g., ".rexx") by checking the
1695 environment and then returning the system default. */
rexxext()1696 char *rexxext() {
1697 static char answer[maxextension];
1698 char *getenv();
1699 char *env=getenv("REXXEXT");
1700 if (env) {
1701 if (env[0]=='.' && env[1]) return env;
1702 if (!env[0] || strlen(env)>sizeof answer-2) return filetype;
1703 answer[0]='.';
1704 strcpy(answer+1,env);
1705 return answer;
1706 }
1707 else return filetype;
1708 }
1709
which(gn,opt,fn)1710 int which(gn,opt,fn)/* finds a file given name `gn'; puts path name in `fn'.
1711 opt<0 indicates that we are looking for a Unix
1712 program (namely, rxque).
1713 opt=0 indicates that the default extension should be
1714 appended, unless it is already at the end of gn.
1715 If not found then try without extension.
1716 opt=1 indicates that it is not to be appended.
1717 opt=2 means do a full search for a REXX function.
1718 opt=3 means search for a dll (.rxfn or exact name).*/
1719 char *fn,*gn;
1720 int opt; /* returns 0 if not found, 1 if rexx found, */
1721 { /* 2 if .rxfn found, 3 if Unix program found. */
1722 char *getenv();
1723 char *path; /* an element of the path */
1724 char *pathend; /* end of this element */
1725 char *basename; /* basename of the file to search for */
1726 int baselen; /* length of basename */
1727 int pathlen; /* length of path */
1728 int gpathlen; /* length of path component in given name */
1729 int tmplen; /* length of temporary filename buffer */
1730 char *defaultext=0; /* default extension */
1731 static char tmp[MAXPATHLEN]; /* temporary filename buffer */
1732 DIR *dp;
1733 struct dirent *dir;
1734 int found=0; /* 0->nothing found, 1->unix prog found, 2->.rexx found
1735 3->default filetype found, 4->.rxfn found */
1736 int copy;
1737 int go=1;
1738 int doexec=1; /* 0 -> don't search for default extension */
1739 int dot=0;
1740
1741 if (opt!=1 && opt!=3) {
1742 /* get system default extension and see if it is the same as the
1743 current default */
1744 defaultext=rexxext();
1745 doexec=strcmp(extension,defaultext);
1746 }
1747
1748 /* split name into pathname and basename */
1749 if((basename=strrchr(gn,'/')))gpathlen=basename++-gn;
1750 else gpathlen=0,basename=gn;
1751 baselen=strlen(basename);
1752 if(opt==0 && baselen>extlen && !strcmp(basename+baselen-extlen,extension))
1753 opt=1;
1754 /* find out where to look. */
1755 if(gn[0]=='.' && gn[1]=='/'){ /* special case for files in ./ */
1756 path="."; /* make path="." and remove the */
1757 gn+=2; /* "." from the name. This */
1758 if((gpathlen-=2)<0)gpathlen=0; /* causes "." to be expanded. */
1759 }
1760 else if(gn[0]=='.' && gn[1]=='.' && gn[2]=='/') /* for files in ../ */
1761 path="."; /* prepend current dir name */
1762 else if(gn[0]=='/'){
1763 path=""; /* path given; prepend nothing */
1764 dot=1; /* don't search "." either */
1765 if(opt==1){ /* whole name given - no search*/
1766 strcpy(fn,gn);
1767 return !access(fn,0);
1768 }
1769 }
1770 else {
1771 path=0;
1772 if(opt==3)path=getenv("REXXLIB"); /* DLLs in REXXLIB */
1773 if(opt>=2&&!(path && path[0]))
1774 path=getenv("REXXFUNC"); /* functions in REXXFUNC */
1775 if(opt==3&&!(path && path[0]))
1776 path=rxpath; /* default for DLLs is my libpath */
1777 if(opt>=0&&!(path && path[0]))
1778 path=getenv("REXXPATH"); /* REXX programs in REXXPATH */
1779 if(!(path && path[0]))path=getenv("PATH"); /* or in PATH */
1780 if(!(path && path[0]))path="."; /* or in "." */
1781 }
1782 if(opt<0)opt=1;
1783 /* scan each directory in the path */
1784 while(go && path){
1785 if((pathend=strchr(path,':')))pathlen=pathend++-path;
1786 else pathlen=strlen(path);
1787 if(pathlen==1 && path[0]=='.'){
1788 dot=1;
1789 if(!getcwd(tmp,sizeof tmp) || tmp[0]!='/') strcpy(tmp,".");
1790 tmplen=strlen(tmp);
1791 }
1792 else memcpy(tmp,path,tmplen=pathlen);
1793 if(gpathlen && gn[0]!='/' && pathlen)tmp[tmplen++]='/';
1794 memcpy(tmp+tmplen,gn,gpathlen);
1795 tmp[tmplen+=gpathlen]=0;
1796 if((dp=opendir(tmp))){
1797 while(go && (dir=readdir(dp))){/* for each file in the directory */
1798 if(memcmp(dir->d_name,basename,baselen))
1799 continue; /* check that it starts with basename */
1800 copy=0; /* if "copy" gets set then the current */
1801 /* name will be saved. */
1802 switch(opt){ /* validate the name according to opt */
1803 case 0: if (!strcmp(dir->d_name+baselen,extension))
1804 copy=found=1,go=0;
1805 else if (!found && !dir->d_name[baselen])copy=found=1;
1806 break;
1807 case 1: go=dir->d_name[baselen];
1808 if(!go)copy=found=1;
1809 break;
1810 case 2:
1811 if(!strcmp(dir->d_name+baselen,".rxfn"))copy=found=4,go=0;
1812 else if(found<3 && !strcmp(dir->d_name+baselen,extension))
1813 copy=found=3;
1814 else if(doexec &&
1815 found<2 && !strcmp(dir->d_name+baselen,defaultext))
1816 copy=found=2;
1817 else if(found<1 && !dir->d_name[baselen])copy=found=1;
1818 break;
1819 case 3:
1820 if(!dir->d_name[baselen])copy=found=1,go=0;
1821 else if(!strcmp(dir->d_name+baselen,".rxfn"))copy=found=4;
1822 }
1823 if(copy)
1824 strcpy(fn,tmp),
1825 fn[tmplen]='/',
1826 strcpy(fn+tmplen+1,dir->d_name);
1827 }
1828 closedir(dp);
1829 }
1830 else if (!access(tmp,X_OK)) {
1831 /* opendir failed - probably an unreadable directory. Try access().*/
1832 tmp[tmplen]='/';
1833 memcpy(tmp+tmplen+1,basename,baselen);
1834 tmp[tmplen+=baselen+1]=0;
1835 copy=0;
1836 switch(opt) {
1837 case 0:
1838 strcpy(tmp+tmplen,extension);
1839 if (!access(tmp,0)) {copy=found=1;go=0;break;}
1840 tmp[tmplen]=0;
1841 if (!found && !access(tmp,0)) copy=found=1;
1842 break;
1843 case 1:
1844 if (!access(tmp,0)) {copy=found=1;go=0;}
1845 break;
1846 case 2:
1847 strcpy(tmp+tmplen,".rxfn");
1848 if (!access(tmp,0)) {copy=found=4;go=0;break;}
1849 if (found==3) break;
1850 strcpy(tmp+tmplen,extension);
1851 if (!access(tmp,0)) {copy=found=3;break;}
1852 if (doexec && found<2) {
1853 strcpy(tmp+tmplen,defaultext);
1854 if (!access(tmp,0)) {copy=found=2;break;}
1855 }
1856 if (found>0) break;
1857 tmp[tmplen]=0;
1858 if (!access(tmp,0)) copy=found=1;
1859 break;
1860 case 3:
1861 if (!access(tmp,0)) {copy=found=1;go=0;break;}
1862 if (found) break;
1863 strcpy(tmp+tmplen,".rxfn");
1864 if (!access(tmp,0)) copy=found=1;
1865 }
1866 if (copy) strcpy(fn,tmp);
1867 }
1868 path=pathend;
1869 if(!path && !dot)path=".";
1870 }
1871 if(!found){
1872 strcpy(fn,gn);
1873 if(opt!=1)strcat(fn,extension);
1874 errno=ENOENT;
1875 return 0;
1876 }
1877 if(opt<2)return 1;
1878 if(found==1)return 3;
1879 if(found==4)return 2;
1880 return 1;
1881 }
1882
1883 /* Hash table routines */
1884 /* These routines maintain several tables (not actually hash tables, but
1885 never mind) in the style of the above variable handling routines, except
1886 that each table is single-level.
1887 Each table entry contains a hashent structure containing the following
1888 fields: next (length), grtr, less (tree pointer fields), value (the void*
1889 value associated with the name), and name. The name is a NUL-
1890 terminated sequence of characters followed by pad bytes to make up a
1891 multiple of 4 bytes.
1892 The hash tables maintained are:
1893 0. environment variable names => address of storage for their values
1894 1. file names => address of a structure containing their details
1895 2. function names => address of structure containing their details
1896
1897 Each hash table is characterised by three values: hashptr[x] is the
1898 address of hash table x, hashlen[x] is the amount of storage allocated,
1899 and ehashptr[x] is the actual length of the table.
1900 */
1901
hashsearch(hash,name,exist)1902 char *hashsearch(hash,name,exist)
1903 int hash;
1904 char *name;
1905 int *exist;
1906 /* search for name `name' of length `len' in hash table `hash'.
1907 The answer is the address of the entry which matches, with `exist'
1908 non-zero, or, if the name does not exist, exist=0 and the answer
1909 is the address of the slot where the new branch of the tree is to
1910 be added. If there are no names in the table, 0 is returned. */
1911 {
1912 char *data=hashptr[hash];
1913 char *ans=data;
1914 int *slot;
1915 int c;
1916 *exist=0;
1917 if(!ehashptr[hash])return cnull;
1918 while((c=strcmp(name,ans+sizeof(hashent)))
1919 && (*(slot= &(((hashent *)ans)->less)+(c>0)))>=0)
1920 ans=data+*slot;
1921 if(!c)return *exist=1,ans;
1922 return(char*)slot;
1923 }
1924
hashget(hash,name,exist)1925 void *hashget(hash,name,exist) /* like hashsearch, but the value is returned */
1926 int hash; /* (if any) */
1927 char *name;
1928 int *exist;
1929 {
1930 char *ptr=hashsearch(hash,name,exist);
1931 if(*exist)return((hashent *)ptr)->value;
1932 else return 0;
1933 }
1934
hashfind(hash,name,exist)1935 void **hashfind(hash,name,exist)
1936 int hash;
1937 char *name;
1938 int *exist;
1939 { /* like hashsearch, but the address of the value is returned. If no
1940 value is present, one is created. */
1941 char *ptr=hashsearch(hash,name,exist);
1942 int len;
1943 if(*exist)return &(((hashent *)ptr)->value);
1944 if(ptr)*(int *)ptr=ehashptr[hash];
1945 len=align(strlen(name)+1)+sizeof(hashent);
1946 mtest(hashptr[hash],hashlen[hash],ehashptr[hash]+len,len+256);
1947 ptr=hashptr[hash]+ehashptr[hash],
1948 ehashptr[hash]+=len,
1949 ((hashent *)ptr)->next=len,
1950 ((hashent *)ptr)->less=-1,
1951 ((hashent *)ptr)->grtr=-1,
1952 strcpy(ptr+sizeof(hashent),name);
1953 return &(((hashent *)ptr)->value);
1954 }
1955
fileinit(name,filename,fp)1956 struct fileinfo *fileinit(name,filename,fp)
1957 char *name,*filename; /* associate "name" with the file "filename" */
1958 FILE *fp; /* which has just been opened on fp */
1959 { /* return the fileinfo structure created */
1960 int exist;
1961 struct stat buf; /* For finding the file's details */
1962 void **entry=hashfind(1,name,&exist);
1963 unsigned len=align(filename?strlen(filename)+1:1);
1964 struct fileinfo *info=
1965 (struct fileinfo *)allocm(sizeof(struct fileinfo)+len);
1966 if(exist&&*entry) /* What if the name is already used? */
1967 fclose(((struct fileinfo *)(*entry))->fp),
1968 free((char*)(*entry));
1969 *entry=(void *)info;
1970 if(filename)strcpy((char*)(info+1),filename);
1971 else *(char*)(info+1)=0;
1972 if(fp && fstat(fileno(fp),&buf)==0) /* Make the file persistent if and */
1973 info->persist=S_ISREG(buf.st_mode); /* only if it can be determined */
1974 else info->persist=0; /* that it is a regular file */
1975 info->fp=fp, /* fill in the structure with suitable */
1976 info->wr=0, /* defaults */
1977 info->lastwr=1, /* lastwr=1 so that the first read does seek */
1978 info->rdpos=0, /* usually read from beginning of file */
1979 info->rdline=1,
1980 info->rdchars=0,
1981 info->wrpos=fp?ftell(fp):0, /* Usually write to end of file */
1982 info->wrline=!info->wrpos,
1983 info->wrchars=0,
1984 info->errnum=0;
1985 if(info->wrpos<0)info->wrpos=0; /* In case ftell failed */
1986 return info;
1987 }
1988
funcinit(name,handle,address,saa)1989 void funcinit(name,handle,address,saa) /* Associate "name" with a function */
1990 char *name; /* The REXX name of the function */
1991 void *handle; /* The handle from dlopen(), if this is the "main" function */
1992 int (*address)();/* The address of the function's implementation */
1993 int saa; /* calling sequence of the function */
1994 {
1995 funcinfo *info;
1996 int exist;
1997 void **slot=hashfind(2,name,&exist);
1998 if(!(exist&&*slot)) /* if it exists, a dl handle might be lost. */
1999 info=(funcinfo *)allocm(sizeof(funcinfo)),
2000 *slot=(void *)info;
2001 else info=(funcinfo*)*slot;
2002 info->dlhandle=handle;
2003 info->dlfunc=address;
2004 info->saa=saa;
2005 if(!address){ /* if the func has no address, just register its name. */
2006 info->dlhandle=0;
2007 info->name=allocm(1+strlen((char*)handle));
2008 strcpy(info->name,(char*)handle);
2009 }
2010 }
2011
libsearch()2012 void libsearch(){ /* search for *.rxlib files */
2013 char *getenv(); /* and hash the functions they contain. */
2014 char *path=getenv("REXXLIB");
2015 char *pathend;
2016 char *file;
2017 int l;
2018 int namelen;
2019 int ch;
2020 DIR *dp;
2021 FILE *fp;
2022 struct dirent *dir;
2023 int type;
2024 if(!(path&&path[0]))path=rxpath;
2025 while(path){
2026 if((pathend=strchr(path,':'))) /* temporarily change the next ':' */
2027 pathend[0]=0; /* into a 0 */
2028 if((dp=opendir(path))){
2029 while((dir=readdir(dp))){ /* for each file in the directory */
2030 /* matching *.rxlib ... */
2031 #if defined(sgi) || defined(Solaris) || defined(linux)
2032 namelen=strlen(dir->d_name);
2033 #else
2034 namelen=dir->d_namlen;
2035 #endif
2036 if(namelen>6 &&
2037 !memcmp(dir->d_name+namelen-6,".rxlib",6)){
2038 l=strlen(path);
2039 file=allocm(l+namelen+2);
2040 strcpy(file,path);
2041 file[l++]='/';
2042 strcpy(file+l,dir->d_name);
2043 l+=namelen;
2044 if((fp=fopen(file,"r"))){ /* read the file */
2045 file[l-6]=0; /* knock off the ".rxlib" */
2046 type=0;
2047 while((ch=getc(fp))!=EOF){
2048 if(ch==' ' || ch=='\t' || ch=='\r' || ch=='\n')
2049 continue;
2050 pull[0]=ch;
2051 l=1;
2052 while((ch=getc(fp))!=EOF &&
2053 !(ch==' ' || ch=='\t' || ch=='\r' || ch=='\n')){
2054 mtest(pull,pulllen,l+2,256);
2055 pull[l++]=ch;
2056 }
2057 pull[l]=0;
2058 if(!strcmp(pull,"rxmathfn:"))
2059 type=RXDIGITS; /* kludge for math functions */
2060 else if(!strcmp(pull,"rxsaa:"))
2061 type=1; /* kludge for SAA functions */
2062 else funcinit(pull,(void*)file,(int(*)())0,type);
2063 }
2064 fclose(fp);
2065 }
2066 free(file);
2067 }
2068 }
2069 closedir(dp);
2070 }
2071 if(pathend)pathend++[0]=':';
2072 path=pathend;
2073 }
2074 }
2075
fileclose(name)2076 int fileclose(name) /* close and free the file associated with "name" */
2077 char *name; /* return the code from close */
2078 {
2079 int exist;
2080 int ans=0;
2081 char *ptr=hashsearch(1,name,&exist);
2082 struct fileinfo *info;
2083 if(!exist)return 0;
2084 info=(struct fileinfo *)(((hashent *)ptr)->value);
2085 if(info){
2086 if(info->fp)ans=fclose(info->fp),
2087 free((char*)info);
2088 }
2089 ((hashent *)ptr)->value=0;
2090 return ans;
2091 }
2092
2093 #ifdef NO_LDL /* Define dummy versions of the dynamic load functions */
dlopen(path,mode)2094 void *dlopen(path, mode)
2095 char *path; int mode;
2096 {die(Eexist);/*NOTREACHED*/}
2097
dlsym(handle,sym)2098 void *dlsym(handle,sym)
2099 void *handle; char *sym;
2100 {die(Eexist);/*NOTREACHED*/}
2101
dlerror()2102 char *dlerror()
2103 {die(Eexist);/*NOTREACHED*/}
2104
dlclose(handle)2105 int dlclose(handle)
2106 void *handle;
2107 {die(Eexist);/*NOTREACHED*/}
2108
2109 #endif
2110