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