fortran.c

<B>Digital的Unix操作系统VAX 4.2源码</B>

			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;

/* jlr005
 * 8 byte value.  Could be a double complex (2 doubles) or an H-float.
 * Check the type name to find out for sure.
 */
		    case 2*sizeof(double):
			if (istypename(s->type,"double complex")) {
			    d2 = pop(double);
			    d1 = pop(double);
			    printf("(");
			    prtreal(d1);
			    printf(",");
			    prtreal(d2);
			    printf(")");
			} else {
			    prth(pop(struct hfloat));
			}
			break;
		
		    default:
			panic("bad size \"%d\" for real",
                                  s->symvalue.rangev.lower);
			break;
		}
	    } else {
		printint(popsmall(s), s);
	    }
	    break;

	case RECORD:
	    printrecord(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;
{
/* jlr005
 * Need to check for both f77 type name (logical) and fort type names
 * [unsigned (char,short,int)].  Also, since true==1 for f77 but 
 * true==all 1's for fort, check just the low-order bit to determine
 * the value.
 */
    if (istypename(t->type, "logical") or 
	istypename(t->type, "unsigned char") or 
	istypename(t->type, "unsigned short") or
	istypename(t->type, "unsigned int") ) {
	printf((Boolean) (i & 1) == true ? "true" : "false");
    }
/* jlr005
 * f77: integer or integer*2; fort: integer or short.
 */
    else if ( (t->type == t_int) or istypename(t->type, "integer") or
		  istypename(t->type,"integer*2") or 
		  istypename(t->type,"short") ) {
	printf("%ld", 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;
}

public Node fortran_printf(p, argv)
Node p;
char **argv;
{
	return p;
}