xref: /original-bsd/old/dbx/fortran.c (revision 4d1ce0b0) 
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 
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 
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 
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 
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 
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 
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 
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 
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 
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 
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 
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  */
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 
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 
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 
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 
648 public fortran_modinit (typetable)
649 Symbol typetable[];
650 {
651     /* nothing for now */
652 }
653 
654 public boolean fortran_hasmodules ()
655 {
656     return false;
657 }
658 
659 public boolean fortran_passaddr (param, exprtype)
660 Symbol param, exprtype;
661 {
662     return false;
663 }
664