![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to misc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f77|
Return to misc.c CVS log | Up to [Research Unix] / researchv10no / cmd / f77 |
1.1 root 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 tagptr p;
105: register chainp q;
106: {
107: register chainp r;
108:
109: if(chains)
110: {
111: r = chains;
112: chains = chains->nextp;
113: }
114: else
115: r = ALLOC(Chain);
116:
117: r->datap = p;
118: r->nextp = q;
119: return(r);
120: }
121:
122:
123:
124: char * varstr(n, s)
125: register int n;
126: register char *s;
127: {
128: register int i;
129: static char name[XL+1];
130:
131: for(i=0; i<n && *s!=' ' && *s!='\0' ; ++i)
132: name[i] = *s++;
133:
134: name[i] = '\0';
135:
136: return( name );
137: }
138:
139:
140:
141:
142: char * varunder(n, s)
143: register int n;
144: register char *s;
145: {
146: register int i;
147: static char name[XL+1];
148:
149: for(i=0; i<n && *s!=' ' && *s!='\0' ; ++i)
150: name[i] = *s++;
151:
152: #if TARGET != GCOS
153: name[i++] = '_';
154: #endif
155:
156: name[i] = '\0';
157:
158: return( name );
159: }
160:
161:
162:
163:
164:
165: char * nounder(n, s)
166: register int n;
167: register char *s;
168: {
169: register int i;
170: static char name[XL+1];
171:
172: for(i=0; i<n && *s!=' ' && *s!='\0' ; ++s)
173: if(*s != '_')
174: name[i++] = *s;
175:
176: name[i] = '\0';
177:
178: return( name );
179: }
180:
181:
182:
183: char *copyn(n, s)
184: register int n;
185: register char *s;
186: {
187: register char *p, *q;
188:
189: p = q = (char *) ckalloc(n);
190: while(--n >= 0)
191: *q++ = *s++;
192: return(p);
193: }
194:
195:
196:
197: char *copys(s)
198: char *s;
199: {
200: return( copyn( strlen(s)+1 , s) );
201: }
202:
203:
204:
205: ftnint convci(n, s)
206: register int n;
207: register char *s;
208: {
209: ftnint sum;
210: sum = 0;
211: while(n-- > 0)
212: sum = 10*sum + (*s++ - '0');
213: return(sum);
214: }
215:
216: char *convic(n)
217: ftnint n;
218: {
219: static char s[20];
220: register char *t;
221:
222: s[19] = '\0';
223: t = s+19;
224:
225: do {
226: *--t = '0' + n%10;
227: n /= 10;
228: } while(n > 0);
229:
230: return(t);
231: }
232:
233:
234:
235: double convcd(n, s)
236: int n;
237: register char *s;
238: {
239: double atof();
240: char v[100];
241: register char *t;
242: if(n > 90)
243: {
244: err("too many digits in floating constant");
245: n = 90;
246: }
247: for(t = v ; n-- > 0 ; s++)
248: *t++ = (*s=='d' ? 'e' : *s);
249: *t = '\0';
250: return( atof(v) );
251: }
252:
253:
254:
255: Namep mkname(l, s)
256: int l;
257: register char *s;
258: {
259: struct Hashentry *hp;
260: int hash;
261: register Namep q;
262: register int i;
263: char n[VL];
264:
265: hash = 0;
266: for(i = 0 ; i<l && *s!='\0' ; ++i)
267: {
268: hash += *s;
269: n[i] = *s++;
270: }
271: hash %= maxhash;
272: while( i < VL )
273: n[i++] = ' ';
274:
275: hp = hashtab + hash;
276: while(q = hp->varp)
277: if( hash==hp->hashval && eqn(VL,n,q->varname) )
278: return(q);
279: else if(++hp >= lasthash)
280: hp = hashtab;
281:
282: if(++nintnames >= maxhash-1)
283: many("names", 'n', maxhash);
284: hp->varp = q = ALLOC(Nameblock);
285: hp->hashval = hash;
286: q->tag = TNAME;
287: cpn(VL, n, q->varname);
288: return(q);
289: }
290:
291:
292:
293: struct Labelblock *mklabel(l)
294: ftnint l;
295: {
296: register struct Labelblock *lp;
297:
298: if(l <= 0)
299: return(NULL);
300:
301: for(lp = labeltab ; lp < highlabtab ; ++lp)
302: if(lp->stateno == l)
303: return(lp);
304:
305: if(++highlabtab > labtabend)
306: many("statement numbers", 's', maxstno);
307:
308: lp->stateno = l;
309: lp->labelno = newlabel();
310: lp->blklevel = 0;
311: lp->labused = NO;
312: lp->labdefined = NO;
313: lp->labinacc = NO;
314: lp->labtype = LABUNKNOWN;
315: return(lp);
316: }
317:
318:
319: newlabel()
320: {
321: return( ++lastlabno );
322: }
323:
324:
325: /* this label appears in a branch context */
326:
327: struct Labelblock *execlab(stateno)
328: ftnint stateno;
329: {
330: register struct Labelblock *lp;
331:
332: if(lp = mklabel(stateno))
333: {
334: if(lp->labinacc)
335: warn1("illegal branch to inner block, statement %s",
336: convic(stateno) );
337: else if(lp->labdefined == NO)
338: lp->blklevel = blklevel;
339: lp->labused = YES;
340: if(lp->labtype == LABFORMAT)
341: err("may not branch to a format");
342: else
343: lp->labtype = LABEXEC;
344: }
345: else
346: execerr("illegal label %s", convic(stateno));
347:
348: return(lp);
349: }
350:
351:
352:
353:
354:
355: /* find or put a name in the external symbol table */
356:
357: struct Extsym *mkext(s)
358: char *s;
359: {
360: int i;
361: register char *t;
362: char n[XL];
363: struct Extsym *p;
364:
365: i = 0;
366: t = n;
367: while(i<XL && *s)
368: *t++ = *s++;
369: while(t < n+XL)
370: *t++ = ' ';
371:
372: for(p = extsymtab ; p<nextext ; ++p)
373: if(eqn(XL, n, p->extname))
374: return( p );
375:
376: if(nextext >= lastext)
377: many("external symbols", 'x', maxext);
378:
379: cpn(XL, n, nextext->extname);
380: nextext->extstg = STGUNKNOWN;
381: nextext->extsave = NO;
382: nextext->extp = 0;
383: nextext->cv = 0;
384: nextext->extleng = 0;
385: nextext->maxleng = 0;
386: nextext->extinit = NO;
387: return( nextext++ );
388: }
389:
390:
391:
392:
393:
394:
395:
396:
397: Addrp builtin(t, s)
398: int t;
399: char *s;
400: {
401: register struct Extsym *p;
402: register Addrp q;
403:
404: p = mkext(s);
405: if(p->extstg == STGUNKNOWN)
406: p->extstg = STGEXT;
407: else if(p->extstg != STGEXT)
408: {
409: errstr("improper use of builtin %s", s);
410: return(0);
411: }
412:
413: q = ALLOC(Addrblock);
414: q->tag = TADDR;
415: q->vtype = t;
416: q->vclass = CLPROC;
417: q->vstg = STGEXT;
418: q->memno = p - extsymtab;
419: return(q);
420: }
421:
422:
423:
424: frchain(p)
425: register chainp *p;
426: {
427: register chainp q;
428:
429: if(p==0 || *p==0)
430: return;
431:
432: for(q = *p; q->nextp ; q = q->nextp)
433: ;
434: q->nextp = chains;
435: chains = *p;
436: *p = 0;
437: }
438:
439:
440: tagptr cpblock(n,p)
441: register int n;
442: register char * p;
443: {
444: register char *q;
445: ptr q0;
446:
447: q0 = ckalloc(n);
448: q = (char *) q0;
449: while(n-- > 0)
450: *q++ = *p++;
451: return( (tagptr) q0);
452: }
453:
454:
455:
456: max(a,b)
457: int a,b;
458: {
459: return( a>b ? a : b);
460: }
461:
462:
463: ftnint lmax(a, b)
464: ftnint a, b;
465: {
466: return( a>b ? a : b);
467: }
468:
469: ftnint lmin(a, b)
470: ftnint a, b;
471: {
472: return(a < b ? a : b);
473: }
474:
475:
476:
477:
478: maxtype(t1, t2)
479: int t1, t2;
480: {
481: int t;
482:
483: t = max(t1, t2);
484: if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) )
485: t = TYDCOMPLEX;
486: return(t);
487: }
488:
489:
490:
491: /* return log base 2 of n if n a power of 2; otherwise -1 */
492: #if FAMILY == PCC
493: log2(n)
494: ftnint n;
495: {
496: int k;
497:
498: /* trick based on binary representation */
499:
500: if(n<=0 || (n & (n-1))!=0)
501: return(-1);
502:
503: for(k = 0 ; n >>= 1 ; ++k)
504: ;
505: return(k);
506: }
507: #endif
508:
509:
510:
511: frrpl()
512: {
513: struct Rplblock *rp;
514:
515: while(rpllist)
516: {
517: rp = rpllist->rplnextp;
518: free( (charptr) rpllist);
519: rpllist = rp;
520: }
521: }
522:
523:
524:
525: expptr callk(type, name, args)
526: int type;
527: char *name;
528: chainp args;
529: {
530: register expptr p;
531:
532: p = mkexpr(OPCALL, builtin(type,name), args);
533: p->exprblock.vtype = type;
534: return(p);
535: }
536:
537:
538:
539: expptr call4(type, name, arg1, arg2, arg3, arg4)
540: int type;
541: char *name;
542: expptr arg1, arg2, arg3, arg4;
543: {
544: struct Listblock *args;
545: args = mklist( mkchain(arg1, mkchain(arg2, mkchain(arg3,
546: mkchain(arg4, CHNULL)) ) ) );
547: return( callk(type, name, args) );
548: }
549:
550:
551:
552:
553: expptr call3(type, name, arg1, arg2, arg3)
554: int type;
555: char *name;
556: expptr arg1, arg2, arg3;
557: {
558: struct Listblock *args;
559: args = mklist( mkchain(arg1, mkchain(arg2, mkchain(arg3, CHNULL) ) ) );
560: return( callk(type, name, args) );
561: }
562:
563:
564:
565:
566:
567: expptr call2(type, name, arg1, arg2)
568: int type;
569: char *name;
570: expptr arg1, arg2;
571: {
572: struct Listblock *args;
573:
574: args = mklist( mkchain(arg1, mkchain(arg2, CHNULL) ) );
575: return( callk(type,name, args) );
576: }
577:
578:
579:
580:
581: expptr call1(type, name, arg)
582: int type;
583: char *name;
584: expptr arg;
585: {
586: return( callk(type,name, mklist(mkchain(arg,CHNULL)) ));
587: }
588:
589:
590: expptr call0(type, name)
591: int type;
592: char *name;
593: {
594: return( callk(type, name, PNULL) );
595: }
596:
597:
598:
599: struct Impldoblock *mkiodo(dospec, list)
600: chainp dospec, list;
601: {
602: register struct Impldoblock *q;
603:
604: q = ALLOC(Impldoblock);
605: q->tag = TIMPLDO;
606: q->impdospec = dospec;
607: q->datalist = list;
608: return(q);
609: }
610:
611:
612:
613:
614: ptr ckalloc(n)
615: register int n;
616: {
617: register ptr p;
618: ptr calloc();
619:
620: if( p = calloc(1, (unsigned) n) )
621: return(p);
622:
623: fatal("out of memory");
624: /* NOTREACHED */
625: }
626:
627:
628:
629:
630:
631: isaddr(p)
632: register expptr p;
633: {
634: if(p->tag == TADDR)
635: return(YES);
636: if(p->tag == TEXPR)
637: switch(p->exprblock.opcode)
638: {
639: case OPCOMMA:
640: return( isaddr(p->exprblock.rightp) );
641:
642: case OPASSIGN:
643: case OPPLUSEQ:
644: return( isaddr(p->exprblock.leftp) );
645: }
646: return(NO);
647: }
648:
649:
650:
651:
652: isstatic(p)
653: register expptr p;
654: {
655: if(p->headblock.vleng && !ISCONST(p->headblock.vleng))
656: return(NO);
657:
658: switch(p->tag)
659: {
660: case TCONST:
661: return(YES);
662:
663: case TADDR:
664: if(ONEOF(p->addrblock.vstg,MSKSTATIC) &&
665: ISCONST(p->addrblock.memoffset))
666: return(YES);
667:
668: default:
669: return(NO);
670: }
671: }
672:
673:
674:
675: addressable(p)
676: register expptr p;
677: {
678: switch(p->tag)
679: {
680: case TCONST:
681: return(YES);
682:
683: case TADDR:
684: return( addressable(p->addrblock.memoffset) );
685:
686: default:
687: return(NO);
688: }
689: }
690:
691:
692:
693: hextoi(c)
694: register int c;
695: {
696: register char *p;
697: static char p0[17] = "0123456789abcdef";
698:
699: for(p = p0 ; *p ; ++p)
700: if(*p == c)
701: return( p-p0 );
702: return(16);
703: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.