|
|
1.1 root 1: #include <ctype.h>
2: #include "defs"
3:
4: char * copys(s)
5: register char *s;
6: {
7: register char *t;
8: char *k;
9: ptr calloc();
10:
11: for(t=s; *t++ ; );
12: if( (k = calloc( t-s , sizeof(char))) == NULL)
13: fatal("Cannot allocate memory");
14:
15: for(t=k ; *t++ = *s++ ; );
16: return(k);
17: }
18:
19:
20:
21: equals(a,b)
22: register char *a,*b;
23: {
24: if(a==b) return(YES);
25:
26: while(*a == *b)
27: if(*a == '\0') return(YES);
28: else {++a; ++b;}
29:
30: return(NO);
31: }
32:
33:
34: char *concat(a,b,c) /* c = concatenation of a and b */
35: register char *a,*b;
36: char *c;
37: {
38: register char *t;
39: t = c;
40:
41: while(*t = *a++) t++;
42: while(*t++ = *b++);
43: return(c);
44: }
45:
46:
47:
48:
49:
50: ptr conrep(a,b)
51: char *a, *b;
52: {
53: char *s;
54:
55: s = intalloc( strlen(a)+strlen(b)+1 );
56: concat(a,b,s);
57: cfree(a);
58: return(s);
59: }
60:
61:
62: eqcon(p,q)
63: register ptr p, q;
64: {
65: int pt, qt;
66:
67: if(p==q) return(YES);
68: if(p==NULL || q==NULL) return(NO);
69: pt = p->tag;
70: qt = q->tag;
71: if(pt==TNEGOP && qt==TNEGOP)
72: return( eqcon(p->leftp, q->leftp) );
73: if(pt==TCONST && qt==TNEGOP)
74: return(NO);
75: if(pt==TNEGOP && qt==TCONST)
76: return(NO);
77: if(p->tag==TCONST && q->tag==TCONST)
78: return( equals(p->leftp,q->leftp) );
79:
80: fatal("eqcon: nonconstant argument");
81: /* NOTREACHED */
82: }
83:
84:
85:
86: char *convic(n)
87: register int n;
88: {
89: static char s[20];
90: register char *t;
91:
92: s[19] = '\0';
93: t = s+19;
94:
95: do {
96: *--t = '0' + n%10;
97: n /= 10;
98: } while(n > 0);
99:
100: return(t);
101: }
102:
103:
104:
105: conval(p)
106: register ptr p;
107: {
108: int val;
109: if(isicon(p, &val))
110: return(val);
111: fatal("bad conval");
112: }
113:
114:
115:
116: isicon(p, valp)
117: ptr p;
118: int *valp;
119: {
120: int val1;
121:
122: if(p)
123: switch(p->tag)
124: {
125: case TNEGOP:
126: if(isicon(p->leftp, &val1))
127: {
128: *valp = - val1;
129: return(1);
130: }
131: break;
132:
133: case TCONST:
134: if(p->vtype == TYINT)
135: {
136: *valp = convci(p->leftp);
137: return(YES);
138: }
139: default:
140: break;
141: }
142: return(NO);
143: }
144:
145:
146:
147: isconst(p)
148: ptr p;
149: {
150: return(p->tag==TCONST || (p->tag==TNEGOP && isconst(p->leftp)) );
151: }
152:
153:
154:
155: iszero(s)
156: register char *s;
157: {
158: if(s == NULL)
159: return(YES);
160: while( *s=='+' || *s=='-' || *s==' ' )
161: ++s;
162: while( *s=='0' || *s=='.' )
163: ++s;
164: switch( *s )
165: {
166: case 'd':
167: case 'e':
168: case 'D':
169: case 'E':
170: case ' ':
171: case '\0':
172: return(YES);
173: default:
174: return(NO);
175: }
176: }
177:
178:
179:
180:
181: convci(p)
182: register char *p;
183: {
184: register int n;
185: register int sgn;
186:
187: n = 0;
188: sgn = 1;
189: for( ; *p ; ++p)
190: if(*p == '-')
191: sgn = -1;
192: else if( isdigit(*p) )
193: n = 10*n + (*p - '0');
194:
195: return(sgn * n);
196: }
197:
198:
199:
200: chainp hookup(x,y)
201: register chainp x, y;
202: {
203: register chainp p;
204:
205: if(x == NULL)
206: return(y);
207: for(p=x ; p->nextp ; p = p->nextp)
208: ;
209:
210: p->nextp = y;
211: return(x);
212: }
213:
214:
215: ptr cpexpr(p)
216: register ptr p;
217: {
218: register ptr e;
219: ptr q, q1;
220:
221: if(p == NULL)
222: return(NULL);
223:
224: e = allexpblock();
225: cpblock(p, e, sizeof(struct exprblock));
226:
227: switch(p->tag)
228: {
229: case TAROP:
230: case TRELOP:
231: case TLOGOP:
232: case TASGNOP:
233: case TCALL:
234: e->rightp = cpexpr(p->rightp);
235:
236: case TNOTOP:
237: case TNEGOP:
238: e->leftp = cpexpr(p->leftp);
239: break;
240:
241: case TCONST:
242: e->leftp = copys(p->leftp);
243: if(p->rightp)
244: e->rightp = copys(p->rightp);
245: if(p->vtype == TYCHAR)
246: e->vtypep = cpexpr(p->vtypep);
247: break;
248:
249: case TLIST:
250: q1 = &(e->leftp);
251: for(q = p->leftp ; q ; q = q->nextp)
252: q1 = q1->nextp = mkchain( cpexpr(q->datap), CHNULL);
253: break;
254:
255: case TTEMP:
256: case TNAME:
257: case TFTNBLOCK:
258: if(p->vsubs)
259: e->vsubs = cpexpr(p->vsubs);
260: if(p->voffset)
261: e->voffset = cpexpr(p->voffset);
262: break;
263:
264: case TERROR:
265: break;
266:
267: default:
268: badtag("cpexpr", p->tag);
269: }
270: return(e);
271: }
272:
273:
274: mvexpr(p,q)
275: char *p, *q;
276: {
277: cpblock(p,q, sizeof(struct exprblock) );
278: frexpblock(p);
279: }
280:
281:
282: cpblock(p,q,n)
283: register char *p, *q;
284: int n;
285: {
286: register int i;
287:
288: for(i=0; i<n; ++i)
289: *q++ = *p++;
290: }
291:
292:
293:
294: strlen(s)
295: register char *s;
296: {
297: register char *t;
298: for(t=s ; *t ; t++ ) ;
299: return(t-s);
300: }
301:
302:
303: char *procnm() /* name of the current procedure */
304: {
305: return( procname ? procname->sthead->namep : "" );
306: }
307:
308:
309:
310:
311:
312: ptr arg1(a) /* make an argument list of one value */
313: ptr a;
314: {
315: return( mknode(TLIST,0, mkchain(a,CHNULL), PNULL) );
316: }
317:
318:
319:
320: ptr arg2(a,b) /* make an argumentlist (a,b) */
321: ptr a,b;
322: {
323: register ptr p;
324:
325: p = mkchain(a, mkchain(b,CHNULL) );
326: return( mknode(TLIST,0, p,0) );
327: }
328:
329:
330:
331:
332: ptr arg4(a,b) /* make an argument list of (a,len(a), b,len(b)) */
333: ptr a,b;
334: {
335: register ptr p;
336: p = mkchain(b, mkchain(cpexpr(b->vtypep), CHNULL));
337: p = mkchain(a, mkchain(cpexpr(a->vtypep), p));
338: return( mknode(TLIST,0,p,PNULL));
339: }
340:
341:
342:
343: ptr builtin(type,s)
344: int type;
345: char *s;
346: {
347: register ptr p, q;
348: ptr mkvar(), mkname();
349:
350: if(p = name(s,1))
351: {
352: if(p->blklevel>1 || (p->tag!=TNAME && p->tag!=TKEYWORD)
353: || (q=p->varp)==0 || q->vext
354: || (q->vtype!=type && q->vtype!=TYUNDEFINED) )
355: {
356: exprerr("error involving builtin %s", s);
357: return(errnode());
358: }
359: if(q->vtype!= TYUNDEFINED)
360: return( cpexpr(q) );
361: }
362: else {
363: q = mkvar( mkname(s) );
364: if(blklevel > 1)
365: {
366: q->blklevel = 1;
367: q->sthead->blklevel = 1;
368: --ndecl[blklevel];
369: ++ndecl[1];
370: }
371: }
372:
373: q->vtype = type;
374: q->vdclstart = 1;
375: mkftnp(q);
376: return( cpexpr(q) );
377: }
378:
379:
380:
381: ptr errnode()
382: {
383: register struct exprblock * p;
384:
385: p = allexpblock();
386: p->tag = TERROR;
387: p->vtype = TYINT;
388: return(p);
389: }
390:
391:
392:
393: min(a,b)
394: int a,b;
395: {
396: return( a<b ? a : b);
397: }
398:
399:
400:
401: setvproc(p, v)
402: register ptr p;
403: register int v;
404: {
405: ptr q;
406: register int k;
407:
408: q = p->sthead->varp;
409: k = q->vproc;
410: /*debug printf("setvproc(%s ,%d)\n", q->sthead->namep, v); */
411: if(p != q)
412: p->vproc = k;
413: if(k == v)
414: return;
415:
416: if(k==PROCUNKNOWN || (k==PROCYES && v==PROCINTRINSIC) )
417: p->vproc = q->vproc = v;
418: else if( !(k==PROCINTRINSIC && v==PROCYES) && p->sthead->varp!=procname)
419: execerr("attempt to use %s as variable and procedure",
420: p->sthead->namep);
421: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.