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