Commit | Line | Data |
---|---|---|
4bcd6e9e F |
1 | #include "defs" |
2 | ||
3 | ||
4 | ||
5 | cpn(n, a, b) | |
6 | register int n; | |
7 | register char *a, *b; | |
8 | { | |
9 | while(--n >= 0) | |
10 | *b++ = *a++; | |
11 | } | |
12 | ||
13 | ||
14 | ||
15 | eqn(n, a, b) | |
16 | register int n; | |
17 | register char *a, *b; | |
18 | { | |
19 | while(--n >= 0) | |
20 | if(*a++ != *b++) | |
21 | return(NO); | |
22 | return(YES); | |
23 | } | |
24 | ||
25 | ||
26 | ||
27 | ||
28 | ||
29 | ||
30 | ||
31 | cmpstr(a, b, la, lb) /* compare two strings */ | |
32 | register char *a, *b; | |
33 | ftnint la, lb; | |
34 | { | |
35 | register char *aend, *bend; | |
36 | aend = a + la; | |
37 | bend = b + lb; | |
38 | ||
39 | ||
40 | if(la <= lb) | |
41 | { | |
42 | while(a < aend) | |
43 | if(*a != *b) | |
44 | return( *a - *b ); | |
45 | else | |
46 | { ++a; ++b; } | |
47 | ||
48 | while(b < bend) | |
49 | if(*b != ' ') | |
50 | return(' ' - *b); | |
51 | else | |
52 | ++b; | |
53 | } | |
54 | ||
55 | else | |
56 | { | |
57 | while(b < bend) | |
58 | if(*a != *b) | |
59 | return( *a - *b ); | |
60 | else | |
61 | { ++a; ++b; } | |
62 | while(a < aend) | |
63 | if(*a != ' ') | |
64 | return(*a - ' '); | |
65 | else | |
66 | ++a; | |
67 | } | |
68 | return(0); | |
69 | } | |
70 | ||
71 | ||
72 | ||
73 | ||
74 | ||
75 | chainp hookup(x,y) | |
76 | register chainp x, y; | |
77 | { | |
78 | register chainp p; | |
79 | ||
80 | if(x == NULL) | |
81 | return(y); | |
82 | ||
83 | for(p = x ; p->nextp ; p = p->nextp) | |
84 | ; | |
85 | p->nextp = y; | |
86 | return(x); | |
87 | } | |
88 | ||
89 | ||
90 | ||
91 | struct listblock *mklist(p) | |
92 | chainp p; | |
93 | { | |
94 | register struct listblock *q; | |
95 | ||
96 | q = ALLOC(listblock); | |
97 | q->tag = TLIST; | |
98 | q->listp = p; | |
99 | return(q); | |
100 | } | |
101 | ||
102 | ||
103 | chainp mkchain(p,q) | |
104 | register int p, q; | |
105 | { | |
106 | register chainp r; | |
107 | ||
108 | if(chains) | |
109 | { | |
110 | r = chains; | |
111 | chains = chains->nextp; | |
112 | } | |
113 | else | |
114 | r = ALLOC(chain); | |
115 | ||
116 | r->datap = p; | |
117 | r->nextp = q; | |
118 | return(r); | |
119 | } | |
120 | ||
121 | ||
122 | ||
123 | char * varstr(n, s) | |
124 | register int n; | |
125 | register char *s; | |
126 | { | |
127 | register int i; | |
128 | static char name[XL+1]; | |
129 | ||
130 | for(i=0; i<n && *s!=' ' && *s!='\0' ; ++i) | |
131 | name[i] = *s++; | |
132 | ||
133 | name[i] = '\0'; | |
134 | ||
135 | return( name ); | |
136 | } | |
137 | ||
138 | ||
139 | ||
140 | ||
141 | char * varunder(n, s) | |
142 | register int n; | |
143 | register char *s; | |
144 | { | |
145 | register int i; | |
146 | static char name[XL+1]; | |
147 | ||
148 | for(i=0; i<n && *s!=' ' && *s!='\0' ; ++i) | |
149 | name[i] = *s++; | |
150 | ||
151 | #if TARGET != GCOS | |
152 | name[i++] = '_'; | |
153 | #endif | |
154 | ||
155 | name[i] = '\0'; | |
156 | ||
157 | return( name ); | |
158 | } | |
159 | ||
160 | ||
161 | ||
162 | ||
163 | ||
164 | char * nounder(n, s) | |
165 | register int n; | |
166 | register char *s; | |
167 | { | |
168 | register int i; | |
169 | static char name[XL+1]; | |
170 | ||
171 | for(i=0; i<n && *s!=' ' && *s!='\0' ; ++s) | |
172 | if(*s != '_') | |
173 | name[i++] = *s; | |
174 | ||
175 | name[i] = '\0'; | |
176 | ||
177 | return( name ); | |
178 | } | |
179 | ||
180 | ||
181 | ||
182 | char *copyn(n, s) | |
183 | register int n; | |
184 | register char *s; | |
185 | { | |
186 | register char *p, *q; | |
187 | ||
188 | p = q = ckalloc(n); | |
189 | while(--n >= 0) | |
190 | *q++ = *s++; | |
191 | return(p); | |
192 | } | |
193 | ||
194 | ||
195 | ||
196 | char *copys(s) | |
197 | char *s; | |
198 | { | |
199 | return( copyn( strlen(s)+1 , s) ); | |
200 | } | |
201 | ||
202 | ||
203 | ||
204 | ftnint convci(n, s) | |
205 | register int n; | |
206 | register char *s; | |
207 | { | |
208 | ftnint sum; | |
209 | sum = 0; | |
210 | while(n-- > 0) | |
211 | sum = 10*sum + (*s++ - '0'); | |
212 | return(sum); | |
213 | } | |
214 | ||
215 | char *convic(n) | |
216 | ftnint n; | |
217 | { | |
218 | static char s[20]; | |
219 | register char *t; | |
220 | ||
221 | s[19] = '\0'; | |
222 | t = s+19; | |
223 | ||
224 | do { | |
225 | *--t = '0' + n%10; | |
226 | n /= 10; | |
227 | } while(n > 0); | |
228 | ||
229 | return(t); | |
230 | } | |
231 | ||
232 | ||
233 | ||
234 | double convcd(n, s) | |
235 | int n; | |
236 | register char *s; | |
237 | { | |
238 | double atof(); | |
239 | char v[100]; | |
240 | register char *t; | |
241 | if(n > 90) | |
242 | { | |
243 | err("too many digits in floating constant"); | |
244 | n = 90; | |
245 | } | |
246 | for(t = v ; n-- > 0 ; s++) | |
247 | *t++ = (*s=='d' ? 'e' : *s); | |
248 | *t = '\0'; | |
249 | return( atof(v) ); | |
250 | } | |
251 | ||
252 | ||
253 | ||
254 | struct nameblock *mkname(l, s) | |
255 | int l; | |
256 | register char *s; | |
257 | { | |
258 | struct hashentry *hp; | |
259 | int hash; | |
260 | register struct nameblock *q; | |
261 | register int i; | |
262 | char n[VL]; | |
263 | ||
264 | hash = 0; | |
265 | for(i = 0 ; i<l && *s!='\0' ; ++i) | |
266 | { | |
267 | hash += *s; | |
268 | n[i] = *s++; | |
269 | } | |
270 | hash %= MAXHASH; | |
271 | while( i < VL ) | |
272 | n[i++] = ' '; | |
273 | ||
274 | hp = hashtab + hash; | |
275 | while(q = hp->varp) | |
276 | if( hash==hp->hashval && eqn(VL,n,q->varname) ) | |
277 | return(q); | |
278 | else if(++hp >= lasthash) | |
279 | hp = hashtab; | |
280 | ||
281 | if(++nintnames >= MAXHASH-1) | |
282 | fatal("hash table full"); | |
283 | hp->varp = q = ALLOC(nameblock); | |
284 | hp->hashval = hash; | |
285 | q->tag = TNAME; | |
286 | cpn(VL, n, q->varname); | |
287 | return(q); | |
288 | } | |
289 | ||
290 | ||
291 | ||
292 | struct labelblock *mklabel(l) | |
293 | ftnint l; | |
294 | { | |
295 | register struct labelblock *lp; | |
296 | ||
297 | if(l == 0) | |
298 | return(0); | |
299 | ||
300 | for(lp = labeltab ; lp < highlabtab ; ++lp) | |
301 | if(lp->stateno == l) | |
302 | return(lp); | |
303 | ||
304 | if(++highlabtab >= labtabend) | |
305 | fatal("too many statement numbers"); | |
306 | ||
307 | lp->stateno = l; | |
308 | lp->labelno = newlabel(); | |
309 | lp->blklevel = 0; | |
310 | lp->labused = NO; | |
311 | lp->labdefined = NO; | |
312 | lp->labinacc = NO; | |
313 | lp->labtype = LABUNKNOWN; | |
314 | return(lp); | |
315 | } | |
316 | ||
317 | ||
318 | newlabel() | |
319 | { | |
320 | return( ++lastlabno ); | |
321 | } | |
322 | ||
323 | ||
324 | /* find or put a name in the external symbol table */ | |
325 | ||
326 | struct extsym *mkext(s) | |
327 | char *s; | |
328 | { | |
329 | int i; | |
330 | register char *t; | |
331 | char n[XL]; | |
332 | struct extsym *p; | |
333 | ||
334 | i = 0; | |
335 | t = n; | |
336 | while(i<XL && *s) | |
337 | *t++ = *s++; | |
338 | while(t < n+XL) | |
339 | *t++ = ' '; | |
340 | ||
341 | for(p = extsymtab ; p<nextext ; ++p) | |
342 | if(eqn(XL, n, p->extname)) | |
343 | return( p ); | |
344 | ||
345 | if(nextext >= lastext) | |
346 | fatal("too many external symbols"); | |
347 | ||
348 | cpn(XL, n, nextext->extname); | |
349 | nextext->extstg = STGUNKNOWN; | |
350 | nextext->extsave = NO; | |
351 | nextext->extp = 0; | |
352 | nextext->extleng = 0; | |
353 | nextext->maxleng = 0; | |
354 | nextext->extinit = NO; | |
355 | return( nextext++ ); | |
356 | } | |
357 | ||
358 | ||
359 | ||
360 | ||
361 | ||
362 | ||
363 | ||
364 | ||
365 | struct addrblock *builtin(t, s) | |
366 | int t; | |
367 | char *s; | |
368 | { | |
369 | register struct extsym *p; | |
370 | register struct addrblock *q; | |
371 | ||
372 | p = mkext(s); | |
373 | if(p->extstg == STGUNKNOWN) | |
374 | p->extstg = STGEXT; | |
375 | else if(p->extstg != STGEXT) | |
376 | { | |
377 | err1("improper use of builtin %s", s); | |
378 | return(0); | |
379 | } | |
380 | ||
381 | q = ALLOC(addrblock); | |
382 | q->tag = TADDR; | |
383 | q->vtype = t; | |
384 | q->vclass = CLPROC; | |
385 | q->vstg = STGEXT; | |
386 | q->memno = p - extsymtab; | |
387 | return(q); | |
388 | } | |
389 | ||
390 | ||
391 | ||
392 | frchain(p) | |
393 | register chainp *p; | |
394 | { | |
395 | register chainp q; | |
396 | ||
397 | if(p==0 || *p==0) | |
398 | return; | |
399 | ||
400 | for(q = *p; q->nextp ; q = q->nextp) | |
401 | ; | |
402 | q->nextp = chains; | |
403 | chains = *p; | |
404 | *p = 0; | |
405 | } | |
406 | ||
407 | ||
408 | ptr cpblock(n,p) | |
409 | register int n; | |
410 | register char * p; | |
411 | { | |
412 | register char *q; | |
413 | ptr q0; | |
414 | ||
415 | q = q0 = ckalloc(n); | |
416 | while(n-- > 0) | |
417 | *q++ = *p++; | |
418 | return(q0); | |
419 | } | |
420 | ||
421 | ||
422 | ||
423 | max(a,b) | |
424 | int a,b; | |
425 | { | |
426 | return( a>b ? a : b); | |
427 | } | |
428 | ||
429 | ||
430 | ftnint lmax(a, b) | |
431 | ftnint a, b; | |
432 | { | |
433 | return( a>b ? a : b); | |
434 | } | |
435 | ||
436 | ftnint lmin(a, b) | |
437 | ftnint a, b; | |
438 | { | |
439 | return(a < b ? a : b); | |
440 | } | |
441 | ||
442 | ||
443 | ||
444 | ||
445 | maxtype(t1, t2) | |
446 | int t1, t2; | |
447 | { | |
448 | int t; | |
449 | ||
450 | t = max(t1, t2); | |
451 | if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) ) | |
452 | t = TYDCOMPLEX; | |
453 | return(t); | |
454 | } | |
455 | ||
456 | ||
457 | ||
458 | /* return log base 2 of n if n a power of 2; otherwise -1 */ | |
459 | #if FAMILY == SCJ | |
460 | log2(n) | |
461 | ftnint n; | |
462 | { | |
463 | int k; | |
464 | ||
465 | /* trick based on binary representation */ | |
466 | ||
467 | if(n<=0 || (n & (n-1))!=0) | |
468 | return(-1); | |
469 | ||
470 | for(k = 0 ; n >>= 1 ; ++k) | |
471 | ; | |
472 | return(k); | |
473 | } | |
474 | #endif | |
475 | ||
476 | ||
477 | ||
478 | frrpl() | |
479 | { | |
480 | struct rplblock *rp; | |
481 | ||
482 | while(rpllist) | |
483 | { | |
484 | rp = rpllist->nextp; | |
485 | free(rpllist); | |
486 | rpllist = rp; | |
487 | } | |
488 | } | |
489 | ||
490 | ||
491 | popstack(p) | |
492 | register chainp *p; | |
493 | { | |
494 | register chainp q; | |
495 | ||
496 | if(p==NULL || *p==NULL) | |
497 | fatal("popstack: stack empty"); | |
498 | q = (*p)->nextp; | |
499 | free(*p); | |
500 | *p = q; | |
501 | } | |
502 | ||
503 | ||
504 | ||
505 | struct exprblock *callk(type, name, args) | |
506 | int type; | |
507 | char *name; | |
508 | chainp args; | |
509 | { | |
510 | register struct exprblock *p; | |
511 | ||
512 | p = mkexpr(OPCALL, builtin(type,name), args); | |
513 | p->vtype = type; | |
514 | return(p); | |
515 | } | |
516 | ||
517 | ||
518 | ||
519 | struct exprblock *call4(type, name, arg1, arg2, arg3, arg4) | |
520 | int type; | |
521 | char *name; | |
522 | expptr arg1, arg2, arg3, arg4; | |
523 | { | |
524 | struct listblock *args; | |
525 | args = mklist( mkchain(arg1, mkchain(arg2, mkchain(arg3, mkchain(arg4, NULL)) ) ) ); | |
526 | return( callk(type, name, args) ); | |
527 | } | |
528 | ||
529 | ||
530 | ||
531 | ||
532 | struct exprblock *call3(type, name, arg1, arg2, arg3) | |
533 | int type; | |
534 | char *name; | |
535 | expptr arg1, arg2, arg3; | |
536 | { | |
537 | struct listblock *args; | |
538 | args = mklist( mkchain(arg1, mkchain(arg2, mkchain(arg3, NULL) ) ) ); | |
539 | return( callk(type, name, args) ); | |
540 | } | |
541 | ||
542 | ||
543 | ||
544 | ||
545 | ||
546 | struct exprblock *call2(type, name, arg1, arg2) | |
547 | int type; | |
548 | char *name; | |
549 | expptr arg1, arg2; | |
550 | { | |
551 | struct listblock *args; | |
552 | ||
553 | args = mklist( mkchain(arg1, mkchain(arg2, NULL) ) ); | |
554 | return( callk(type,name, args) ); | |
555 | } | |
556 | ||
557 | ||
558 | ||
559 | ||
560 | struct exprblock *call1(type, name, arg) | |
561 | int type; | |
562 | char *name; | |
563 | expptr arg; | |
564 | { | |
565 | return( callk(type,name, mklist(mkchain(arg,0)) )); | |
566 | } | |
567 | ||
568 | ||
569 | struct exprblock *call0(type, name) | |
570 | int type; | |
571 | char *name; | |
572 | { | |
573 | return( callk(type, name, NULL) ); | |
574 | } | |
575 | ||
576 | ||
577 | ||
578 | struct impldoblock *mkiodo(dospec, list) | |
579 | chainp dospec, list; | |
580 | { | |
581 | register struct impldoblock *q; | |
582 | ||
583 | q = ALLOC(impldoblock); | |
584 | q->tag = TIMPLDO; | |
585 | q->varnp = dospec; | |
586 | q->datalist = list; | |
587 | return(q); | |
588 | } | |
589 | ||
590 | ||
591 | ||
592 | ||
593 | ptr ckalloc(n) | |
594 | register int n; | |
595 | { | |
596 | register ptr p; | |
597 | ptr calloc(); | |
598 | ||
599 | if( p = calloc(1, (unsigned) n) ) | |
600 | return(p); | |
601 | ||
602 | fatal("out of memory"); | |
603 | /* NOTREACHED */ | |
604 | } | |
605 | ||
606 | ||
607 | ||
608 | ||
609 | ||
610 | isaddr(p) | |
611 | register expptr p; | |
612 | { | |
613 | if(p->tag == TADDR) | |
614 | return(YES); | |
615 | if(p->tag == TEXPR) | |
616 | switch(p->opcode) | |
617 | { | |
618 | case OPCOMMA: | |
619 | return( isaddr(p->rightp) ); | |
620 | ||
621 | case OPASSIGN: | |
622 | case OPPLUSEQ: | |
623 | return( isaddr(p->leftp) ); | |
624 | } | |
625 | return(NO); | |
626 | } | |
627 | ||
628 | ||
629 | ||
630 | ||
631 | ||
632 | addressable(p) | |
633 | register expptr p; | |
634 | { | |
635 | switch(p->tag) | |
636 | { | |
637 | case TCONST: | |
638 | return(YES); | |
639 | ||
640 | case TADDR: | |
641 | return( addressable(p->memoffset) ); | |
642 | ||
643 | default: | |
644 | return(NO); | |
645 | } | |
646 | } | |
647 | ||
648 | ||
649 | ||
650 | hextoi(c) | |
651 | register int c; | |
652 | { | |
653 | register char *p; | |
654 | static char p0[17] = "0123456789abcdef"; | |
655 | ||
656 | for(p = p0 ; *p ; ++p) | |
657 | if(*p == c) | |
658 | return( p-p0 ); | |
659 | return(16); | |
660 | } |