xref: /csrg-svn/old/dbx/fortran.c (revision 16610)
1 /* Copyright (c) 1982 Regents of the University of California */
2 
3 static char sccsid[] = "@(#)fortran.c	1.3	5/20/83";
4 
5 static char rcsid[] = "$Header: fortran.c,v 1.3 84/03/27 10:20:53 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 
264     /* printf("fortran_printval with class %s \n",classname(s)); OUT*/
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 			   printf("(");
296 			prtreal(pop(float));
297 			   printf(",");
298 			prtreal(pop(float));
299 			   printf(")");
300 			}
301 			else prtreal(pop(double));
302 			break;
303 
304 		    default:
305 			panic("bad size \"%d\" for real",
306                                   t->symvalue.rangev.lower);
307 			break;
308 		}
309 	    } else {
310 		printint(popsmall(s), s);
311 	    }
312 	    break;
313 
314 	default:
315 	    if (ord(s->class) > ord(TYPEREF)) {
316 		panic("printval: bad class %d", ord(s->class));
317 	    }
318 	    error("don't know how to print a %s", fortran_classname(s));
319 	    /* NOTREACHED */
320     }
321 }
322 
323 /*
324  * Print out an int
325  */
326 
327 private printint(i, t)
328 Integer i;
329 register Symbol t;
330 {
331     if (istypename(t->type, "logical")) {
332 	printf(((Boolean) i) == true ? "true" : "false");
333     }
334     else if ( (t->type == t_int) or istypename(t->type, "integer") or
335                   istypename(t->type,"integer*2") ) {
336 	printf("%ld", i);
337     } else {
338       error("unkown type in fortran printint");
339     }
340 }
341 
342 /*
343  * Print out a null-terminated string (pointer to char)
344  * starting at the given address.
345  */
346 
347 private printstring(addr)
348 Address addr;
349 {
350     register Address a;
351     register Integer i, len;
352     register Boolean endofstring;
353     union {
354 	char ch[sizeof(Word)];
355 	int word;
356     } u;
357 
358     putchar('"');
359     a = addr;
360     endofstring = false;
361     while (not endofstring) {
362 	dread(&u, a, sizeof(u));
363 	i = 0;
364 	do {
365 	    if (u.ch[i] == '\0') {
366 		endofstring = true;
367 	    } else {
368 		printchar(u.ch[i]);
369 	    }
370 	    ++i;
371 	} while (i < sizeof(Word) and not endofstring);
372 	a += sizeof(Word);
373     }
374     putchar('"');
375 }
376 /*
377  * Return the FORTRAN name for the particular class of a symbol.
378  */
379 
380 public String fortran_classname(s)
381 Symbol s;
382 {
383     String str;
384 
385     switch (s->class) {
386 	case REF:
387 	    str = "dummy argument";
388 	    break;
389 
390 	case CONST:
391 	    str = "parameter";
392 	    break;
393 
394 	default:
395 	    str = classname(s);
396     }
397     return str;
398 }
399 
400 /* reverses the indices from the expr_list; should be folded into buildaref
401  * and done as one recursive routine
402  */
403 Node private rev_index(here,n)
404 register Node here,n;
405 {
406 
407   register Node i;
408 
409   if( here == nil  or  here == n) i=nil;
410   else if( here->value.arg[1] == n) i = here;
411   else i=rev_index(here->value.arg[1],n);
412   return i;
413 }
414 
415 public Node fortran_buildaref(a, slist)
416 Node a, slist;
417 {
418     register Symbol as;      /* array of array of .. cursor */
419     register Node en;        /* Expr list cursor */
420     Symbol etype;            /* Type of subscript expr */
421     Node esub, tree;         /* Subscript expression ptr and tree to be built*/
422 
423     tree=a;
424 
425     as = rtype(tree->nodetype);     /* node->sym.type->array*/
426     if ( not (
427                (tree->nodetype->class == VAR or tree->nodetype->class == REF)
428                 and as->class == ARRAY
429              ) ) {
430 	beginerrmsg();
431 	prtree(stderr, a);
432 	fprintf(stderr, " is not an array");
433 	/*fprintf(stderr, " a-> %x as %x ", tree->nodetype, as ); OUT*/
434 	enderrmsg();
435     } else {
436 	for (en = rev_index(slist,nil); en != nil and as->class == ARRAY;
437                      en = rev_index(slist,en), as = as->type) {
438 	    esub = en->value.arg[0];
439 	    etype = rtype(esub->nodetype);
440             assert(as->chain->class == RANGE);
441 	    if ( not compatible( t_int, etype) ) {
442 		beginerrmsg();
443 		fprintf(stderr, "subscript ");
444 		prtree(stderr, esub);
445 		fprintf(stderr, " is type %s ",symname(etype->type) );
446 		enderrmsg();
447 	    }
448 	    tree = build(O_INDEX, tree, esub);
449 	    tree->nodetype = as->type;
450 	}
451 	if (en != nil or
452              (as->class == ARRAY && (not istypename(as->type,"char"))) ) {
453 	    beginerrmsg();
454 	    if (en != nil) {
455 		fprintf(stderr, "too many subscripts for ");
456 	    } else {
457 		fprintf(stderr, "not enough subscripts for ");
458 	    }
459 	    prtree(stderr, tree);
460 	    enderrmsg();
461 	}
462     }
463     return tree;
464 }
465 
466 /*
467  * Evaluate a subscript index.
468  */
469 
470 public int fortran_evalaref(s, i)
471 Symbol s;
472 long i;
473 {
474     Symbol r;
475     long lb, ub;
476 
477     r = rtype(s)->chain;
478     if(r->symvalue.rangev.lowertype == R_ARG or
479        r->symvalue.rangev.lowertype == R_TEMP  ) {
480 	if(! getbound(s,r->symvalue.rangev.lower,
481 		        r->symvalue.rangev.lowertype,&lb))
482           error("dynamic bounds not currently available");
483     }
484     else lb = r->symvalue.rangev.lower;
485 
486     if(r->symvalue.rangev.uppertype == R_ARG or
487        r->symvalue.rangev.uppertype == R_TEMP  ) {
488 	if(! getbound(s,r->symvalue.rangev.upper,
489 		        r->symvalue.rangev.uppertype,&ub))
490           error("dynamic bounds not currently available");
491     }
492     else ub = r->symvalue.rangev.upper;
493 
494     if (i < lb or i > ub) {
495 	error("subscript out of range");
496     }
497     return (i - lb);
498 }
499 
500 private fortran_printarray(a)
501 Symbol a;
502 {
503 struct Bounds { int lb, val, ub} dim[MAXDIM];
504 
505 Symbol sc,st,eltype;
506 char buf[50];
507 char *subscr;
508 int i,ndim,elsize;
509 Stack *savesp;
510 Boolean done;
511 
512 st = a;
513 
514 savesp = sp;
515 sp -= size(a);
516 ndim=0;
517 
518 for(;;){
519           sc = st->chain;
520           if(sc->symvalue.rangev.lowertype == R_ARG or
521              sc->symvalue.rangev.lowertype == R_TEMP) {
522 	      if( ! getbound(a,sc->symvalue.rangev.lower,
523                     sc->symvalue.rangev.lowertype, &dim[ndim].lb) )
524 		error(" dynamic bounds not currently available");
525 	  }
526 	  else dim[ndim].lb = sc->symvalue.rangev.lower;
527 
528           if(sc->symvalue.rangev.uppertype == R_ARG or
529              sc->symvalue.rangev.uppertype == R_TEMP) {
530 	      if( ! getbound(a,sc->symvalue.rangev.upper,
531                     sc->symvalue.rangev.uppertype, &dim[ndim].ub) )
532 		error(" dynamic bounds not currently available");
533 	  }
534 	  else dim[ndim].ub = sc->symvalue.rangev.upper;
535 
536           ndim ++;
537           if (st->type->class == ARRAY) st=st->type;
538 	  else break;
539      }
540 
541 if(istypename(st->type,"char")) {
542 		eltype = st;
543 		ndim--;
544 	}
545 else eltype=st->type;
546 elsize=size(eltype);
547 sp += elsize;
548  /*printf("ndim %d elsize %lx in fortran_printarray\n",ndim,elsize);OUT*/
549 
550 ndim--;
551 for (i=0;i<=ndim;i++){
552 	  dim[i].val=dim[i].lb;
553 	  /*OUT printf(" %d %d %d \n",i,dim[i].lb,dim[i].ub);
554 	    fflush(stdout); OUT*/
555 }
556 
557 
558 for(;;) {
559 	buf[0]=',';
560 	subscr = buf+1;
561 
562 	for (i=ndim-1;i>=0;i--)  {
563 
564 		sprintf(subscr,"%d,",dim[i].val);
565         	subscr += strlen(subscr);
566 	}
567         *--subscr = '\0';
568 
569 	for(i=dim[ndim].lb;i<=dim[ndim].ub;i++) {
570 	      	printf("[%d%s]\t",i,buf);
571 		printval(eltype);
572 	      	printf("\n");
573 		sp += 2*elsize;
574 	}
575         dim[ndim].val=dim[ndim].ub;
576 
577         i=ndim-1;
578         if (i<0) break;
579 
580         done=false;
581         do {
582 		dim[i].val++;
583 		if(dim[i].val > dim[i].ub) {
584 			dim[i].val = dim[i].lb;
585 			if(--i<0) done=true;
586 		}
587 		else done=true;
588          }
589 	 while (not done);
590          if (i<0) break;
591      }
592 }
593 
594 /*
595  * Initialize typetable at beginning of a module.
596  */
597 
598 public fortran_modinit (typetable)
599 Symbol typetable[];
600 {
601     /* nothing for now */
602 }
603 
604 public boolean fortran_hasmodules ()
605 {
606     return false;
607 }
608 
609 public boolean fortran_passaddr (param, exprtype)
610 Symbol param, exprtype;
611 {
612     return false;
613 }
614