[unix-history] / usr / src / old / dbx / fortran.c

/*
 * Copyright (c) 1983 Regents of the University of California.
 * All rights reserved.  The Berkeley software License Agreement
 * specifies the terms and conditions for redistribution.
 */

#ifndef lint
static char sccsid[] = "@(#)fortran.c	5.2 (Berkeley) %G%";
#endif not lint

static char rcsid[] = "$Header: fortran.c,v 1.5 84/12/26 10:39:37 linton Exp $";

/*
 * FORTRAN dependent symbol routines.
 */

#include "defs.h"
#include "symbols.h"
#include "printsym.h"
#include "languages.h"
#include "fortran.h"
#include "tree.h"
#include "eval.h"
#include "operators.h"
#include "mappings.h"
#include "process.h"
#include "runtime.h"
#include "machine.h"

#define isfloat(range) ( \
    range->symvalue.rangev.upper == 0 and range->symvalue.rangev.lower > 0 \
)

#define isrange(t, name) (t->class == RANGE and istypename(t->type, name))

#define MAXDIM  20

private Language fort;

/*
 * Initialize FORTRAN language information.
 */

public fortran_init()
{
    fort = language_define("fortran", ".f");
    language_setop(fort, L_PRINTDECL, fortran_printdecl);
    language_setop(fort, L_PRINTVAL, fortran_printval);
    language_setop(fort, L_TYPEMATCH, fortran_typematch);
    language_setop(fort, L_BUILDAREF, fortran_buildaref);
    language_setop(fort, L_EVALAREF, fortran_evalaref);
    language_setop(fort, L_MODINIT, fortran_modinit);
    language_setop(fort, L_HASMODULES, fortran_hasmodules);
    language_setop(fort, L_PASSADDR, fortran_passaddr);
}

/*
 * Test if two types are compatible.
 *
 * Integers and reals are not compatible since they cannot always be mixed.
 */

public Boolean fortran_typematch(type1, type2)
Symbol type1, type2;
{

/* only does integer for now; may need to add others
*/

    Boolean b;
    register Symbol t1, t2, tmp;

    t1 = rtype(type1);
    t2 = rtype(type2);
    if(t1 == nil or t1->type == nil or t2 == nil or t2->type == nil ) b = false;
    else { b = (Boolean)   (
            (t1 == t2)  or 
	    (t1->type == t_int and (istypename(t2->type, "integer") or
                                    istypename(t2->type, "integer*2"))  ) or
	    (t2->type == t_int and (istypename(t1->type, "integer") or
                                    istypename(t1->type, "integer*2"))  ) 
                    );
         }
    /*OUT fprintf(stderr," %d compat %s %s \n", b,
      (t1 == nil or t1->type == nil ) ? "nil" : symname(t1->type),
      (t2 == nil or t2->type == nil ) ? "nil" : symname(t2->type)  );*/
    return b;
}

private String typename(s)
Symbol s;
{
int ub;
static char buf[20];
char *pbuf;
Symbol st,sc;

     if(s->type->class == TYPE) return(symname(s->type));

     for(st = s->type; st->type->class != TYPE; st = st->type);

     pbuf=buf;

     if(istypename(st->type,"char"))  { 
	  sprintf(pbuf,"character*");
          pbuf += strlen(pbuf);
	  sc = st->chain;
          if(sc->symvalue.rangev.uppertype == R_ARG or
             sc->symvalue.rangev.uppertype == R_TEMP) {
	      if( ! getbound(s,sc->symvalue.rangev.upper, 
                    sc->symvalue.rangev.uppertype, &ub) )
		sprintf(pbuf,"(*)");
	      else 
		sprintf(pbuf,"%d",ub);
          }
 	  else sprintf(pbuf,"%d",sc->symvalue.rangev.upper);
     }
     else {
          sprintf(pbuf,"%s ",symname(st->type));
     }
     return(buf);
}

private Symbol mksubs(pbuf,st)
Symbol st;
char  **pbuf;
{   
   int lb, ub;
   Symbol r, eltype;

   if(st->class != ARRAY or (istypename(st->type, "char")) ) return;
   else {
          mksubs(pbuf,st->type);
          assert( (r = st->chain)->class == RANGE);

          if(r->symvalue.rangev.lowertype == R_ARG or
             r->symvalue.rangev.lowertype == R_TEMP) {
	      if( ! getbound(st,r->symvalue.rangev.lower, 
                    r->symvalue.rangev.lowertype, &lb) )
		sprintf(*pbuf,"?:");
	      else 
		sprintf(*pbuf,"%d:",lb);
	  }
          else {
		lb = r->symvalue.rangev.lower;
		sprintf(*pbuf,"%d:",lb);
		}
    	  *pbuf += strlen(*pbuf);

          if(r->symvalue.rangev.uppertype == R_ARG or
             r->symvalue.rangev.uppertype == R_TEMP) {
	      if( ! getbound(st,r->symvalue.rangev.upper, 
                    r->symvalue.rangev.uppertype, &ub) )
		sprintf(*pbuf,"?,");
	      else 
		sprintf(*pbuf,"%d,",ub);
	  }
          else {
		ub = r->symvalue.rangev.upper;
		sprintf(*pbuf,"%d,",ub);
		}
    	  *pbuf += strlen(*pbuf);

       }
}

/*
 * Print out the declaration of a FORTRAN variable.
 */

public fortran_printdecl(s)
Symbol s;
{


Symbol eltype;

    switch (s->class) {

	case CONST:
	    
	    printf("parameter %s = ", symname(s));
            printval(s);
	    break;

        case REF:
            printf(" (dummy argument) ");

	case VAR:
	    if (s->type->class == ARRAY &&
		 (not istypename(s->type->type,"char")) ) {
                char bounds[130], *p1, **p;
		p1 = bounds;
                p = &p1;
                mksubs(p,s->type);
                *p -= 1; 
                **p = '\0';   /* get rid of trailing ',' */
		printf(" %s %s[%s] ",typename(s), symname(s), bounds);
	    } else {
		printf("%s %s", typename(s), symname(s));
	    }
	    break;

	case FUNC:
	    if (not istypename(s->type, "void")) {
                printf(" %s function ", typename(s) );
	    }
	    else printf(" subroutine");
	    printf(" %s ", symname(s));
	    fortran_listparams(s);
	    break;

	case MODULE:
	    printf("source file \"%s.c\"", symname(s));
	    break;

	case PROG:
	    printf("executable file \"%s\"", symname(s));
	    break;

	default:
	    error("class %s in fortran_printdecl", classname(s));
    }
    putchar('\n');
}

/*
 * List the parameters of a procedure or function.
 * No attempt is made to combine like types.
 */

public fortran_listparams(s)
Symbol s;
{
    register Symbol t;

    putchar('(');
    for (t = s->chain; t != nil; t = t->chain) {
	printf("%s", symname(t));
	if (t->chain != nil) {
	    printf(", ");
	}
    }
    putchar(')');
    if (s->chain != nil) {
	printf("\n");
	for (t = s->chain; t != nil; t = t->chain) {
	    if (t->class != REF) {
		panic("unexpected class %d for parameter", t->class);
	    }
	    printdecl(t, 0);
	}
    } else {
	putchar('\n');
    }
}

/*
 * Print out the value on the top of the expression stack
 * in the format for the type of the given symbol.
 */

public fortran_printval(s)
Symbol s;
{
    register Symbol t;
    register Address a;
    register int i, len;
    double d1, d2;

    switch (s->class) {
	case CONST:
	case TYPE:
	case VAR:
	case REF:
	case FVAR:
	case TAG:
	    fortran_printval(s->type);
	    break;

	case ARRAY:
	    t = rtype(s->type);
	    if (t->class == RANGE and istypename(t->type, "char")) {
		len = size(s);
		sp -= len;
		printf("\"%.*s\"", len, sp);
	    } else {
		fortran_printarray(s);
	    }
	    break;

	case RANGE:
	     if (isfloat(s)) {
		switch (s->symvalue.rangev.lower) {
		    case sizeof(float):
			prtreal(pop(float));
			break;

		    case sizeof(double):
			if (istypename(s->type,"complex")) {
			    d2 = pop(float);
			    d1 = pop(float);
			    printf("(");
			    prtreal(d1);
			    printf(",");
			    prtreal(d2);
			    printf(")");
			} else {
			    prtreal(pop(double));
			}
			break;

		    case 2*sizeof(double):
			d2 = pop(double);
			d1 = pop(double);
			printf("(");
			prtreal(d1);
			printf(",");
			prtreal(d2);
			printf(")");
			break;
		
		    default:
			panic("bad size \"%d\" for real",
                                  s->symvalue.rangev.lower);
			break;
		}
	    } else {
		printint(popsmall(s), s);
	    }
	    break;

	default:
	    if (ord(s->class) > ord(TYPEREF)) {
		panic("printval: bad class %d", ord(s->class));
	    }
	    error("don't know how to print a %s", fortran_classname(s));
	    /* NOTREACHED */
    }
}

/*
 * Print out an int 
 */

private printint(i, t)
Integer i;
register Symbol t;
{
    if (istypename(t->type, "logical")) {
	printf(((Boolean) i) == true ? "true" : "false");
    }
    else if ( (t->type == t_int) or istypename(t->type, "integer") or
                  istypename(t->type,"integer*2") ) {
	printf("%ld", i);
    } else {
      error("unkown type in fortran printint");
    }
}

/*
 * Print out a null-terminated string (pointer to char)
 * starting at the given address.
 */

private printstring(addr)
Address addr;
{
    register Address a;
    register Integer i, len;
    register Boolean endofstring;
    union {
	char ch[sizeof(Word)];
	int word;
    } u;

    putchar('"');
    a = addr;
    endofstring = false;
    while (not endofstring) {
	dread(&u, a, sizeof(u));
	i = 0;
	do {
	    if (u.ch[i] == '\0') {
		endofstring = true;
	    } else {
		printchar(u.ch[i]);
	    }
	    ++i;
	} while (i < sizeof(Word) and not endofstring);
	a += sizeof(Word);
    }
    putchar('"');
}
/*
 * Return the FORTRAN name for the particular class of a symbol.
 */

public String fortran_classname(s)
Symbol s;
{
    String str;

    switch (s->class) {
	case REF:
	    str = "dummy argument";
	    break;

	case CONST:
	    str = "parameter";
	    break;

	default:
	    str = classname(s);
    }
    return str;
}

/* reverses the indices from the expr_list; should be folded into buildaref
 * and done as one recursive routine
 */
Node private rev_index(here,n)
register Node here,n;
{
 
  register Node i;

  if( here == nil  or  here == n) i=nil;
  else if( here->value.arg[1] == n) i = here;
  else i=rev_index(here->value.arg[1],n);
  return i;
}

public Node fortran_buildaref(a, slist)
Node a, slist;
{
    register Symbol as;      /* array of array of .. cursor */
    register Node en;        /* Expr list cursor */
    Symbol etype;            /* Type of subscript expr */
    Node esub, tree;         /* Subscript expression ptr and tree to be built*/

    tree=a;

    as = rtype(tree->nodetype);     /* node->sym.type->array*/
    if ( not (
               (tree->nodetype->class == VAR or tree->nodetype->class == REF)
                and as->class == ARRAY
             ) ) {
	beginerrmsg();
	prtree(stderr, a);
	fprintf(stderr, " is not an array");
	/*fprintf(stderr, " a-> %x as %x ", tree->nodetype, as ); OUT*/
	enderrmsg();
    } else {
	for (en = rev_index(slist,nil); en != nil and as->class == ARRAY;
                     en = rev_index(slist,en), as = as->type) {
	    esub = en->value.arg[0];
	    etype = rtype(esub->nodetype);
            assert(as->chain->class == RANGE);
	    if ( not compatible( t_int, etype) ) {
		beginerrmsg();
		fprintf(stderr, "subscript ");
		prtree(stderr, esub);
		fprintf(stderr, " is type %s ",symname(etype->type) );
		enderrmsg();
	    }
	    tree = build(O_INDEX, tree, esub);
	    tree->nodetype = as->type;
	}
	if (en != nil or
             (as->class == ARRAY && (not istypename(as->type,"char"))) ) {
	    beginerrmsg();
	    if (en != nil) {
		fprintf(stderr, "too many subscripts for ");
	    } else {
		fprintf(stderr, "not enough subscripts for ");
	    }
	    prtree(stderr, tree);
	    enderrmsg();
	}
    }
    return tree;
}

/*
 * Evaluate a subscript index.
 */

public fortran_evalaref(s, base, i)
Symbol s;
Address base;
long i;
{
    Symbol r, t;
    long lb, ub;

    t = rtype(s);
    r = t->chain;
    if (
	r->symvalue.rangev.lowertype == R_ARG or
        r->symvalue.rangev.lowertype == R_TEMP
    ) {
	if (not getbound(
	    s, r->symvalue.rangev.lower, r->symvalue.rangev.lowertype, &lb
	)) {
          error("dynamic bounds not currently available");
	}
    } else {
	lb = r->symvalue.rangev.lower;
    }
    if (
	r->symvalue.rangev.uppertype == R_ARG or
        r->symvalue.rangev.uppertype == R_TEMP
    ) {
	if (not getbound(
	    s, r->symvalue.rangev.upper, r->symvalue.rangev.uppertype, &ub
	)) {
          error("dynamic bounds not currently available");
	}
    } else {
	ub = r->symvalue.rangev.upper;
    }

    if (i < lb or i > ub) {
	error("subscript out of range");
    }
    push(long, base + (i - lb) * size(t->type));
}

private fortran_printarray(a)
Symbol a;
{
struct Bounds { int lb, val, ub} dim[MAXDIM];

Symbol sc,st,eltype;
char buf[50];
char *subscr;
int i,ndim,elsize;
Stack *savesp;
Boolean done;

st = a;

savesp = sp;
sp -= size(a);
ndim=0;

for(;;){
          sc = st->chain;
          if(sc->symvalue.rangev.lowertype == R_ARG or
             sc->symvalue.rangev.lowertype == R_TEMP) {
	      if( ! getbound(a,sc->symvalue.rangev.lower, 
                    sc->symvalue.rangev.lowertype, &dim[ndim].lb) )
		error(" dynamic bounds not currently available");
	  }
	  else dim[ndim].lb = sc->symvalue.rangev.lower;

          if(sc->symvalue.rangev.uppertype == R_ARG or
             sc->symvalue.rangev.uppertype == R_TEMP) {
	      if( ! getbound(a,sc->symvalue.rangev.upper, 
                    sc->symvalue.rangev.uppertype, &dim[ndim].ub) )
		error(" dynamic bounds not currently available");
	  }
	  else dim[ndim].ub = sc->symvalue.rangev.upper;

          ndim ++;
          if (st->type->class == ARRAY) st=st->type;
	  else break;
     }

if(istypename(st->type,"char")) {
		eltype = st;
		ndim--;
	}
else eltype=st->type;
elsize=size(eltype);
sp += elsize;
 /*printf("ndim %d elsize %lx in fortran_printarray\n",ndim,elsize);OUT*/

ndim--;
for (i=0;i<=ndim;i++){
	  dim[i].val=dim[i].lb;
	  /*OUT printf(" %d %d %d \n",i,dim[i].lb,dim[i].ub);
	    fflush(stdout); OUT*/
}


for(;;) {
	buf[0]=',';
	subscr = buf+1;

	for (i=ndim-1;i>=0;i--)  {

		sprintf(subscr,"%d,",dim[i].val);
        	subscr += strlen(subscr);
	}
        *--subscr = '\0';

	for(i=dim[ndim].lb;i<=dim[ndim].ub;i++) {
	      	printf("[%d%s]\t",i,buf);
		printval(eltype);
	      	printf("\n");
		sp += 2*elsize;
	}
        dim[ndim].val=dim[ndim].ub;

        i=ndim-1;
        if (i<0) break;

        done=false;
        do {
		dim[i].val++;
		if(dim[i].val > dim[i].ub) { 
			dim[i].val = dim[i].lb;
			if(--i<0) done=true;
		}
		else done=true;
         }
	 while (not done);
         if (i<0) break;
     }
}

/*
 * Initialize typetable at beginning of a module.
 */

public fortran_modinit (typetable)
Symbol typetable[];
{
    /* nothing for now */
}

public boolean fortran_hasmodules ()
{
    return false;
}

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