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

/*
 * Copyright (c) 1983 The Regents of the University of California.
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms are permitted
 * provided that: (1) source distributions retain this entire copyright
 * notice and comment, and (2) distributions including binaries display
 * the following acknowledgement:  ``This product includes software
 * developed by the University of California, Berkeley and its contributors''
 * in the documentation or other materials provided with the distribution
 * and in all advertising materials mentioning features or use of this
 * software. Neither the name of the University nor the names of its
 * contributors may be used to endorse or promote products derived
 * from this software without specific prior written permission.
 * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
 * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
 */

#ifndef lint
static char sccsid[] = "@(#)fortran.c	5.7 (Berkeley) 6/1/90";
#endif /* not lint */

/*
 * 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 isspecial(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));
	    eval(s->symvalue.constval);
            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 (isspecial(s)) {
		switch (s->symvalue.rangev.lower) {
		    case sizeof(short):
			if (istypename(s->type, "logical*2")) {
			    printlogical(pop(short));
			}
			break;

		    case sizeof(float):
			if (istypename(s->type, "logical")) {
			    printlogical(pop(long));
			} else {
			    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 special",
                                  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 a logical
 */

private printlogical (i)
integer i;
{
    if (i == 0) {
	printf(".false.");
    } else {
	printf(".true.");
    }
}

/*
 * Print out an int 
 */

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