![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fortran.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / lib / old_compiler / dbx|
Return to fortran.c CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / lib / old_compiler / dbx |
1.1 root 1: /*
2: * Copyright (c) 1983 Regents of the University of California.
3: * All rights reserved. The Berkeley software License Agreement
4: * specifies the terms and conditions for redistribution.
5: */
6:
7: #ifndef lint
8: static char sccsid[] = "@(#)fortran.c 5.4 (Berkeley) 1/12/88";
9: #endif not lint
10:
11: static char rcsid[] = "$Header: fortran.c,v 1.3 87/03/25 20:00:03 donn Exp $";
12:
13: /*
14: * FORTRAN dependent symbol routines.
15: */
16:
17: #include "defs.h"
18: #include "symbols.h"
19: #include "printsym.h"
20: #include "languages.h"
21: #include "fortran.h"
22: #include "tree.h"
23: #include "eval.h"
24: #include "operators.h"
25: #include "mappings.h"
26: #include "process.h"
27: #include "runtime.h"
28: #include "machine.h"
29:
30: #define isspecial(range) ( \
31: range->symvalue.rangev.upper == 0 and range->symvalue.rangev.lower > 0 \
32: )
33:
34: #define isrange(t, name) (t->class == RANGE and istypename(t->type, name))
35:
36: #define MAXDIM 20
37:
38: private Language fort;
39:
40: /*
41: * Initialize FORTRAN language information.
42: */
43:
44: public fortran_init()
45: {
46: fort = language_define("fortran", ".f");
47: language_setop(fort, L_PRINTDECL, fortran_printdecl);
48: language_setop(fort, L_PRINTVAL, fortran_printval);
49: language_setop(fort, L_TYPEMATCH, fortran_typematch);
50: language_setop(fort, L_BUILDAREF, fortran_buildaref);
51: language_setop(fort, L_EVALAREF, fortran_evalaref);
52: language_setop(fort, L_MODINIT, fortran_modinit);
53: language_setop(fort, L_HASMODULES, fortran_hasmodules);
54: language_setop(fort, L_PASSADDR, fortran_passaddr);
55: }
56:
57: /*
58: * Test if two types are compatible.
59: *
60: * Integers and reals are not compatible since they cannot always be mixed.
61: */
62:
63: public Boolean fortran_typematch(type1, type2)
64: Symbol type1, type2;
65: {
66:
67: /* only does integer for now; may need to add others
68: */
69:
70: Boolean b;
71: register Symbol t1, t2, tmp;
72:
73: t1 = rtype(type1);
74: t2 = rtype(type2);
75: if(t1 == nil or t1->type == nil or t2 == nil or t2->type == nil ) b = false;
76: else { b = (Boolean) (
77: (t1 == t2) or
78: (t1->type == t_int and (istypename(t2->type, "integer") or
79: istypename(t2->type, "integer*2")) ) or
80: (t2->type == t_int and (istypename(t1->type, "integer") or
81: istypename(t1->type, "integer*2")) )
82: );
83: }
84: /*OUT fprintf(stderr," %d compat %s %s \n", b,
85: (t1 == nil or t1->type == nil ) ? "nil" : symname(t1->type),
86: (t2 == nil or t2->type == nil ) ? "nil" : symname(t2->type) );*/
87: return b;
88: }
89:
90: private String typename(s)
91: Symbol s;
92: {
93: int ub;
94: static char buf[20];
95: char *pbuf;
96: Symbol st,sc;
97:
98: if(s->type->class == TYPE) return(symname(s->type));
99:
100: for(st = s->type; st->type->class != TYPE; st = st->type);
101:
102: pbuf=buf;
103:
104: if(istypename(st->type,"char")) {
105: sprintf(pbuf,"character*");
106: pbuf += strlen(pbuf);
107: sc = st->chain;
108: if(sc->symvalue.rangev.uppertype == R_ARG or
109: sc->symvalue.rangev.uppertype == R_TEMP) {
110: if( ! getbound(s,sc->symvalue.rangev.upper,
111: sc->symvalue.rangev.uppertype, &ub) )
112: sprintf(pbuf,"(*)");
113: else
114: sprintf(pbuf,"%d",ub);
115: }
116: else sprintf(pbuf,"%d",sc->symvalue.rangev.upper);
117: }
118: else {
119: sprintf(pbuf,"%s ",symname(st->type));
120: }
121: return(buf);
122: }
123:
124: private Symbol mksubs(pbuf,st)
125: Symbol st;
126: char **pbuf;
127: {
128: int lb, ub;
129: Symbol r, eltype;
130:
131: if(st->class != ARRAY or (istypename(st->type, "char")) ) return;
132: else {
133: mksubs(pbuf,st->type);
134: assert( (r = st->chain)->class == RANGE);
135:
136: if(r->symvalue.rangev.lowertype == R_ARG or
137: r->symvalue.rangev.lowertype == R_TEMP) {
138: if( ! getbound(st,r->symvalue.rangev.lower,
139: r->symvalue.rangev.lowertype, &lb) )
140: sprintf(*pbuf,"?:");
141: else
142: sprintf(*pbuf,"%d:",lb);
143: }
144: else {
145: lb = r->symvalue.rangev.lower;
146: sprintf(*pbuf,"%d:",lb);
147: }
148: *pbuf += strlen(*pbuf);
149:
150: if(r->symvalue.rangev.uppertype == R_ARG or
151: r->symvalue.rangev.uppertype == R_TEMP) {
152: if( ! getbound(st,r->symvalue.rangev.upper,
153: r->symvalue.rangev.uppertype, &ub) )
154: sprintf(*pbuf,"?,");
155: else
156: sprintf(*pbuf,"%d,",ub);
157: }
158: else {
159: ub = r->symvalue.rangev.upper;
160: sprintf(*pbuf,"%d,",ub);
161: }
162: *pbuf += strlen(*pbuf);
163:
164: }
165: }
166:
167: /*
168: * Print out the declaration of a FORTRAN variable.
169: */
170:
171: public fortran_printdecl(s)
172: Symbol s;
173: {
174: Symbol eltype;
175:
176: switch (s->class) {
177: case CONST:
178: printf("parameter %s = ", symname(s));
179: eval(s->symvalue.constval);
180: printval(s);
181: break;
182:
183: case REF:
184: printf(" (dummy argument) ");
185:
186: case VAR:
187: if (s->type->class == ARRAY &&
188: (not istypename(s->type->type,"char")) ) {
189: char bounds[130], *p1, **p;
190: p1 = bounds;
191: p = &p1;
192: mksubs(p,s->type);
193: *p -= 1;
194: **p = '\0'; /* get rid of trailing ',' */
195: printf(" %s %s[%s] ",typename(s), symname(s), bounds);
196: } else {
197: printf("%s %s", typename(s), symname(s));
198: }
199: break;
200:
201: case FUNC:
202: if (not istypename(s->type, "void")) {
203: printf(" %s function ", typename(s) );
204: }
205: else printf(" subroutine");
206: printf(" %s ", symname(s));
207: fortran_listparams(s);
208: break;
209:
210: case MODULE:
211: printf("source file \"%s.c\"", symname(s));
212: break;
213:
214: case PROG:
215: printf("executable file \"%s\"", symname(s));
216: break;
217:
218: default:
219: error("class %s in fortran_printdecl", classname(s));
220: }
221: putchar('\n');
222: }
223:
224: /*
225: * List the parameters of a procedure or function.
226: * No attempt is made to combine like types.
227: */
228:
229: public fortran_listparams(s)
230: Symbol s;
231: {
232: register Symbol t;
233:
234: putchar('(');
235: for (t = s->chain; t != nil; t = t->chain) {
236: printf("%s", symname(t));
237: if (t->chain != nil) {
238: printf(", ");
239: }
240: }
241: putchar(')');
242: if (s->chain != nil) {
243: printf("\n");
244: for (t = s->chain; t != nil; t = t->chain) {
245: if (t->class != REF) {
246: panic("unexpected class %d for parameter", t->class);
247: }
248: printdecl(t, 0);
249: }
250: } else {
251: putchar('\n');
252: }
253: }
254:
255: /*
256: * Print out the value on the top of the expression stack
257: * in the format for the type of the given symbol.
258: */
259:
260: public fortran_printval(s)
261: Symbol s;
262: {
263: register Symbol t;
264: register Address a;
265: register int i, len;
266: double d1, d2;
267:
268: switch (s->class) {
269: case CONST:
270: case TYPE:
271: case VAR:
272: case REF:
273: case FVAR:
274: case TAG:
275: fortran_printval(s->type);
276: break;
277:
278: case ARRAY:
279: t = rtype(s->type);
280: if (t->class == RANGE and istypename(t->type, "char")) {
281: len = size(s);
282: sp -= len;
283: printf("\"%.*s\"", len, sp);
284: } else {
285: fortran_printarray(s);
286: }
287: break;
288:
289: case RANGE:
290: if (isspecial(s)) {
291: switch (s->symvalue.rangev.lower) {
292: case sizeof(short):
293: if (istypename(s->type, "logical*2")) {
294: printlogical(pop(short));
295: }
296: break;
297:
298: case sizeof(float):
299: if (istypename(s->type, "logical")) {
300: printlogical(pop(long));
301: } else {
302: prtreal(pop(float));
303: }
304: break;
305:
306: case sizeof(double):
307: if (istypename(s->type,"complex")) {
308: d2 = pop(float);
309: d1 = pop(float);
310: printf("(");
311: prtreal(d1);
312: printf(",");
313: prtreal(d2);
314: printf(")");
315: } else {
316: prtreal(pop(double));
317: }
318: break;
319:
320: case 2*sizeof(double):
321: d2 = pop(double);
322: d1 = pop(double);
323: printf("(");
324: prtreal(d1);
325: printf(",");
326: prtreal(d2);
327: printf(")");
328: break;
329:
330: default:
331: panic("bad size \"%d\" for special",
332: s->symvalue.rangev.lower);
333: break;
334: }
335: } else {
336: printint(popsmall(s), s);
337: }
338: break;
339:
340: default:
341: if (ord(s->class) > ord(TYPEREF)) {
342: panic("printval: bad class %d", ord(s->class));
343: }
344: error("don't know how to print a %s", fortran_classname(s));
345: /* NOTREACHED */
346: }
347: }
348:
349: /*
350: * Print out a logical
351: */
352:
353: private printlogical (i)
354: integer i;
355: {
356: if (i == 0) {
357: printf(".false.");
358: } else {
359: printf(".true.");
360: }
361: }
362:
363: /*
364: * Print out an int
365: */
366:
367: private printint(i, t)
368: Integer i;
369: register Symbol t;
370: {
371: if (t->type == t_int or istypename(t->type, "integer") or
372: istypename(t->type,"integer*2")
373: ) {
374: printf("%ld", i);
375: } else if (istypename(t->type, "addr")) {
376: printf("0x%lx", i);
377: } else {
378: error("unknown type in fortran printint");
379: }
380: }
381:
382: /*
383: * Print out a null-terminated string (pointer to char)
384: * starting at the given address.
385: */
386:
387: private printstring(addr)
388: Address addr;
389: {
390: register Address a;
391: register Integer i, len;
392: register Boolean endofstring;
393: union {
394: char ch[sizeof(Word)];
395: int word;
396: } u;
397:
398: putchar('"');
399: a = addr;
400: endofstring = false;
401: while (not endofstring) {
402: dread(&u, a, sizeof(u));
403: i = 0;
404: do {
405: if (u.ch[i] == '\0') {
406: endofstring = true;
407: } else {
408: printchar(u.ch[i]);
409: }
410: ++i;
411: } while (i < sizeof(Word) and not endofstring);
412: a += sizeof(Word);
413: }
414: putchar('"');
415: }
416: /*
417: * Return the FORTRAN name for the particular class of a symbol.
418: */
419:
420: public String fortran_classname(s)
421: Symbol s;
422: {
423: String str;
424:
425: switch (s->class) {
426: case REF:
427: str = "dummy argument";
428: break;
429:
430: case CONST:
431: str = "parameter";
432: break;
433:
434: default:
435: str = classname(s);
436: }
437: return str;
438: }
439:
440: /* reverses the indices from the expr_list; should be folded into buildaref
441: * and done as one recursive routine
442: */
443: Node private rev_index(here,n)
444: register Node here,n;
445: {
446:
447: register Node i;
448:
449: if( here == nil or here == n) i=nil;
450: else if( here->value.arg[1] == n) i = here;
451: else i=rev_index(here->value.arg[1],n);
452: return i;
453: }
454:
455: public Node fortran_buildaref(a, slist)
456: Node a, slist;
457: {
458: register Symbol as; /* array of array of .. cursor */
459: register Node en; /* Expr list cursor */
460: Symbol etype; /* Type of subscript expr */
461: Node esub, tree; /* Subscript expression ptr and tree to be built*/
462:
463: tree=a;
464:
465: as = rtype(tree->nodetype); /* node->sym.type->array*/
466: if ( not (
467: (tree->nodetype->class == VAR or tree->nodetype->class == REF)
468: and as->class == ARRAY
469: ) ) {
470: beginerrmsg();
471: prtree(stderr, a);
472: fprintf(stderr, " is not an array");
473: /*fprintf(stderr, " a-> %x as %x ", tree->nodetype, as ); OUT*/
474: enderrmsg();
475: } else {
476: for (en = rev_index(slist,nil); en != nil and as->class == ARRAY;
477: en = rev_index(slist,en), as = as->type) {
478: esub = en->value.arg[0];
479: etype = rtype(esub->nodetype);
480: assert(as->chain->class == RANGE);
481: if ( not compatible( t_int, etype) ) {
482: beginerrmsg();
483: fprintf(stderr, "subscript ");
484: prtree(stderr, esub);
485: fprintf(stderr, " is type %s ",symname(etype->type) );
486: enderrmsg();
487: }
488: tree = build(O_INDEX, tree, esub);
489: tree->nodetype = as->type;
490: }
491: if (en != nil or
492: (as->class == ARRAY && (not istypename(as->type,"char"))) ) {
493: beginerrmsg();
494: if (en != nil) {
495: fprintf(stderr, "too many subscripts for ");
496: } else {
497: fprintf(stderr, "not enough subscripts for ");
498: }
499: prtree(stderr, tree);
500: enderrmsg();
501: }
502: }
503: return tree;
504: }
505:
506: /*
507: * Evaluate a subscript index.
508: */
509:
510: public fortran_evalaref(s, base, i)
511: Symbol s;
512: Address base;
513: long i;
514: {
515: Symbol r, t;
516: long lb, ub;
517:
518: t = rtype(s);
519: r = t->chain;
520: if (
521: r->symvalue.rangev.lowertype == R_ARG or
522: r->symvalue.rangev.lowertype == R_TEMP
523: ) {
524: if (not getbound(
525: s, r->symvalue.rangev.lower, r->symvalue.rangev.lowertype, &lb
526: )) {
527: error("dynamic bounds not currently available");
528: }
529: } else {
530: lb = r->symvalue.rangev.lower;
531: }
532: if (
533: r->symvalue.rangev.uppertype == R_ARG or
534: r->symvalue.rangev.uppertype == R_TEMP
535: ) {
536: if (not getbound(
537: s, r->symvalue.rangev.upper, r->symvalue.rangev.uppertype, &ub
538: )) {
539: error("dynamic bounds not currently available");
540: }
541: } else {
542: ub = r->symvalue.rangev.upper;
543: }
544:
545: if (i < lb or i > ub) {
546: error("subscript out of range");
547: }
548: push(long, base + (i - lb) * size(t->type));
549: }
550:
551: private fortran_printarray(a)
552: Symbol a;
553: {
554: struct Bounds { int lb, val, ub} dim[MAXDIM];
555:
556: Symbol sc,st,eltype;
557: char buf[50];
558: char *subscr;
559: int i,ndim,elsize;
560: Stack *savesp;
561: Boolean done;
562:
563: st = a;
564:
565: savesp = sp;
566: sp -= size(a);
567: ndim=0;
568:
569: for(;;){
570: sc = st->chain;
571: if(sc->symvalue.rangev.lowertype == R_ARG or
572: sc->symvalue.rangev.lowertype == R_TEMP) {
573: if( ! getbound(a,sc->symvalue.rangev.lower,
574: sc->symvalue.rangev.lowertype, &dim[ndim].lb) )
575: error(" dynamic bounds not currently available");
576: }
577: else dim[ndim].lb = sc->symvalue.rangev.lower;
578:
579: if(sc->symvalue.rangev.uppertype == R_ARG or
580: sc->symvalue.rangev.uppertype == R_TEMP) {
581: if( ! getbound(a,sc->symvalue.rangev.upper,
582: sc->symvalue.rangev.uppertype, &dim[ndim].ub) )
583: error(" dynamic bounds not currently available");
584: }
585: else dim[ndim].ub = sc->symvalue.rangev.upper;
586:
587: ndim ++;
588: if (st->type->class == ARRAY) st=st->type;
589: else break;
590: }
591:
592: if(istypename(st->type,"char")) {
593: eltype = st;
594: ndim--;
595: }
596: else eltype=st->type;
597: elsize=size(eltype);
598: sp += elsize;
599: /*printf("ndim %d elsize %lx in fortran_printarray\n",ndim,elsize);OUT*/
600:
601: ndim--;
602: for (i=0;i<=ndim;i++){
603: dim[i].val=dim[i].lb;
604: /*OUT printf(" %d %d %d \n",i,dim[i].lb,dim[i].ub);
605: fflush(stdout); OUT*/
606: }
607:
608:
609: for(;;) {
610: buf[0]=',';
611: subscr = buf+1;
612:
613: for (i=ndim-1;i>=0;i--) {
614:
615: sprintf(subscr,"%d,",dim[i].val);
616: subscr += strlen(subscr);
617: }
618: *--subscr = '\0';
619:
620: for(i=dim[ndim].lb;i<=dim[ndim].ub;i++) {
621: printf("[%d%s]\t",i,buf);
622: printval(eltype);
623: printf("\n");
624: sp += 2*elsize;
625: }
626: dim[ndim].val=dim[ndim].ub;
627:
628: i=ndim-1;
629: if (i<0) break;
630:
631: done=false;
632: do {
633: dim[i].val++;
634: if(dim[i].val > dim[i].ub) {
635: dim[i].val = dim[i].lb;
636: if(--i<0) done=true;
637: }
638: else done=true;
639: }
640: while (not done);
641: if (i<0) break;
642: }
643: }
644:
645: /*
646: * Initialize typetable at beginning of a module.
647: */
648:
649: public fortran_modinit (typetable)
650: Symbol typetable[];
651: {
652: /* nothing for now */
653: }
654:
655: public boolean fortran_hasmodules ()
656: {
657: return false;
658: }
659:
660: public boolean fortran_passaddr (param, exprtype)
661: Symbol param, exprtype;
662: {
663: return false;
664: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.