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