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