121603Sdist /* 2*38105Sbostic * Copyright (c) 1983 The Regents of the University of California. 3*38105Sbostic * All rights reserved. 4*38105Sbostic * 5*38105Sbostic * Redistribution and use in source and binary forms are permitted 6*38105Sbostic * provided that the above copyright notice and this paragraph are 7*38105Sbostic * duplicated in all such forms and that any documentation, 8*38105Sbostic * advertising materials, and other materials related to such 9*38105Sbostic * distribution and use acknowledge that the software was developed 10*38105Sbostic * by the University of California, Berkeley. The name of the 11*38105Sbostic * University may not be used to endorse or promote products derived 12*38105Sbostic * from this software without specific prior written permission. 13*38105Sbostic * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR 14*38105Sbostic * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED 15*38105Sbostic * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. 1621603Sdist */ 1712554Scsvaf 1821603Sdist #ifndef lint 19*38105Sbostic static char sccsid[] = "@(#)fortran.c 5.5 (Berkeley) 05/23/89"; 20*38105Sbostic #endif /* not lint */ 2112554Scsvaf 2212549Scsvaf /* 2312549Scsvaf * FORTRAN dependent symbol routines. 2412549Scsvaf */ 2512549Scsvaf 2612549Scsvaf #include "defs.h" 2712549Scsvaf #include "symbols.h" 2812549Scsvaf #include "printsym.h" 2912549Scsvaf #include "languages.h" 3012549Scsvaf #include "fortran.h" 3112549Scsvaf #include "tree.h" 3212549Scsvaf #include "eval.h" 3312549Scsvaf #include "operators.h" 3412549Scsvaf #include "mappings.h" 3512549Scsvaf #include "process.h" 3612549Scsvaf #include "runtime.h" 3712549Scsvaf #include "machine.h" 3812549Scsvaf 3925810Sdonn #define isspecial(range) ( \ 4012549Scsvaf range->symvalue.rangev.upper == 0 and range->symvalue.rangev.lower > 0 \ 4112549Scsvaf ) 4212549Scsvaf 4312549Scsvaf #define isrange(t, name) (t->class == RANGE and istypename(t->type, name)) 4412549Scsvaf 4512549Scsvaf #define MAXDIM 20 4616610Ssam 4716610Ssam private Language fort; 4816610Ssam 4912549Scsvaf /* 5012549Scsvaf * Initialize FORTRAN language information. 5112549Scsvaf */ 5212549Scsvaf 5312549Scsvaf public fortran_init() 5412549Scsvaf { 5516610Ssam fort = language_define("fortran", ".f"); 5616610Ssam language_setop(fort, L_PRINTDECL, fortran_printdecl); 5716610Ssam language_setop(fort, L_PRINTVAL, fortran_printval); 5816610Ssam language_setop(fort, L_TYPEMATCH, fortran_typematch); 5916610Ssam language_setop(fort, L_BUILDAREF, fortran_buildaref); 6016610Ssam language_setop(fort, L_EVALAREF, fortran_evalaref); 6116610Ssam language_setop(fort, L_MODINIT, fortran_modinit); 6216610Ssam language_setop(fort, L_HASMODULES, fortran_hasmodules); 6316610Ssam language_setop(fort, L_PASSADDR, fortran_passaddr); 6412549Scsvaf } 6512549Scsvaf 6612549Scsvaf /* 6712549Scsvaf * Test if two types are compatible. 6812549Scsvaf * 6912549Scsvaf * Integers and reals are not compatible since they cannot always be mixed. 7012549Scsvaf */ 7112549Scsvaf 7212549Scsvaf public Boolean fortran_typematch(type1, type2) 7312549Scsvaf Symbol type1, type2; 7412549Scsvaf { 7512549Scsvaf 7612549Scsvaf /* only does integer for now; may need to add others 7712549Scsvaf */ 7812549Scsvaf 7912549Scsvaf Boolean b; 8012549Scsvaf register Symbol t1, t2, tmp; 8112549Scsvaf 8212549Scsvaf t1 = rtype(type1); 8312549Scsvaf t2 = rtype(type2); 8412549Scsvaf if(t1 == nil or t1->type == nil or t2 == nil or t2->type == nil ) b = false; 8512549Scsvaf else { b = (Boolean) ( 8612549Scsvaf (t1 == t2) or 8712549Scsvaf (t1->type == t_int and (istypename(t2->type, "integer") or 8812549Scsvaf istypename(t2->type, "integer*2")) ) or 8912549Scsvaf (t2->type == t_int and (istypename(t1->type, "integer") or 9012549Scsvaf istypename(t1->type, "integer*2")) ) 9112549Scsvaf ); 9212549Scsvaf } 9312549Scsvaf /*OUT fprintf(stderr," %d compat %s %s \n", b, 9412549Scsvaf (t1 == nil or t1->type == nil ) ? "nil" : symname(t1->type), 9512549Scsvaf (t2 == nil or t2->type == nil ) ? "nil" : symname(t2->type) );*/ 9612549Scsvaf return b; 9712549Scsvaf } 9812549Scsvaf 9912549Scsvaf private String typename(s) 10012549Scsvaf Symbol s; 10112549Scsvaf { 10212549Scsvaf int ub; 10312549Scsvaf static char buf[20]; 10412549Scsvaf char *pbuf; 10512549Scsvaf Symbol st,sc; 10612549Scsvaf 10712549Scsvaf if(s->type->class == TYPE) return(symname(s->type)); 10812549Scsvaf 10912549Scsvaf for(st = s->type; st->type->class != TYPE; st = st->type); 11012549Scsvaf 11112549Scsvaf pbuf=buf; 11212549Scsvaf 11312549Scsvaf if(istypename(st->type,"char")) { 11412549Scsvaf sprintf(pbuf,"character*"); 11512549Scsvaf pbuf += strlen(pbuf); 11612549Scsvaf sc = st->chain; 11712549Scsvaf if(sc->symvalue.rangev.uppertype == R_ARG or 11812549Scsvaf sc->symvalue.rangev.uppertype == R_TEMP) { 11912549Scsvaf if( ! getbound(s,sc->symvalue.rangev.upper, 12012549Scsvaf sc->symvalue.rangev.uppertype, &ub) ) 12112549Scsvaf sprintf(pbuf,"(*)"); 12212549Scsvaf else 12312549Scsvaf sprintf(pbuf,"%d",ub); 12412549Scsvaf } 12512549Scsvaf else sprintf(pbuf,"%d",sc->symvalue.rangev.upper); 12612549Scsvaf } 12712549Scsvaf else { 12812549Scsvaf sprintf(pbuf,"%s ",symname(st->type)); 12912549Scsvaf } 13012549Scsvaf return(buf); 13112549Scsvaf } 13212549Scsvaf 13312549Scsvaf private Symbol mksubs(pbuf,st) 13412549Scsvaf Symbol st; 13512549Scsvaf char **pbuf; 13612549Scsvaf { 13712549Scsvaf int lb, ub; 13812549Scsvaf Symbol r, eltype; 13912549Scsvaf 14012549Scsvaf if(st->class != ARRAY or (istypename(st->type, "char")) ) return; 14112549Scsvaf else { 14212549Scsvaf mksubs(pbuf,st->type); 14312549Scsvaf assert( (r = st->chain)->class == RANGE); 14412549Scsvaf 14512549Scsvaf if(r->symvalue.rangev.lowertype == R_ARG or 14612549Scsvaf r->symvalue.rangev.lowertype == R_TEMP) { 14712549Scsvaf if( ! getbound(st,r->symvalue.rangev.lower, 14812549Scsvaf r->symvalue.rangev.lowertype, &lb) ) 14912549Scsvaf sprintf(*pbuf,"?:"); 15012549Scsvaf else 15112549Scsvaf sprintf(*pbuf,"%d:",lb); 15212549Scsvaf } 15312549Scsvaf else { 15412549Scsvaf lb = r->symvalue.rangev.lower; 15512549Scsvaf sprintf(*pbuf,"%d:",lb); 15612549Scsvaf } 15712549Scsvaf *pbuf += strlen(*pbuf); 15812549Scsvaf 15912549Scsvaf if(r->symvalue.rangev.uppertype == R_ARG or 16012549Scsvaf r->symvalue.rangev.uppertype == R_TEMP) { 16112549Scsvaf if( ! getbound(st,r->symvalue.rangev.upper, 16212549Scsvaf r->symvalue.rangev.uppertype, &ub) ) 16312549Scsvaf sprintf(*pbuf,"?,"); 16412549Scsvaf else 16512549Scsvaf sprintf(*pbuf,"%d,",ub); 16612549Scsvaf } 16712549Scsvaf else { 16812549Scsvaf ub = r->symvalue.rangev.upper; 16912549Scsvaf sprintf(*pbuf,"%d,",ub); 17012549Scsvaf } 17112549Scsvaf *pbuf += strlen(*pbuf); 17212549Scsvaf 17312549Scsvaf } 17412549Scsvaf } 17512549Scsvaf 17612549Scsvaf /* 17712549Scsvaf * Print out the declaration of a FORTRAN variable. 17812549Scsvaf */ 17912549Scsvaf 18012549Scsvaf public fortran_printdecl(s) 18112549Scsvaf Symbol s; 18212549Scsvaf { 18333317Sdonn Symbol eltype; 18412549Scsvaf 18512549Scsvaf switch (s->class) { 18612549Scsvaf case CONST: 18712549Scsvaf printf("parameter %s = ", symname(s)); 18825810Sdonn eval(s->symvalue.constval); 18912549Scsvaf printval(s); 19012549Scsvaf break; 19112549Scsvaf 19212549Scsvaf case REF: 19312549Scsvaf printf(" (dummy argument) "); 19416610Ssam 19514652Slinton case VAR: 19616610Ssam if (s->type->class == ARRAY && 19716610Ssam (not istypename(s->type->type,"char")) ) { 19816610Ssam char bounds[130], *p1, **p; 19912549Scsvaf p1 = bounds; 20012549Scsvaf p = &p1; 20116610Ssam mksubs(p,s->type); 20212549Scsvaf *p -= 1; 20312549Scsvaf **p = '\0'; /* get rid of trailing ',' */ 20416610Ssam printf(" %s %s[%s] ",typename(s), symname(s), bounds); 20512549Scsvaf } else { 20612549Scsvaf printf("%s %s", typename(s), symname(s)); 20712549Scsvaf } 20812549Scsvaf break; 20912549Scsvaf 21012549Scsvaf case FUNC: 21112627Scsvaf if (not istypename(s->type, "void")) { 21212549Scsvaf printf(" %s function ", typename(s) ); 21312549Scsvaf } 21416610Ssam else printf(" subroutine"); 21512549Scsvaf printf(" %s ", symname(s)); 21612549Scsvaf fortran_listparams(s); 21712549Scsvaf break; 21812549Scsvaf 21912549Scsvaf case MODULE: 22016610Ssam printf("source file \"%s.c\"", symname(s)); 22112549Scsvaf break; 22212549Scsvaf 22312549Scsvaf case PROG: 22412549Scsvaf printf("executable file \"%s\"", symname(s)); 22512549Scsvaf break; 22612549Scsvaf 22712549Scsvaf default: 22812549Scsvaf error("class %s in fortran_printdecl", classname(s)); 22912549Scsvaf } 23012549Scsvaf putchar('\n'); 23112549Scsvaf } 23212549Scsvaf 23312549Scsvaf /* 23412549Scsvaf * List the parameters of a procedure or function. 23512549Scsvaf * No attempt is made to combine like types. 23612549Scsvaf */ 23712549Scsvaf 23812549Scsvaf public fortran_listparams(s) 23912549Scsvaf Symbol s; 24012549Scsvaf { 24112549Scsvaf register Symbol t; 24212549Scsvaf 24312549Scsvaf putchar('('); 24412549Scsvaf for (t = s->chain; t != nil; t = t->chain) { 24512549Scsvaf printf("%s", symname(t)); 24612549Scsvaf if (t->chain != nil) { 24712549Scsvaf printf(", "); 24812549Scsvaf } 24912549Scsvaf } 25012549Scsvaf putchar(')'); 25112549Scsvaf if (s->chain != nil) { 25212549Scsvaf printf("\n"); 25312549Scsvaf for (t = s->chain; t != nil; t = t->chain) { 25412549Scsvaf if (t->class != REF) { 25512549Scsvaf panic("unexpected class %d for parameter", t->class); 25612549Scsvaf } 25712549Scsvaf printdecl(t, 0); 25812549Scsvaf } 25912549Scsvaf } else { 26012549Scsvaf putchar('\n'); 26112549Scsvaf } 26212549Scsvaf } 26312549Scsvaf 26412549Scsvaf /* 26512549Scsvaf * Print out the value on the top of the expression stack 26612549Scsvaf * in the format for the type of the given symbol. 26712549Scsvaf */ 26812549Scsvaf 26912549Scsvaf public fortran_printval(s) 27012549Scsvaf Symbol s; 27112549Scsvaf { 27212549Scsvaf register Symbol t; 27312549Scsvaf register Address a; 27412549Scsvaf register int i, len; 27518219Slinton double d1, d2; 27612549Scsvaf 27712549Scsvaf switch (s->class) { 27812549Scsvaf case CONST: 27912549Scsvaf case TYPE: 28012549Scsvaf case VAR: 28112549Scsvaf case REF: 28212549Scsvaf case FVAR: 28312549Scsvaf case TAG: 28412549Scsvaf fortran_printval(s->type); 28512549Scsvaf break; 28612549Scsvaf 28712549Scsvaf case ARRAY: 28812549Scsvaf t = rtype(s->type); 28912549Scsvaf if (t->class == RANGE and istypename(t->type, "char")) { 29012549Scsvaf len = size(s); 29112549Scsvaf sp -= len; 29212549Scsvaf printf("\"%.*s\"", len, sp); 29312549Scsvaf } else { 29412549Scsvaf fortran_printarray(s); 29512549Scsvaf } 29612549Scsvaf break; 29712549Scsvaf 29812549Scsvaf case RANGE: 29933317Sdonn if (isspecial(s)) { 30012549Scsvaf switch (s->symvalue.rangev.lower) { 30125810Sdonn case sizeof(short): 30225810Sdonn if (istypename(s->type, "logical*2")) { 30325810Sdonn printlogical(pop(short)); 30425810Sdonn } 30525810Sdonn break; 30625810Sdonn 30712549Scsvaf case sizeof(float): 30825810Sdonn if (istypename(s->type, "logical")) { 30925810Sdonn printlogical(pop(long)); 31025810Sdonn } else { 31125810Sdonn prtreal(pop(float)); 31225810Sdonn } 31312549Scsvaf break; 31412549Scsvaf 31512549Scsvaf case sizeof(double): 31633317Sdonn if (istypename(s->type,"complex")) { 31718219Slinton d2 = pop(float); 31818219Slinton d1 = pop(float); 31918219Slinton printf("("); 32018219Slinton prtreal(d1); 32118219Slinton printf(","); 32218219Slinton prtreal(d2); 32318219Slinton printf(")"); 32418219Slinton } else { 32518219Slinton prtreal(pop(double)); 32612549Scsvaf } 32712549Scsvaf break; 32812549Scsvaf 32924553Smckusick case 2*sizeof(double): 33024553Smckusick d2 = pop(double); 33124553Smckusick d1 = pop(double); 33224553Smckusick printf("("); 33324553Smckusick prtreal(d1); 33424553Smckusick printf(","); 33524553Smckusick prtreal(d2); 33624553Smckusick printf(")"); 33724553Smckusick break; 33833317Sdonn 33912549Scsvaf default: 34025810Sdonn panic("bad size \"%d\" for special", 34124553Smckusick s->symvalue.rangev.lower); 34212549Scsvaf break; 34312549Scsvaf } 34412549Scsvaf } else { 34512549Scsvaf printint(popsmall(s), s); 34612549Scsvaf } 34712549Scsvaf break; 34812549Scsvaf 34912549Scsvaf default: 35012549Scsvaf if (ord(s->class) > ord(TYPEREF)) { 35112549Scsvaf panic("printval: bad class %d", ord(s->class)); 35212549Scsvaf } 35312549Scsvaf error("don't know how to print a %s", fortran_classname(s)); 35412549Scsvaf /* NOTREACHED */ 35512549Scsvaf } 35612549Scsvaf } 35712549Scsvaf 35812549Scsvaf /* 35925810Sdonn * Print out a logical 36025810Sdonn */ 36125810Sdonn 36233317Sdonn private printlogical (i) 36333317Sdonn integer i; 36425810Sdonn { 36525810Sdonn if (i == 0) { 36625810Sdonn printf(".false."); 36725810Sdonn } else { 36825810Sdonn printf(".true."); 36925810Sdonn } 37025810Sdonn } 37125810Sdonn 37225810Sdonn /* 37312549Scsvaf * Print out an int 37412549Scsvaf */ 37512549Scsvaf 37612549Scsvaf private printint(i, t) 37712549Scsvaf Integer i; 37812549Scsvaf register Symbol t; 37912549Scsvaf { 38033317Sdonn if (t->type == t_int or istypename(t->type, "integer") or 38133317Sdonn istypename(t->type,"integer*2") 38233317Sdonn ) { 38312549Scsvaf printf("%ld", i); 38425810Sdonn } else if (istypename(t->type, "addr")) { 38525810Sdonn printf("0x%lx", i); 38612549Scsvaf } else { 38725810Sdonn error("unknown type in fortran printint"); 38812549Scsvaf } 38912549Scsvaf } 39012549Scsvaf 39112549Scsvaf /* 39212549Scsvaf * Print out a null-terminated string (pointer to char) 39312549Scsvaf * starting at the given address. 39412549Scsvaf */ 39512549Scsvaf 39612549Scsvaf private printstring(addr) 39712549Scsvaf Address addr; 39812549Scsvaf { 39912549Scsvaf register Address a; 40012549Scsvaf register Integer i, len; 40112549Scsvaf register Boolean endofstring; 40212549Scsvaf union { 40312549Scsvaf char ch[sizeof(Word)]; 40412549Scsvaf int word; 40512549Scsvaf } u; 40612549Scsvaf 40712549Scsvaf putchar('"'); 40812549Scsvaf a = addr; 40912549Scsvaf endofstring = false; 41012549Scsvaf while (not endofstring) { 41112549Scsvaf dread(&u, a, sizeof(u)); 41212549Scsvaf i = 0; 41312549Scsvaf do { 41412549Scsvaf if (u.ch[i] == '\0') { 41512549Scsvaf endofstring = true; 41612549Scsvaf } else { 41712549Scsvaf printchar(u.ch[i]); 41812549Scsvaf } 41912549Scsvaf ++i; 42012549Scsvaf } while (i < sizeof(Word) and not endofstring); 42112549Scsvaf a += sizeof(Word); 42212549Scsvaf } 42312549Scsvaf putchar('"'); 42412549Scsvaf } 42512549Scsvaf /* 42612549Scsvaf * Return the FORTRAN name for the particular class of a symbol. 42712549Scsvaf */ 42812549Scsvaf 42912549Scsvaf public String fortran_classname(s) 43012549Scsvaf Symbol s; 43112549Scsvaf { 43212549Scsvaf String str; 43312549Scsvaf 43412549Scsvaf switch (s->class) { 43512549Scsvaf case REF: 43612549Scsvaf str = "dummy argument"; 43712549Scsvaf break; 43812549Scsvaf 43912549Scsvaf case CONST: 44012549Scsvaf str = "parameter"; 44112549Scsvaf break; 44212549Scsvaf 44312549Scsvaf default: 44412549Scsvaf str = classname(s); 44512549Scsvaf } 44612549Scsvaf return str; 44712549Scsvaf } 44812549Scsvaf 44912549Scsvaf /* reverses the indices from the expr_list; should be folded into buildaref 45012549Scsvaf * and done as one recursive routine 45112549Scsvaf */ 45212549Scsvaf Node private rev_index(here,n) 45312549Scsvaf register Node here,n; 45412549Scsvaf { 45512549Scsvaf 45612549Scsvaf register Node i; 45712549Scsvaf 45812549Scsvaf if( here == nil or here == n) i=nil; 45912549Scsvaf else if( here->value.arg[1] == n) i = here; 46012549Scsvaf else i=rev_index(here->value.arg[1],n); 46112549Scsvaf return i; 46212549Scsvaf } 46312549Scsvaf 46412549Scsvaf public Node fortran_buildaref(a, slist) 46512549Scsvaf Node a, slist; 46612549Scsvaf { 46712549Scsvaf register Symbol as; /* array of array of .. cursor */ 46812549Scsvaf register Node en; /* Expr list cursor */ 46912549Scsvaf Symbol etype; /* Type of subscript expr */ 47012549Scsvaf Node esub, tree; /* Subscript expression ptr and tree to be built*/ 47112549Scsvaf 47212549Scsvaf tree=a; 47312549Scsvaf 47412549Scsvaf as = rtype(tree->nodetype); /* node->sym.type->array*/ 47512549Scsvaf if ( not ( 47612549Scsvaf (tree->nodetype->class == VAR or tree->nodetype->class == REF) 47712549Scsvaf and as->class == ARRAY 47812549Scsvaf ) ) { 47912549Scsvaf beginerrmsg(); 48012549Scsvaf prtree(stderr, a); 48112549Scsvaf fprintf(stderr, " is not an array"); 48212549Scsvaf /*fprintf(stderr, " a-> %x as %x ", tree->nodetype, as ); OUT*/ 48312549Scsvaf enderrmsg(); 48412549Scsvaf } else { 48512549Scsvaf for (en = rev_index(slist,nil); en != nil and as->class == ARRAY; 48612549Scsvaf en = rev_index(slist,en), as = as->type) { 48712549Scsvaf esub = en->value.arg[0]; 48812549Scsvaf etype = rtype(esub->nodetype); 48912549Scsvaf assert(as->chain->class == RANGE); 49012549Scsvaf if ( not compatible( t_int, etype) ) { 49112549Scsvaf beginerrmsg(); 49212549Scsvaf fprintf(stderr, "subscript "); 49312549Scsvaf prtree(stderr, esub); 49412549Scsvaf fprintf(stderr, " is type %s ",symname(etype->type) ); 49512549Scsvaf enderrmsg(); 49612549Scsvaf } 49712549Scsvaf tree = build(O_INDEX, tree, esub); 49812549Scsvaf tree->nodetype = as->type; 49912549Scsvaf } 50012549Scsvaf if (en != nil or 50112549Scsvaf (as->class == ARRAY && (not istypename(as->type,"char"))) ) { 50212549Scsvaf beginerrmsg(); 50312549Scsvaf if (en != nil) { 50412549Scsvaf fprintf(stderr, "too many subscripts for "); 50512549Scsvaf } else { 50612549Scsvaf fprintf(stderr, "not enough subscripts for "); 50712549Scsvaf } 50812549Scsvaf prtree(stderr, tree); 50912549Scsvaf enderrmsg(); 51012549Scsvaf } 51112549Scsvaf } 51212549Scsvaf return tree; 51312549Scsvaf } 51412549Scsvaf 51512549Scsvaf /* 51612549Scsvaf * Evaluate a subscript index. 51712549Scsvaf */ 51812549Scsvaf 51918219Slinton public fortran_evalaref(s, base, i) 52012549Scsvaf Symbol s; 52118219Slinton Address base; 52212549Scsvaf long i; 52312549Scsvaf { 52418219Slinton Symbol r, t; 52512549Scsvaf long lb, ub; 52612549Scsvaf 52718219Slinton t = rtype(s); 52818219Slinton r = t->chain; 52918219Slinton if ( 53018219Slinton r->symvalue.rangev.lowertype == R_ARG or 53118219Slinton r->symvalue.rangev.lowertype == R_TEMP 53218219Slinton ) { 53318219Slinton if (not getbound( 53418219Slinton s, r->symvalue.rangev.lower, r->symvalue.rangev.lowertype, &lb 53518219Slinton )) { 53612549Scsvaf error("dynamic bounds not currently available"); 53718219Slinton } 53818219Slinton } else { 53918219Slinton lb = r->symvalue.rangev.lower; 54012549Scsvaf } 54118219Slinton if ( 54218219Slinton r->symvalue.rangev.uppertype == R_ARG or 54318219Slinton r->symvalue.rangev.uppertype == R_TEMP 54418219Slinton ) { 54518219Slinton if (not getbound( 54618219Slinton s, r->symvalue.rangev.upper, r->symvalue.rangev.uppertype, &ub 54718219Slinton )) { 54812549Scsvaf error("dynamic bounds not currently available"); 54918219Slinton } 55018219Slinton } else { 55118219Slinton ub = r->symvalue.rangev.upper; 55212549Scsvaf } 55312549Scsvaf 55412549Scsvaf if (i < lb or i > ub) { 55512549Scsvaf error("subscript out of range"); 55612549Scsvaf } 55718219Slinton push(long, base + (i - lb) * size(t->type)); 55812549Scsvaf } 55912549Scsvaf 56012549Scsvaf private fortran_printarray(a) 56112549Scsvaf Symbol a; 56212549Scsvaf { 56312549Scsvaf struct Bounds { int lb, val, ub} dim[MAXDIM]; 56412549Scsvaf 56512549Scsvaf Symbol sc,st,eltype; 56612549Scsvaf char buf[50]; 56712549Scsvaf char *subscr; 56812549Scsvaf int i,ndim,elsize; 56912549Scsvaf Stack *savesp; 57012549Scsvaf Boolean done; 57112549Scsvaf 57212549Scsvaf st = a; 57312549Scsvaf 57412549Scsvaf savesp = sp; 57512549Scsvaf sp -= size(a); 57612549Scsvaf ndim=0; 57712549Scsvaf 57812549Scsvaf for(;;){ 57912549Scsvaf sc = st->chain; 58012549Scsvaf if(sc->symvalue.rangev.lowertype == R_ARG or 58112549Scsvaf sc->symvalue.rangev.lowertype == R_TEMP) { 58212549Scsvaf if( ! getbound(a,sc->symvalue.rangev.lower, 58312627Scsvaf sc->symvalue.rangev.lowertype, &dim[ndim].lb) ) 58412549Scsvaf error(" dynamic bounds not currently available"); 58512549Scsvaf } 58612549Scsvaf else dim[ndim].lb = sc->symvalue.rangev.lower; 58712549Scsvaf 58812549Scsvaf if(sc->symvalue.rangev.uppertype == R_ARG or 58912549Scsvaf sc->symvalue.rangev.uppertype == R_TEMP) { 59012549Scsvaf if( ! getbound(a,sc->symvalue.rangev.upper, 59112549Scsvaf sc->symvalue.rangev.uppertype, &dim[ndim].ub) ) 59212549Scsvaf error(" dynamic bounds not currently available"); 59312549Scsvaf } 59412549Scsvaf else dim[ndim].ub = sc->symvalue.rangev.upper; 59512549Scsvaf 59612549Scsvaf ndim ++; 59712549Scsvaf if (st->type->class == ARRAY) st=st->type; 59812549Scsvaf else break; 59912549Scsvaf } 60012549Scsvaf 60112549Scsvaf if(istypename(st->type,"char")) { 60212549Scsvaf eltype = st; 60312549Scsvaf ndim--; 60412549Scsvaf } 60512549Scsvaf else eltype=st->type; 60612549Scsvaf elsize=size(eltype); 60712549Scsvaf sp += elsize; 60812549Scsvaf /*printf("ndim %d elsize %lx in fortran_printarray\n",ndim,elsize);OUT*/ 60912549Scsvaf 61012549Scsvaf ndim--; 61112549Scsvaf for (i=0;i<=ndim;i++){ 61212549Scsvaf dim[i].val=dim[i].lb; 61312549Scsvaf /*OUT printf(" %d %d %d \n",i,dim[i].lb,dim[i].ub); 61412549Scsvaf fflush(stdout); OUT*/ 61512549Scsvaf } 61612549Scsvaf 61712549Scsvaf 61812549Scsvaf for(;;) { 61912549Scsvaf buf[0]=','; 62012549Scsvaf subscr = buf+1; 62112549Scsvaf 62212549Scsvaf for (i=ndim-1;i>=0;i--) { 62312549Scsvaf 62412549Scsvaf sprintf(subscr,"%d,",dim[i].val); 62512549Scsvaf subscr += strlen(subscr); 62612549Scsvaf } 62712549Scsvaf *--subscr = '\0'; 62812549Scsvaf 62912549Scsvaf for(i=dim[ndim].lb;i<=dim[ndim].ub;i++) { 63012549Scsvaf printf("[%d%s]\t",i,buf); 63112549Scsvaf printval(eltype); 63212549Scsvaf printf("\n"); 63312549Scsvaf sp += 2*elsize; 63412549Scsvaf } 63512549Scsvaf dim[ndim].val=dim[ndim].ub; 63612549Scsvaf 63712549Scsvaf i=ndim-1; 63812549Scsvaf if (i<0) break; 63912549Scsvaf 64012549Scsvaf done=false; 64112549Scsvaf do { 64212549Scsvaf dim[i].val++; 64312549Scsvaf if(dim[i].val > dim[i].ub) { 64412549Scsvaf dim[i].val = dim[i].lb; 64512549Scsvaf if(--i<0) done=true; 64612549Scsvaf } 64712549Scsvaf else done=true; 64812549Scsvaf } 64912549Scsvaf while (not done); 65012549Scsvaf if (i<0) break; 65112549Scsvaf } 65212549Scsvaf } 65316610Ssam 65416610Ssam /* 65516610Ssam * Initialize typetable at beginning of a module. 65616610Ssam */ 65716610Ssam 65816610Ssam public fortran_modinit (typetable) 65916610Ssam Symbol typetable[]; 66016610Ssam { 66116610Ssam /* nothing for now */ 66216610Ssam } 66316610Ssam 66416610Ssam public boolean fortran_hasmodules () 66516610Ssam { 66616610Ssam return false; 66716610Ssam } 66816610Ssam 66916610Ssam public boolean fortran_passaddr (param, exprtype) 67016610Ssam Symbol param, exprtype; 67116610Ssam { 67216610Ssam return false; 67316610Ssam } 674