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