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