xref: /csrg-svn/old/dbx/fortran.c (revision 33317)
121603Sdist /*
221603Sdist  * Copyright (c) 1983 Regents of the University of California.
321603Sdist  * All rights reserved.  The Berkeley software License Agreement
421603Sdist  * specifies the terms and conditions for redistribution.
521603Sdist  */
612554Scsvaf 
721603Sdist #ifndef lint
8*33317Sdonn static char sccsid[] = "@(#)fortran.c	5.4 (Berkeley) 01/12/88";
921603Sdist #endif not lint
1012554Scsvaf 
11*33317Sdonn static char rcsid[] = "$Header: fortran.c,v 1.3 87/03/25 20:00:03 donn Exp $";
1218219Slinton 
1312549Scsvaf /*
1412549Scsvaf  * FORTRAN dependent symbol routines.
1512549Scsvaf  */
1612549Scsvaf 
1712549Scsvaf #include "defs.h"
1812549Scsvaf #include "symbols.h"
1912549Scsvaf #include "printsym.h"
2012549Scsvaf #include "languages.h"
2112549Scsvaf #include "fortran.h"
2212549Scsvaf #include "tree.h"
2312549Scsvaf #include "eval.h"
2412549Scsvaf #include "operators.h"
2512549Scsvaf #include "mappings.h"
2612549Scsvaf #include "process.h"
2712549Scsvaf #include "runtime.h"
2812549Scsvaf #include "machine.h"
2912549Scsvaf 
3025810Sdonn #define isspecial(range) ( \
3112549Scsvaf     range->symvalue.rangev.upper == 0 and range->symvalue.rangev.lower > 0 \
3212549Scsvaf )
3312549Scsvaf 
3412549Scsvaf #define isrange(t, name) (t->class == RANGE and istypename(t->type, name))
3512549Scsvaf 
3612549Scsvaf #define MAXDIM  20
3716610Ssam 
3816610Ssam private Language fort;
3916610Ssam 
4012549Scsvaf /*
4112549Scsvaf  * Initialize FORTRAN language information.
4212549Scsvaf  */
4312549Scsvaf 
4412549Scsvaf public fortran_init()
4512549Scsvaf {
4616610Ssam     fort = language_define("fortran", ".f");
4716610Ssam     language_setop(fort, L_PRINTDECL, fortran_printdecl);
4816610Ssam     language_setop(fort, L_PRINTVAL, fortran_printval);
4916610Ssam     language_setop(fort, L_TYPEMATCH, fortran_typematch);
5016610Ssam     language_setop(fort, L_BUILDAREF, fortran_buildaref);
5116610Ssam     language_setop(fort, L_EVALAREF, fortran_evalaref);
5216610Ssam     language_setop(fort, L_MODINIT, fortran_modinit);
5316610Ssam     language_setop(fort, L_HASMODULES, fortran_hasmodules);
5416610Ssam     language_setop(fort, L_PASSADDR, fortran_passaddr);
5512549Scsvaf }
5612549Scsvaf 
5712549Scsvaf /*
5812549Scsvaf  * Test if two types are compatible.
5912549Scsvaf  *
6012549Scsvaf  * Integers and reals are not compatible since they cannot always be mixed.
6112549Scsvaf  */
6212549Scsvaf 
6312549Scsvaf public Boolean fortran_typematch(type1, type2)
6412549Scsvaf Symbol type1, type2;
6512549Scsvaf {
6612549Scsvaf 
6712549Scsvaf /* only does integer for now; may need to add others
6812549Scsvaf */
6912549Scsvaf 
7012549Scsvaf     Boolean b;
7112549Scsvaf     register Symbol t1, t2, tmp;
7212549Scsvaf 
7312549Scsvaf     t1 = rtype(type1);
7412549Scsvaf     t2 = rtype(type2);
7512549Scsvaf     if(t1 == nil or t1->type == nil or t2 == nil or t2->type == nil ) b = false;
7612549Scsvaf     else { b = (Boolean)   (
7712549Scsvaf             (t1 == t2)  or
7812549Scsvaf 	    (t1->type == t_int and (istypename(t2->type, "integer") or
7912549Scsvaf                                     istypename(t2->type, "integer*2"))  ) or
8012549Scsvaf 	    (t2->type == t_int and (istypename(t1->type, "integer") or
8112549Scsvaf                                     istypename(t1->type, "integer*2"))  )
8212549Scsvaf                     );
8312549Scsvaf          }
8412549Scsvaf     /*OUT fprintf(stderr," %d compat %s %s \n", b,
8512549Scsvaf       (t1 == nil or t1->type == nil ) ? "nil" : symname(t1->type),
8612549Scsvaf       (t2 == nil or t2->type == nil ) ? "nil" : symname(t2->type)  );*/
8712549Scsvaf     return b;
8812549Scsvaf }
8912549Scsvaf 
9012549Scsvaf private String typename(s)
9112549Scsvaf Symbol s;
9212549Scsvaf {
9312549Scsvaf int ub;
9412549Scsvaf static char buf[20];
9512549Scsvaf char *pbuf;
9612549Scsvaf Symbol st,sc;
9712549Scsvaf 
9812549Scsvaf      if(s->type->class == TYPE) return(symname(s->type));
9912549Scsvaf 
10012549Scsvaf      for(st = s->type; st->type->class != TYPE; st = st->type);
10112549Scsvaf 
10212549Scsvaf      pbuf=buf;
10312549Scsvaf 
10412549Scsvaf      if(istypename(st->type,"char"))  {
10512549Scsvaf 	  sprintf(pbuf,"character*");
10612549Scsvaf           pbuf += strlen(pbuf);
10712549Scsvaf 	  sc = st->chain;
10812549Scsvaf           if(sc->symvalue.rangev.uppertype == R_ARG or
10912549Scsvaf              sc->symvalue.rangev.uppertype == R_TEMP) {
11012549Scsvaf 	      if( ! getbound(s,sc->symvalue.rangev.upper,
11112549Scsvaf                     sc->symvalue.rangev.uppertype, &ub) )
11212549Scsvaf 		sprintf(pbuf,"(*)");
11312549Scsvaf 	      else
11412549Scsvaf 		sprintf(pbuf,"%d",ub);
11512549Scsvaf           }
11612549Scsvaf  	  else sprintf(pbuf,"%d",sc->symvalue.rangev.upper);
11712549Scsvaf      }
11812549Scsvaf      else {
11912549Scsvaf           sprintf(pbuf,"%s ",symname(st->type));
12012549Scsvaf      }
12112549Scsvaf      return(buf);
12212549Scsvaf }
12312549Scsvaf 
12412549Scsvaf private Symbol mksubs(pbuf,st)
12512549Scsvaf Symbol st;
12612549Scsvaf char  **pbuf;
12712549Scsvaf {
12812549Scsvaf    int lb, ub;
12912549Scsvaf    Symbol r, eltype;
13012549Scsvaf 
13112549Scsvaf    if(st->class != ARRAY or (istypename(st->type, "char")) ) return;
13212549Scsvaf    else {
13312549Scsvaf           mksubs(pbuf,st->type);
13412549Scsvaf           assert( (r = st->chain)->class == RANGE);
13512549Scsvaf 
13612549Scsvaf           if(r->symvalue.rangev.lowertype == R_ARG or
13712549Scsvaf              r->symvalue.rangev.lowertype == R_TEMP) {
13812549Scsvaf 	      if( ! getbound(st,r->symvalue.rangev.lower,
13912549Scsvaf                     r->symvalue.rangev.lowertype, &lb) )
14012549Scsvaf 		sprintf(*pbuf,"?:");
14112549Scsvaf 	      else
14212549Scsvaf 		sprintf(*pbuf,"%d:",lb);
14312549Scsvaf 	  }
14412549Scsvaf           else {
14512549Scsvaf 		lb = r->symvalue.rangev.lower;
14612549Scsvaf 		sprintf(*pbuf,"%d:",lb);
14712549Scsvaf 		}
14812549Scsvaf     	  *pbuf += strlen(*pbuf);
14912549Scsvaf 
15012549Scsvaf           if(r->symvalue.rangev.uppertype == R_ARG or
15112549Scsvaf              r->symvalue.rangev.uppertype == R_TEMP) {
15212549Scsvaf 	      if( ! getbound(st,r->symvalue.rangev.upper,
15312549Scsvaf                     r->symvalue.rangev.uppertype, &ub) )
15412549Scsvaf 		sprintf(*pbuf,"?,");
15512549Scsvaf 	      else
15612549Scsvaf 		sprintf(*pbuf,"%d,",ub);
15712549Scsvaf 	  }
15812549Scsvaf           else {
15912549Scsvaf 		ub = r->symvalue.rangev.upper;
16012549Scsvaf 		sprintf(*pbuf,"%d,",ub);
16112549Scsvaf 		}
16212549Scsvaf     	  *pbuf += strlen(*pbuf);
16312549Scsvaf 
16412549Scsvaf        }
16512549Scsvaf }
16612549Scsvaf 
16712549Scsvaf /*
16812549Scsvaf  * Print out the declaration of a FORTRAN variable.
16912549Scsvaf  */
17012549Scsvaf 
17112549Scsvaf public fortran_printdecl(s)
17212549Scsvaf Symbol s;
17312549Scsvaf {
174*33317Sdonn     Symbol eltype;
17512549Scsvaf 
17612549Scsvaf     switch (s->class) {
17712549Scsvaf 	case CONST:
17812549Scsvaf 	    printf("parameter %s = ", symname(s));
17925810Sdonn 	    eval(s->symvalue.constval);
18012549Scsvaf             printval(s);
18112549Scsvaf 	    break;
18212549Scsvaf 
18312549Scsvaf         case REF:
18412549Scsvaf             printf(" (dummy argument) ");
18516610Ssam 
18614652Slinton 	case VAR:
18716610Ssam 	    if (s->type->class == ARRAY &&
18816610Ssam 		 (not istypename(s->type->type,"char")) ) {
18916610Ssam                 char bounds[130], *p1, **p;
19012549Scsvaf 		p1 = bounds;
19112549Scsvaf                 p = &p1;
19216610Ssam                 mksubs(p,s->type);
19312549Scsvaf                 *p -= 1;
19412549Scsvaf                 **p = '\0';   /* get rid of trailing ',' */
19516610Ssam 		printf(" %s %s[%s] ",typename(s), symname(s), bounds);
19612549Scsvaf 	    } else {
19712549Scsvaf 		printf("%s %s", typename(s), symname(s));
19812549Scsvaf 	    }
19912549Scsvaf 	    break;
20012549Scsvaf 
20112549Scsvaf 	case FUNC:
20212627Scsvaf 	    if (not istypename(s->type, "void")) {
20312549Scsvaf                 printf(" %s function ", typename(s) );
20412549Scsvaf 	    }
20516610Ssam 	    else printf(" subroutine");
20612549Scsvaf 	    printf(" %s ", symname(s));
20712549Scsvaf 	    fortran_listparams(s);
20812549Scsvaf 	    break;
20912549Scsvaf 
21012549Scsvaf 	case MODULE:
21116610Ssam 	    printf("source file \"%s.c\"", symname(s));
21212549Scsvaf 	    break;
21312549Scsvaf 
21412549Scsvaf 	case PROG:
21512549Scsvaf 	    printf("executable file \"%s\"", symname(s));
21612549Scsvaf 	    break;
21712549Scsvaf 
21812549Scsvaf 	default:
21912549Scsvaf 	    error("class %s in fortran_printdecl", classname(s));
22012549Scsvaf     }
22112549Scsvaf     putchar('\n');
22212549Scsvaf }
22312549Scsvaf 
22412549Scsvaf /*
22512549Scsvaf  * List the parameters of a procedure or function.
22612549Scsvaf  * No attempt is made to combine like types.
22712549Scsvaf  */
22812549Scsvaf 
22912549Scsvaf public fortran_listparams(s)
23012549Scsvaf Symbol s;
23112549Scsvaf {
23212549Scsvaf     register Symbol t;
23312549Scsvaf 
23412549Scsvaf     putchar('(');
23512549Scsvaf     for (t = s->chain; t != nil; t = t->chain) {
23612549Scsvaf 	printf("%s", symname(t));
23712549Scsvaf 	if (t->chain != nil) {
23812549Scsvaf 	    printf(", ");
23912549Scsvaf 	}
24012549Scsvaf     }
24112549Scsvaf     putchar(')');
24212549Scsvaf     if (s->chain != nil) {
24312549Scsvaf 	printf("\n");
24412549Scsvaf 	for (t = s->chain; t != nil; t = t->chain) {
24512549Scsvaf 	    if (t->class != REF) {
24612549Scsvaf 		panic("unexpected class %d for parameter", t->class);
24712549Scsvaf 	    }
24812549Scsvaf 	    printdecl(t, 0);
24912549Scsvaf 	}
25012549Scsvaf     } else {
25112549Scsvaf 	putchar('\n');
25212549Scsvaf     }
25312549Scsvaf }
25412549Scsvaf 
25512549Scsvaf /*
25612549Scsvaf  * Print out the value on the top of the expression stack
25712549Scsvaf  * in the format for the type of the given symbol.
25812549Scsvaf  */
25912549Scsvaf 
26012549Scsvaf public fortran_printval(s)
26112549Scsvaf Symbol s;
26212549Scsvaf {
26312549Scsvaf     register Symbol t;
26412549Scsvaf     register Address a;
26512549Scsvaf     register int i, len;
26618219Slinton     double d1, d2;
26712549Scsvaf 
26812549Scsvaf     switch (s->class) {
26912549Scsvaf 	case CONST:
27012549Scsvaf 	case TYPE:
27112549Scsvaf 	case VAR:
27212549Scsvaf 	case REF:
27312549Scsvaf 	case FVAR:
27412549Scsvaf 	case TAG:
27512549Scsvaf 	    fortran_printval(s->type);
27612549Scsvaf 	    break;
27712549Scsvaf 
27812549Scsvaf 	case ARRAY:
27912549Scsvaf 	    t = rtype(s->type);
28012549Scsvaf 	    if (t->class == RANGE and istypename(t->type, "char")) {
28112549Scsvaf 		len = size(s);
28212549Scsvaf 		sp -= len;
28312549Scsvaf 		printf("\"%.*s\"", len, sp);
28412549Scsvaf 	    } else {
28512549Scsvaf 		fortran_printarray(s);
28612549Scsvaf 	    }
28712549Scsvaf 	    break;
28812549Scsvaf 
28912549Scsvaf 	case RANGE:
290*33317Sdonn 	     if (isspecial(s)) {
29112549Scsvaf 		switch (s->symvalue.rangev.lower) {
29225810Sdonn 		    case sizeof(short):
29325810Sdonn 			if (istypename(s->type, "logical*2")) {
29425810Sdonn 			    printlogical(pop(short));
29525810Sdonn 			}
29625810Sdonn 			break;
29725810Sdonn 
29812549Scsvaf 		    case sizeof(float):
29925810Sdonn 			if (istypename(s->type, "logical")) {
30025810Sdonn 			    printlogical(pop(long));
30125810Sdonn 			} else {
30225810Sdonn 			    prtreal(pop(float));
30325810Sdonn 			}
30412549Scsvaf 			break;
30512549Scsvaf 
30612549Scsvaf 		    case sizeof(double):
307*33317Sdonn 			if (istypename(s->type,"complex")) {
30818219Slinton 			    d2 = pop(float);
30918219Slinton 			    d1 = pop(float);
31018219Slinton 			    printf("(");
31118219Slinton 			    prtreal(d1);
31218219Slinton 			    printf(",");
31318219Slinton 			    prtreal(d2);
31418219Slinton 			    printf(")");
31518219Slinton 			} else {
31618219Slinton 			    prtreal(pop(double));
31712549Scsvaf 			}
31812549Scsvaf 			break;
31912549Scsvaf 
32024553Smckusick 		    case 2*sizeof(double):
32124553Smckusick 			d2 = pop(double);
32224553Smckusick 			d1 = pop(double);
32324553Smckusick 			printf("(");
32424553Smckusick 			prtreal(d1);
32524553Smckusick 			printf(",");
32624553Smckusick 			prtreal(d2);
32724553Smckusick 			printf(")");
32824553Smckusick 			break;
329*33317Sdonn 
33012549Scsvaf 		    default:
33125810Sdonn 			panic("bad size \"%d\" for special",
33224553Smckusick                                   s->symvalue.rangev.lower);
33312549Scsvaf 			break;
33412549Scsvaf 		}
33512549Scsvaf 	    } else {
33612549Scsvaf 		printint(popsmall(s), s);
33712549Scsvaf 	    }
33812549Scsvaf 	    break;
33912549Scsvaf 
34012549Scsvaf 	default:
34112549Scsvaf 	    if (ord(s->class) > ord(TYPEREF)) {
34212549Scsvaf 		panic("printval: bad class %d", ord(s->class));
34312549Scsvaf 	    }
34412549Scsvaf 	    error("don't know how to print a %s", fortran_classname(s));
34512549Scsvaf 	    /* NOTREACHED */
34612549Scsvaf     }
34712549Scsvaf }
34812549Scsvaf 
34912549Scsvaf /*
35025810Sdonn  * Print out a logical
35125810Sdonn  */
35225810Sdonn 
353*33317Sdonn private printlogical (i)
354*33317Sdonn integer i;
35525810Sdonn {
35625810Sdonn     if (i == 0) {
35725810Sdonn 	printf(".false.");
35825810Sdonn     } else {
35925810Sdonn 	printf(".true.");
36025810Sdonn     }
36125810Sdonn }
36225810Sdonn 
36325810Sdonn /*
36412549Scsvaf  * Print out an int
36512549Scsvaf  */
36612549Scsvaf 
36712549Scsvaf private printint(i, t)
36812549Scsvaf Integer i;
36912549Scsvaf register Symbol t;
37012549Scsvaf {
371*33317Sdonn     if (t->type == t_int or istypename(t->type, "integer") or
372*33317Sdonn 	istypename(t->type,"integer*2")
373*33317Sdonn     ) {
37412549Scsvaf 	printf("%ld", i);
37525810Sdonn     } else if (istypename(t->type, "addr")) {
37625810Sdonn 	printf("0x%lx", i);
37712549Scsvaf     } else {
37825810Sdonn 	error("unknown type in fortran printint");
37912549Scsvaf     }
38012549Scsvaf }
38112549Scsvaf 
38212549Scsvaf /*
38312549Scsvaf  * Print out a null-terminated string (pointer to char)
38412549Scsvaf  * starting at the given address.
38512549Scsvaf  */
38612549Scsvaf 
38712549Scsvaf private printstring(addr)
38812549Scsvaf Address addr;
38912549Scsvaf {
39012549Scsvaf     register Address a;
39112549Scsvaf     register Integer i, len;
39212549Scsvaf     register Boolean endofstring;
39312549Scsvaf     union {
39412549Scsvaf 	char ch[sizeof(Word)];
39512549Scsvaf 	int word;
39612549Scsvaf     } u;
39712549Scsvaf 
39812549Scsvaf     putchar('"');
39912549Scsvaf     a = addr;
40012549Scsvaf     endofstring = false;
40112549Scsvaf     while (not endofstring) {
40212549Scsvaf 	dread(&u, a, sizeof(u));
40312549Scsvaf 	i = 0;
40412549Scsvaf 	do {
40512549Scsvaf 	    if (u.ch[i] == '\0') {
40612549Scsvaf 		endofstring = true;
40712549Scsvaf 	    } else {
40812549Scsvaf 		printchar(u.ch[i]);
40912549Scsvaf 	    }
41012549Scsvaf 	    ++i;
41112549Scsvaf 	} while (i < sizeof(Word) and not endofstring);
41212549Scsvaf 	a += sizeof(Word);
41312549Scsvaf     }
41412549Scsvaf     putchar('"');
41512549Scsvaf }
41612549Scsvaf /*
41712549Scsvaf  * Return the FORTRAN name for the particular class of a symbol.
41812549Scsvaf  */
41912549Scsvaf 
42012549Scsvaf public String fortran_classname(s)
42112549Scsvaf Symbol s;
42212549Scsvaf {
42312549Scsvaf     String str;
42412549Scsvaf 
42512549Scsvaf     switch (s->class) {
42612549Scsvaf 	case REF:
42712549Scsvaf 	    str = "dummy argument";
42812549Scsvaf 	    break;
42912549Scsvaf 
43012549Scsvaf 	case CONST:
43112549Scsvaf 	    str = "parameter";
43212549Scsvaf 	    break;
43312549Scsvaf 
43412549Scsvaf 	default:
43512549Scsvaf 	    str = classname(s);
43612549Scsvaf     }
43712549Scsvaf     return str;
43812549Scsvaf }
43912549Scsvaf 
44012549Scsvaf /* reverses the indices from the expr_list; should be folded into buildaref
44112549Scsvaf  * and done as one recursive routine
44212549Scsvaf  */
44312549Scsvaf Node private rev_index(here,n)
44412549Scsvaf register Node here,n;
44512549Scsvaf {
44612549Scsvaf 
44712549Scsvaf   register Node i;
44812549Scsvaf 
44912549Scsvaf   if( here == nil  or  here == n) i=nil;
45012549Scsvaf   else if( here->value.arg[1] == n) i = here;
45112549Scsvaf   else i=rev_index(here->value.arg[1],n);
45212549Scsvaf   return i;
45312549Scsvaf }
45412549Scsvaf 
45512549Scsvaf public Node fortran_buildaref(a, slist)
45612549Scsvaf Node a, slist;
45712549Scsvaf {
45812549Scsvaf     register Symbol as;      /* array of array of .. cursor */
45912549Scsvaf     register Node en;        /* Expr list cursor */
46012549Scsvaf     Symbol etype;            /* Type of subscript expr */
46112549Scsvaf     Node esub, tree;         /* Subscript expression ptr and tree to be built*/
46212549Scsvaf 
46312549Scsvaf     tree=a;
46412549Scsvaf 
46512549Scsvaf     as = rtype(tree->nodetype);     /* node->sym.type->array*/
46612549Scsvaf     if ( not (
46712549Scsvaf                (tree->nodetype->class == VAR or tree->nodetype->class == REF)
46812549Scsvaf                 and as->class == ARRAY
46912549Scsvaf              ) ) {
47012549Scsvaf 	beginerrmsg();
47112549Scsvaf 	prtree(stderr, a);
47212549Scsvaf 	fprintf(stderr, " is not an array");
47312549Scsvaf 	/*fprintf(stderr, " a-> %x as %x ", tree->nodetype, as ); OUT*/
47412549Scsvaf 	enderrmsg();
47512549Scsvaf     } else {
47612549Scsvaf 	for (en = rev_index(slist,nil); en != nil and as->class == ARRAY;
47712549Scsvaf                      en = rev_index(slist,en), as = as->type) {
47812549Scsvaf 	    esub = en->value.arg[0];
47912549Scsvaf 	    etype = rtype(esub->nodetype);
48012549Scsvaf             assert(as->chain->class == RANGE);
48112549Scsvaf 	    if ( not compatible( t_int, etype) ) {
48212549Scsvaf 		beginerrmsg();
48312549Scsvaf 		fprintf(stderr, "subscript ");
48412549Scsvaf 		prtree(stderr, esub);
48512549Scsvaf 		fprintf(stderr, " is type %s ",symname(etype->type) );
48612549Scsvaf 		enderrmsg();
48712549Scsvaf 	    }
48812549Scsvaf 	    tree = build(O_INDEX, tree, esub);
48912549Scsvaf 	    tree->nodetype = as->type;
49012549Scsvaf 	}
49112549Scsvaf 	if (en != nil or
49212549Scsvaf              (as->class == ARRAY && (not istypename(as->type,"char"))) ) {
49312549Scsvaf 	    beginerrmsg();
49412549Scsvaf 	    if (en != nil) {
49512549Scsvaf 		fprintf(stderr, "too many subscripts for ");
49612549Scsvaf 	    } else {
49712549Scsvaf 		fprintf(stderr, "not enough subscripts for ");
49812549Scsvaf 	    }
49912549Scsvaf 	    prtree(stderr, tree);
50012549Scsvaf 	    enderrmsg();
50112549Scsvaf 	}
50212549Scsvaf     }
50312549Scsvaf     return tree;
50412549Scsvaf }
50512549Scsvaf 
50612549Scsvaf /*
50712549Scsvaf  * Evaluate a subscript index.
50812549Scsvaf  */
50912549Scsvaf 
51018219Slinton public fortran_evalaref(s, base, i)
51112549Scsvaf Symbol s;
51218219Slinton Address base;
51312549Scsvaf long i;
51412549Scsvaf {
51518219Slinton     Symbol r, t;
51612549Scsvaf     long lb, ub;
51712549Scsvaf 
51818219Slinton     t = rtype(s);
51918219Slinton     r = t->chain;
52018219Slinton     if (
52118219Slinton 	r->symvalue.rangev.lowertype == R_ARG or
52218219Slinton         r->symvalue.rangev.lowertype == R_TEMP
52318219Slinton     ) {
52418219Slinton 	if (not getbound(
52518219Slinton 	    s, r->symvalue.rangev.lower, r->symvalue.rangev.lowertype, &lb
52618219Slinton 	)) {
52712549Scsvaf           error("dynamic bounds not currently available");
52818219Slinton 	}
52918219Slinton     } else {
53018219Slinton 	lb = r->symvalue.rangev.lower;
53112549Scsvaf     }
53218219Slinton     if (
53318219Slinton 	r->symvalue.rangev.uppertype == R_ARG or
53418219Slinton         r->symvalue.rangev.uppertype == R_TEMP
53518219Slinton     ) {
53618219Slinton 	if (not getbound(
53718219Slinton 	    s, r->symvalue.rangev.upper, r->symvalue.rangev.uppertype, &ub
53818219Slinton 	)) {
53912549Scsvaf           error("dynamic bounds not currently available");
54018219Slinton 	}
54118219Slinton     } else {
54218219Slinton 	ub = r->symvalue.rangev.upper;
54312549Scsvaf     }
54412549Scsvaf 
54512549Scsvaf     if (i < lb or i > ub) {
54612549Scsvaf 	error("subscript out of range");
54712549Scsvaf     }
54818219Slinton     push(long, base + (i - lb) * size(t->type));
54912549Scsvaf }
55012549Scsvaf 
55112549Scsvaf private fortran_printarray(a)
55212549Scsvaf Symbol a;
55312549Scsvaf {
55412549Scsvaf struct Bounds { int lb, val, ub} dim[MAXDIM];
55512549Scsvaf 
55612549Scsvaf Symbol sc,st,eltype;
55712549Scsvaf char buf[50];
55812549Scsvaf char *subscr;
55912549Scsvaf int i,ndim,elsize;
56012549Scsvaf Stack *savesp;
56112549Scsvaf Boolean done;
56212549Scsvaf 
56312549Scsvaf st = a;
56412549Scsvaf 
56512549Scsvaf savesp = sp;
56612549Scsvaf sp -= size(a);
56712549Scsvaf ndim=0;
56812549Scsvaf 
56912549Scsvaf for(;;){
57012549Scsvaf           sc = st->chain;
57112549Scsvaf           if(sc->symvalue.rangev.lowertype == R_ARG or
57212549Scsvaf              sc->symvalue.rangev.lowertype == R_TEMP) {
57312549Scsvaf 	      if( ! getbound(a,sc->symvalue.rangev.lower,
57412627Scsvaf                     sc->symvalue.rangev.lowertype, &dim[ndim].lb) )
57512549Scsvaf 		error(" dynamic bounds not currently available");
57612549Scsvaf 	  }
57712549Scsvaf 	  else dim[ndim].lb = sc->symvalue.rangev.lower;
57812549Scsvaf 
57912549Scsvaf           if(sc->symvalue.rangev.uppertype == R_ARG or
58012549Scsvaf              sc->symvalue.rangev.uppertype == R_TEMP) {
58112549Scsvaf 	      if( ! getbound(a,sc->symvalue.rangev.upper,
58212549Scsvaf                     sc->symvalue.rangev.uppertype, &dim[ndim].ub) )
58312549Scsvaf 		error(" dynamic bounds not currently available");
58412549Scsvaf 	  }
58512549Scsvaf 	  else dim[ndim].ub = sc->symvalue.rangev.upper;
58612549Scsvaf 
58712549Scsvaf           ndim ++;
58812549Scsvaf           if (st->type->class == ARRAY) st=st->type;
58912549Scsvaf 	  else break;
59012549Scsvaf      }
59112549Scsvaf 
59212549Scsvaf if(istypename(st->type,"char")) {
59312549Scsvaf 		eltype = st;
59412549Scsvaf 		ndim--;
59512549Scsvaf 	}
59612549Scsvaf else eltype=st->type;
59712549Scsvaf elsize=size(eltype);
59812549Scsvaf sp += elsize;
59912549Scsvaf  /*printf("ndim %d elsize %lx in fortran_printarray\n",ndim,elsize);OUT*/
60012549Scsvaf 
60112549Scsvaf ndim--;
60212549Scsvaf for (i=0;i<=ndim;i++){
60312549Scsvaf 	  dim[i].val=dim[i].lb;
60412549Scsvaf 	  /*OUT printf(" %d %d %d \n",i,dim[i].lb,dim[i].ub);
60512549Scsvaf 	    fflush(stdout); OUT*/
60612549Scsvaf }
60712549Scsvaf 
60812549Scsvaf 
60912549Scsvaf for(;;) {
61012549Scsvaf 	buf[0]=',';
61112549Scsvaf 	subscr = buf+1;
61212549Scsvaf 
61312549Scsvaf 	for (i=ndim-1;i>=0;i--)  {
61412549Scsvaf 
61512549Scsvaf 		sprintf(subscr,"%d,",dim[i].val);
61612549Scsvaf         	subscr += strlen(subscr);
61712549Scsvaf 	}
61812549Scsvaf         *--subscr = '\0';
61912549Scsvaf 
62012549Scsvaf 	for(i=dim[ndim].lb;i<=dim[ndim].ub;i++) {
62112549Scsvaf 	      	printf("[%d%s]\t",i,buf);
62212549Scsvaf 		printval(eltype);
62312549Scsvaf 	      	printf("\n");
62412549Scsvaf 		sp += 2*elsize;
62512549Scsvaf 	}
62612549Scsvaf         dim[ndim].val=dim[ndim].ub;
62712549Scsvaf 
62812549Scsvaf         i=ndim-1;
62912549Scsvaf         if (i<0) break;
63012549Scsvaf 
63112549Scsvaf         done=false;
63212549Scsvaf         do {
63312549Scsvaf 		dim[i].val++;
63412549Scsvaf 		if(dim[i].val > dim[i].ub) {
63512549Scsvaf 			dim[i].val = dim[i].lb;
63612549Scsvaf 			if(--i<0) done=true;
63712549Scsvaf 		}
63812549Scsvaf 		else done=true;
63912549Scsvaf          }
64012549Scsvaf 	 while (not done);
64112549Scsvaf          if (i<0) break;
64212549Scsvaf      }
64312549Scsvaf }
64416610Ssam 
64516610Ssam /*
64616610Ssam  * Initialize typetable at beginning of a module.
64716610Ssam  */
64816610Ssam 
64916610Ssam public fortran_modinit (typetable)
65016610Ssam Symbol typetable[];
65116610Ssam {
65216610Ssam     /* nothing for now */
65316610Ssam }
65416610Ssam 
65516610Ssam public boolean fortran_hasmodules ()
65616610Ssam {
65716610Ssam     return false;
65816610Ssam }
65916610Ssam 
66016610Ssam public boolean fortran_passaddr (param, exprtype)
66116610Ssam Symbol param, exprtype;
66216610Ssam {
66316610Ssam     return false;
66416610Ssam }
665