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