![[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] / 43BSD / ucb / dbx|
Return to fortran.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / 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.3 (Berkeley) 1/10/86";
9: #endif not lint
10:
11: static char rcsid[] = "$Header: fortran.c,v 1.5 84/12/26 10:39:37 linton 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:
175:
176: Symbol eltype;
177:
178: switch (s->class) {
179:
180: case CONST:
181:
182: printf("parameter %s = ", symname(s));
183: eval(s->symvalue.constval);
184: printval(s);
185: break;
186:
187: case REF:
188: printf(" (dummy argument) ");
189:
190: case VAR:
191: if (s->type->class == ARRAY &&
192: (not istypename(s->type->type,"char")) ) {
193: char bounds[130], *p1, **p;
194: p1 = bounds;
195: p = &p1;
196: mksubs(p,s->type);
197: *p -= 1;
198: **p = '\0'; /* get rid of trailing ',' */
199: printf(" %s %s[%s] ",typename(s), symname(s), bounds);
200: } else {
201: printf("%s %s", typename(s), symname(s));
202: }
203: break;
204:
205: case FUNC:
206: if (not istypename(s->type, "void")) {
207: printf(" %s function ", typename(s) );
208: }
209: else printf(" subroutine");
210: printf(" %s ", symname(s));
211: fortran_listparams(s);
212: break;
213:
214: case MODULE:
215: printf("source file \"%s.c\"", symname(s));
216: break;
217:
218: case PROG:
219: printf("executable file \"%s\"", symname(s));
220: break;
221:
222: default:
223: error("class %s in fortran_printdecl", classname(s));
224: }
225: putchar('\n');
226: }
227:
228: /*
229: * List the parameters of a procedure or function.
230: * No attempt is made to combine like types.
231: */
232:
233: public fortran_listparams(s)
234: Symbol s;
235: {
236: register Symbol t;
237:
238: putchar('(');
239: for (t = s->chain; t != nil; t = t->chain) {
240: printf("%s", symname(t));
241: if (t->chain != nil) {
242: printf(", ");
243: }
244: }
245: putchar(')');
246: if (s->chain != nil) {
247: printf("\n");
248: for (t = s->chain; t != nil; t = t->chain) {
249: if (t->class != REF) {
250: panic("unexpected class %d for parameter", t->class);
251: }
252: printdecl(t, 0);
253: }
254: } else {
255: putchar('\n');
256: }
257: }
258:
259: /*
260: * Print out the value on the top of the expression stack
261: * in the format for the type of the given symbol.
262: */
263:
264: public fortran_printval(s)
265: Symbol s;
266: {
267: register Symbol t;
268: register Address a;
269: register int i, len;
270: double d1, d2;
271:
272: switch (s->class) {
273: case CONST:
274: case TYPE:
275: case VAR:
276: case REF:
277: case FVAR:
278: case TAG:
279: fortran_printval(s->type);
280: break;
281:
282: case ARRAY:
283: t = rtype(s->type);
284: if (t->class == RANGE and istypename(t->type, "char")) {
285: len = size(s);
286: sp -= len;
287: printf("\"%.*s\"", len, sp);
288: } else {
289: fortran_printarray(s);
290: }
291: break;
292:
293: case RANGE:
294: if (isspecial(s)) {
295: switch (s->symvalue.rangev.lower) {
296: case sizeof(short):
297: if (istypename(s->type, "logical*2")) {
298: printlogical(pop(short));
299: }
300: break;
301:
302: case sizeof(float):
303: if (istypename(s->type, "logical")) {
304: printlogical(pop(long));
305: } else {
306: prtreal(pop(float));
307: }
308: break;
309:
310: case sizeof(double):
311: if (istypename(s->type, "complex")) {
312: d2 = pop(float);
313: d1 = pop(float);
314: printf("(");
315: prtreal(d1);
316: printf(",");
317: prtreal(d2);
318: printf(")");
319: } else {
320: prtreal(pop(double));
321: }
322: break;
323:
324: case 2*sizeof(double):
325: d2 = pop(double);
326: d1 = pop(double);
327: printf("(");
328: prtreal(d1);
329: printf(",");
330: prtreal(d2);
331: printf(")");
332: break;
333:
334: default:
335: panic("bad size \"%d\" for special",
336: s->symvalue.rangev.lower);
337: break;
338: }
339: } else {
340: printint(popsmall(s), s);
341: }
342: break;
343:
344: default:
345: if (ord(s->class) > ord(TYPEREF)) {
346: panic("printval: bad class %d", ord(s->class));
347: }
348: error("don't know how to print a %s", fortran_classname(s));
349: /* NOTREACHED */
350: }
351: }
352:
353: /*
354: * Print out a logical
355: */
356:
357: private printlogical(i)
358: Integer i;
359: {
360: if (i == 0) {
361: printf(".false.");
362: } else {
363: printf(".true.");
364: }
365: }
366:
367: /*
368: * Print out an int
369: */
370:
371: private printint(i, t)
372: Integer i;
373: register Symbol t;
374: {
375: if ( (t->type == t_int) or istypename(t->type, "integer") or
376: istypename(t->type,"integer*2") ) {
377: printf("%ld", i);
378: } else if (istypename(t->type, "addr")) {
379: printf("0x%lx", i);
380: } else {
381: error("unknown type in fortran printint");
382: }
383: }
384:
385: /*
386: * Print out a null-terminated string (pointer to char)
387: * starting at the given address.
388: */
389:
390: private printstring(addr)
391: Address addr;
392: {
393: register Address a;
394: register Integer i, len;
395: register Boolean endofstring;
396: union {
397: char ch[sizeof(Word)];
398: int word;
399: } u;
400:
401: putchar('"');
402: a = addr;
403: endofstring = false;
404: while (not endofstring) {
405: dread(&u, a, sizeof(u));
406: i = 0;
407: do {
408: if (u.ch[i] == '\0') {
409: endofstring = true;
410: } else {
411: printchar(u.ch[i]);
412: }
413: ++i;
414: } while (i < sizeof(Word) and not endofstring);
415: a += sizeof(Word);
416: }
417: putchar('"');
418: }
419: /*
420: * Return the FORTRAN name for the particular class of a symbol.
421: */
422:
423: public String fortran_classname(s)
424: Symbol s;
425: {
426: String str;
427:
428: switch (s->class) {
429: case REF:
430: str = "dummy argument";
431: break;
432:
433: case CONST:
434: str = "parameter";
435: break;
436:
437: default:
438: str = classname(s);
439: }
440: return str;
441: }
442:
443: /* reverses the indices from the expr_list; should be folded into buildaref
444: * and done as one recursive routine
445: */
446: Node private rev_index(here,n)
447: register Node here,n;
448: {
449:
450: register Node i;
451:
452: if( here == nil or here == n) i=nil;
453: else if( here->value.arg[1] == n) i = here;
454: else i=rev_index(here->value.arg[1],n);
455: return i;
456: }
457:
458: public Node fortran_buildaref(a, slist)
459: Node a, slist;
460: {
461: register Symbol as; /* array of array of .. cursor */
462: register Node en; /* Expr list cursor */
463: Symbol etype; /* Type of subscript expr */
464: Node esub, tree; /* Subscript expression ptr and tree to be built*/
465:
466: tree=a;
467:
468: as = rtype(tree->nodetype); /* node->sym.type->array*/
469: if ( not (
470: (tree->nodetype->class == VAR or tree->nodetype->class == REF)
471: and as->class == ARRAY
472: ) ) {
473: beginerrmsg();
474: prtree(stderr, a);
475: fprintf(stderr, " is not an array");
476: /*fprintf(stderr, " a-> %x as %x ", tree->nodetype, as ); OUT*/
477: enderrmsg();
478: } else {
479: for (en = rev_index(slist,nil); en != nil and as->class == ARRAY;
480: en = rev_index(slist,en), as = as->type) {
481: esub = en->value.arg[0];
482: etype = rtype(esub->nodetype);
483: assert(as->chain->class == RANGE);
484: if ( not compatible( t_int, etype) ) {
485: beginerrmsg();
486: fprintf(stderr, "subscript ");
487: prtree(stderr, esub);
488: fprintf(stderr, " is type %s ",symname(etype->type) );
489: enderrmsg();
490: }
491: tree = build(O_INDEX, tree, esub);
492: tree->nodetype = as->type;
493: }
494: if (en != nil or
495: (as->class == ARRAY && (not istypename(as->type,"char"))) ) {
496: beginerrmsg();
497: if (en != nil) {
498: fprintf(stderr, "too many subscripts for ");
499: } else {
500: fprintf(stderr, "not enough subscripts for ");
501: }
502: prtree(stderr, tree);
503: enderrmsg();
504: }
505: }
506: return tree;
507: }
508:
509: /*
510: * Evaluate a subscript index.
511: */
512:
513: public fortran_evalaref(s, base, i)
514: Symbol s;
515: Address base;
516: long i;
517: {
518: Symbol r, t;
519: long lb, ub;
520:
521: t = rtype(s);
522: r = t->chain;
523: if (
524: r->symvalue.rangev.lowertype == R_ARG or
525: r->symvalue.rangev.lowertype == R_TEMP
526: ) {
527: if (not getbound(
528: s, r->symvalue.rangev.lower, r->symvalue.rangev.lowertype, &lb
529: )) {
530: error("dynamic bounds not currently available");
531: }
532: } else {
533: lb = r->symvalue.rangev.lower;
534: }
535: if (
536: r->symvalue.rangev.uppertype == R_ARG or
537: r->symvalue.rangev.uppertype == R_TEMP
538: ) {
539: if (not getbound(
540: s, r->symvalue.rangev.upper, r->symvalue.rangev.uppertype, &ub
541: )) {
542: error("dynamic bounds not currently available");
543: }
544: } else {
545: ub = r->symvalue.rangev.upper;
546: }
547:
548: if (i < lb or i > ub) {
549: error("subscript out of range");
550: }
551: push(long, base + (i - lb) * size(t->type));
552: }
553:
554: private fortran_printarray(a)
555: Symbol a;
556: {
557: struct Bounds { int lb, val, ub} dim[MAXDIM];
558:
559: Symbol sc,st,eltype;
560: char buf[50];
561: char *subscr;
562: int i,ndim,elsize;
563: Stack *savesp;
564: Boolean done;
565:
566: st = a;
567:
568: savesp = sp;
569: sp -= size(a);
570: ndim=0;
571:
572: for(;;){
573: sc = st->chain;
574: if(sc->symvalue.rangev.lowertype == R_ARG or
575: sc->symvalue.rangev.lowertype == R_TEMP) {
576: if( ! getbound(a,sc->symvalue.rangev.lower,
577: sc->symvalue.rangev.lowertype, &dim[ndim].lb) )
578: error(" dynamic bounds not currently available");
579: }
580: else dim[ndim].lb = sc->symvalue.rangev.lower;
581:
582: if(sc->symvalue.rangev.uppertype == R_ARG or
583: sc->symvalue.rangev.uppertype == R_TEMP) {
584: if( ! getbound(a,sc->symvalue.rangev.upper,
585: sc->symvalue.rangev.uppertype, &dim[ndim].ub) )
586: error(" dynamic bounds not currently available");
587: }
588: else dim[ndim].ub = sc->symvalue.rangev.upper;
589:
590: ndim ++;
591: if (st->type->class == ARRAY) st=st->type;
592: else break;
593: }
594:
595: if(istypename(st->type,"char")) {
596: eltype = st;
597: ndim--;
598: }
599: else eltype=st->type;
600: elsize=size(eltype);
601: sp += elsize;
602: /*printf("ndim %d elsize %lx in fortran_printarray\n",ndim,elsize);OUT*/
603:
604: ndim--;
605: for (i=0;i<=ndim;i++){
606: dim[i].val=dim[i].lb;
607: /*OUT printf(" %d %d %d \n",i,dim[i].lb,dim[i].ub);
608: fflush(stdout); OUT*/
609: }
610:
611:
612: for(;;) {
613: buf[0]=',';
614: subscr = buf+1;
615:
616: for (i=ndim-1;i>=0;i--) {
617:
618: sprintf(subscr,"%d,",dim[i].val);
619: subscr += strlen(subscr);
620: }
621: *--subscr = '\0';
622:
623: for(i=dim[ndim].lb;i<=dim[ndim].ub;i++) {
624: printf("[%d%s]\t",i,buf);
625: printval(eltype);
626: printf("\n");
627: sp += 2*elsize;
628: }
629: dim[ndim].val=dim[ndim].ub;
630:
631: i=ndim-1;
632: if (i<0) break;
633:
634: done=false;
635: do {
636: dim[i].val++;
637: if(dim[i].val > dim[i].ub) {
638: dim[i].val = dim[i].lb;
639: if(--i<0) done=true;
640: }
641: else done=true;
642: }
643: while (not done);
644: if (i<0) break;
645: }
646: }
647:
648: /*
649: * Initialize typetable at beginning of a module.
650: */
651:
652: public fortran_modinit (typetable)
653: Symbol typetable[];
654: {
655: /* nothing for now */
656: }
657:
658: public boolean fortran_hasmodules ()
659: {
660: return false;
661: }
662:
663: public boolean fortran_passaddr (param, exprtype)
664: Symbol param, exprtype;
665: {
666: return false;
667: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.