/* Copyright (c) 1982 Regents of the University of California */
static char sccsid
[] = "@(#)fortran.c 1.5 (Berkeley) %G%";
* FORTRAN dependent symbol routines.
#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))
* Initialize FORTRAN language information.
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
)
/* only does integer for now; may need to add others
register Symbol t1
, t2
, tmp
;
if(t1
== nil
or t1
->type
== nil
or t2
== nil
or t2
->type
== nil
) b
= false;
(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) );*/
private String
typename(s
)
if(s
->type
->class == TYPE
) return(symname(s
->type
));
for(st
= s
->type
; st
->type
->class != TYPE
; st
= st
->type
);
if(istypename(st
->type
,"char")) {
sprintf(pbuf
,"character*");
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
) )
else sprintf(pbuf
,"%d",sc
->symvalue
.rangev
.upper
);
sprintf(pbuf
,"%s ",symname(st
->type
));
private Symbol
mksubs(pbuf
,st
)
if(st
->class != ARRAY
or (istypename(st
->type
, "char")) ) return;
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
) )
lb
= r
->symvalue
.rangev
.lower
;
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
) )
ub
= r
->symvalue
.rangev
.upper
;
* Print out the declaration of a FORTRAN variable.
public fortran_printdecl(s
)
printf("parameter %s = ", symname(s
));
printf(" (dummy argument) ");
if (s
->type
->class == ARRAY
&&
(not istypename(s
->type
->type
,"char")) ) {
char bounds
[130], *p1
, **p
;
**p
= '\0'; /* get rid of trailing ',' */
printf(" %s %s[%s] ",typename(s
), symname(s
), bounds
);
printf("%s %s", typename(s
), symname(s
));
if (not istypename(s
->type
, "void")) {
printf(" %s function ", typename(s
) );
else printf(" subroutine");
printf(" %s ", symname(s
));
printf("source file \"%s.c\"", symname(s
));
printf("executable file \"%s\"", symname(s
));
error("class %s in fortran_printdecl", classname(s
));
* List the parameters of a procedure or function.
* No attempt is made to combine like types.
public fortran_listparams(s
)
for (t
= s
->chain
; t
!= nil
; t
= t
->chain
) {
printf("%s", symname(t
));
for (t
= s
->chain
; t
!= nil
; t
= t
->chain
) {
panic("unexpected class %d for parameter", t
->class);
* 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
)
/* printf("fortran_printval with class %s \n",classname(s)); OUT*/
fortran_printval(s
->type
);
if (t
->class == RANGE
and istypename(t
->type
, "char")) {
printf("\"%.*s\"", len
, sp
);
switch (s
->symvalue
.rangev
.lower
) {
if(istypename(s
->type
,"complex")) {
else prtreal(pop(double));
panic("bad size \"%d\" for real",
t
->symvalue
.rangev
.lower
);
printint(popsmall(s
), s
);
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
));
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") ) {
error("unkown type in fortran printint");
* Print out a null-terminated string (pointer to char)
* starting at the given address.
private printstring(addr
)
register Boolean endofstring
;
while (not endofstring
) {
} while (i
< sizeof(Word
) and not endofstring
);
* Return the FORTRAN name for the particular class of a symbol.
public String
fortran_classname(s
)
/* reverses the indices from the expr_list; should be folded into buildaref
* and done as one recursive routine
Node
private rev_index(here
,n
)
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
);
public Node
fortran_buildaref(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*/
as
= rtype(tree
->nodetype
); /* node->sym.type->array*/
(tree
->nodetype
->class == VAR
or tree
->nodetype
->class == REF
)
fprintf(stderr
, " is not an array");
/*fprintf(stderr, " a-> %x as %x ", tree->nodetype, as ); OUT*/
for (en
= rev_index(slist
,nil
); en
!= nil
and as
->class == ARRAY
;
en
= rev_index(slist
,en
), as
= as
->type
) {
etype
= rtype(esub
->nodetype
);
assert(as
->chain
->class == RANGE
);
if ( not compatible( t_int
, etype
) ) {
fprintf(stderr
, "subscript ");
fprintf(stderr
, " is type %s ",symname(etype
->type
) );
tree
= build(O_INDEX
, tree
, esub
);
tree
->nodetype
= as
->type
;
(as
->class == ARRAY
&& (not istypename(as
->type
,"char"))) ) {
fprintf(stderr
, "too many subscripts for ");
fprintf(stderr
, "not enough subscripts for ");
* Evaluate a subscript index.
public int fortran_evalaref(s
, i
)
if(r
->symvalue
.rangev
.lowertype
== R_ARG
or
r
->symvalue
.rangev
.lowertype
== R_TEMP
) {
if(! 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(! getbound(s
,r
->symvalue
.rangev
.upper
,
r
->symvalue
.rangev
.uppertype
,&ub
))
error("dynamic bounds not currently available");
else ub
= r
->symvalue
.rangev
.upper
;
error("subscript out of range");
private fortran_printarray(a
)
struct Bounds
{ int lb
, val
, ub
} dim
[MAXDIM
];
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
;
if (st
->type
->class == ARRAY
) st
=st
->type
;
if(istypename(st
->type
,"char")) {
/*printf("ndim %d elsize %lx in fortran_printarray\n",ndim,elsize);OUT*/
/*OUT printf(" %d %d %d \n",i,dim[i].lb,dim[i].ub);
for (i
=ndim
-1;i
>=0;i
--) {
sprintf(subscr
,"%d,",dim
[i
].val
);
subscr
+= strlen(subscr
);
for(i
=dim
[ndim
].lb
;i
<=dim
[ndim
].ub
;i
++) {
printf("[%d%s]\t",i
,buf
);
dim
[ndim
].val
=dim
[ndim
].ub
;
if(dim
[i
].val
> dim
[i
].ub
) {
* Initialize typetable at beginning of a module.
public fortran_modinit (typetable
)
public boolean
fortran_hasmodules ()
public boolean
fortran_passaddr (param
, exprtype
)