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