/****************************************************************
Copyright 1990, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
****************************************************************/
int oneof_stg (name
, stg
, mask
)
if (stg
== STGCOMMON
&& name
) {
if ((mask
& M(STGEQUIV
)))
if ((mask
& M(STGCOMMON
)))
return !name
->vcommequiv
;
/* op_assign -- given a binary opcode, return the associated assignment
case OPPLUS
: retval
= OPPLUSEQ
; break;
case OPMINUS
: retval
= OPMINUSEQ
; break;
case OPSTAR
: retval
= OPSTAREQ
; break;
case OPSLASH
: retval
= OPSLASHEQ
; break;
case OPMOD
: retval
= OPMODEQ
; break;
case OPLSHIFT
: retval
= OPLSHIFTEQ
; break;
case OPRSHIFT
: retval
= OPRSHIFTEQ
; break;
case OPBITAND
: retval
= OPBITANDEQ
; break;
case OPBITXOR
: retval
= OPBITXOREQ
; break;
case OPBITOR
: retval
= OPBITOREQ
; break;
erri ("op_assign: bad opcode '%d'", opcode
);
Alloc(n
) /* error-checking version of malloc */
/* ckalloc initializes memory to 0; Alloc does not */
sprintf(errbuf
, "malloc(%d) failure!", n
);
cmpstr(a
, b
, la
, lb
) /* compare two strings */
register char *aend
, *bend
;
/* hookup -- Same as LISP NCONC, that is a destructive append of two lists */
for(p
= x
; p
->nextp
; p
= p
->nextp
)
struct Listblock
*mklist(p
)
register struct Listblock
*q
;
register chainp p
, prev
= 0;
/* addunder -- turn a cvarname into an external name */
/* The cvarname may already end in _ (to avoid C keywords); */
/* if not, it has room for appending an _. */
/* copyn -- return a new copy of the input Fortran-string */
p
= q
= (char *) Alloc(n
);
/* copys -- return a new copy of the input C-string */
return( copyn( strlen(s
)+1 , s
) );
/* convci -- Convert Fortran-string to integer; assumes that input is a
legal number, with no trailing blanks */
sum
= 10*sum
+ (*s
++ - '0');
/* convic - Convert Integer constant to string */
/* mkname -- add a new identifier to the environment, including the closed
if (!i
&& in_vector(s0
,c_keywords
,n_keywords
) >= 0)
/* Add the name to the closed hash table */
if( hash
== hp
->hashval
&& !strcmp(s0
,q
->fvarname
) )
else if(++hp
>= lasthash
)
if(++nintnames
>= maxhash
-1)
many("names", 'n', maxhash
); /* Fatal error */
hp
->varp
= q
= ALLOC(Nameblock
);
q
->tag
= TNAME
; /* TNAME means the tag type is NAME */
if (c
> 7 && noextflag
) {
sprintf(errbuf
, "\"%.35s%s\" over 6 characters long", s0
,
q
->fvarname
= strcpy(mem(c
,0), s0
);
t
= q
->cvarname
= mem(c
+ i
+ 1, 0);
/* add __ to the end of any name containing _ and to any C keyword */
struct Labelblock
*mklabel(l
)
register struct Labelblock
*lp
;
for(lp
= labeltab
; lp
< highlabtab
; ++lp
)
if(++highlabtab
> labtabend
)
many("statement labels", 's', maxstno
);
lp
->labelno
= newlabel();
lp
->labtype
= LABUNKNOWN
;
/* this label appears in a branch context */
struct Labelblock
*execlab(stateno
)
register struct Labelblock
*lp
;
if(lp
= mklabel(stateno
))
warn1("illegal branch to inner block, statement label %s",
else if(lp
->labdefined
== NO
)
if(lp
->labtype
== LABFORMAT
)
err("may not branch to a format");
execerr("illegal label %s", convic(stateno
));
/* find or put a name in the external symbol table */
for(p
= extsymtab
; p
<nextext
; ++p
)
if(!strcmp(s
,p
->cextname
))
many("external symbols", 'x', maxext
);
nextext
->fextname
= strcpy(gmem(strlen(f
)+1,0), f
);
nextext
->cextname
= f
== s
: strcpy(gmem(strlen(s
)+1,0), s
);
nextext
->extstg
= STGUNKNOWN
;
nextext
->curno
= nextext
->maxno
= 0;
extern chainp used_builtins
;
if(p
->extstg
== STGUNKNOWN
)
else if(p
->extstg
!= STGEXT
)
errstr("improper use of builtin %s", s
);
q
->memno
= p
- extsymtab
;
/* A NULL pointer here tells you to use memno to check the external
q
-> uname_tag
= UNAM_EXTERN
;
/* Add to the list of used builtins */
add_extern_to_list (q
, &used_builtins
);
add_extern_to_list (addr
, list_store
)
if (list_store
== (chainp
*) NULL
|| addr
== (Addrp
) NULL
)
for (;list
; last
= list
, list
= list
-> nextp
) {
Addrp
this = (Addrp
) (list
-> datap
);
if (this -> tag
== TADDR
&& this -> uname_tag
== UNAM_EXTERN
&&
if (*list_store
== CHNULL
)
*list_store
= mkchain((char *)cpexpr((expptr
)addr
), CHNULL
);
last
->nextp
= mkchain((char *)cpexpr((expptr
)addr
), CHNULL
);
} /* add_extern_to_list */
for(q
= *p
; q
->nextp
; q
= q
->nextp
)
frexpr((expptr
)q
->datap
);
memcpy((char *)(q
= ckalloc(n
)), (char *)p
, n
);
if(t
==TYCOMPLEX
&& (t1
==TYDREAL
|| t2
==TYDREAL
) )
/* return log base 2 of n if n a power of 2; otherwise -1 */
/* trick based on binary representation */
if(n
<=0 || (n
& (n
-1))!=0)
for(k
= 0 ; n
>>= 1 ; ++k
)
free( (charptr
) rpllist
);
/* Call a Fortran function with an arbitrary list of arguments */
expptr
callk(type
, name
, args
)
(expptr
)builtin(callk_kludge
? callk_kludge
: type
, name
, 0),
p
->exprblock
.vtype
= type
;
expptr
call4(type
, name
, arg1
, arg2
, arg3
, arg4
)
expptr arg1
, arg2
, arg3
, arg4
;
args
= mklist( mkchain((char *)arg1
,
mkchain((char *)arg4
, CHNULL
)) ) ) );
return( callk(type
, name
, (chainp
)args
) );
expptr
call3(type
, name
, arg1
, arg2
, arg3
)
args
= mklist( mkchain((char *)arg1
,
mkchain((char *)arg3
, CHNULL
) ) ) );
return( callk(type
, name
, (chainp
)args
) );
expptr
call2(type
, name
, arg1
, arg2
)
args
= mklist( mkchain((char *)arg1
, mkchain((char *)arg2
, CHNULL
) ) );
return( callk(type
,name
, (chainp
)args
) );
expptr
call1(type
, name
, arg
)
return( callk(type
,name
, (chainp
)mklist(mkchain((char *)arg
,CHNULL
)) ));
return( callk(type
, name
, CHNULL
) );
struct Impldoblock
*mkiodo(dospec
, list
)
register struct Impldoblock
*q
;
/* ckalloc -- Allocate 1 memory unit of size n, checking for out of
p
= (ptr
)calloc(1, (unsigned) n
);
fprintf(stderr
, "failing to get %d bytes\n",n
);
/* NOT REACHED */ return 0;
switch(p
->exprblock
.opcode
)
return( isaddr(p
->exprblock
.rightp
) );
return( isaddr(p
->exprblock
.leftp
) );
if(p
->headblock
.vleng
&& !ISCONST(p
->headblock
.vleng
))
if(ONEOF(p
->addrblock
.vstg
,MSKSTATIC
) &&
ISCONST(p
->addrblock
.memoffset
) && !useauto
)
/* addressable -- return True iff it is a constant value, or can be
referenced by constant values */
return( addressable(p
->addrblock
.memoffset
) );
/* isnegative_const -- returns true if the constant is negative. Returns
false for imaginary and nonnumeric constants */
int isnegative_const (cp
)
retval
= cp
-> Const
.ci
< 0;
retval
= cp
->vstg
? *cp
->Const
.cds
[0] == '-'
if (cp
== (struct Constblock
*) NULL
)
cp
-> Const
.ci
= - cp
-> Const
.ci
;
switch(*cp
->Const
.cds
[1]) {
cp
->Const
.cd
[1] = -cp
->Const
.cd
[1];
switch(*cp
->Const
.cds
[0]) {
cp
->Const
.cd
[0] = -cp
->Const
.cd
[0];
erri ("negate_const: can't negate type '%d'", cp
-> vtype
);
erri ("negate_const: bad type '%d'",
register c
= getc (infp
);
/* in_vector -- verifies whether str is in c_keywords.
If so, the index is returned else -1 is returned.
c_keywords must be in alphabetical order (as defined by strcmp).
int in_vector(str
, keywds
, n
)
char *str
; char **keywds
; register int n
;
register char **K
= keywds
;
if (!(t
= strcmp(str
, K
[n1
])))
if (Const
!= (Constp
) NULL
)
switch (Const
-> vtype
) {
retval
= Const
-> Const
.ci
>= -BIGGEST_CHAR
;
retval
= Const
-> Const
.ci
>= -BIGGEST_SHORT
;
retval
= Const
-> Const
.ci
>= -BIGGEST_LONG
;
static char couldnt
[] = "Couldn't open %.80s";
if (!(f
= fopen(fname
, binread
))) {
if (!(b
= fopen(bname
, binwrite
))) {
/* struct_eq -- returns YES if structures have the same field names and
struct Dimblock
*d1
, *d2
;
if (s1
== CHNULL
&& s2
== CHNULL
)
for(; s1
&& s2
; s1
= s1
->nextp
, s2
= s2
->nextp
) {
register Namep v1
= (Namep
) s1
-> datap
;
register Namep v2
= (Namep
) s2
-> datap
;
if (v1
== (Namep
) NULL
|| v1
-> tag
!= TNAME
||
v2
== (Namep
) NULL
|| v2
-> tag
!= TNAME
)
if (v1
->vtype
!= v2
->vtype
|| v1
->vclass
!= v2
->vclass
|| strcmp(v1
->fvarname
, v2
->fvarname
))
/* compare dimensions (needed for comparing COMMON blocks) */
if (!(cp1
= (Constp
)d1
->nelt
) || cp1
->tag
!= TCONST
)
if (!(cp2
= (Constp
)d2
->nelt
) || cp2
->tag
!= TCONST
|| cp1
->Const
.ci
!= cp2
->Const
.ci
)
else if ((d2
= v2
->vdim
) && (!(cp2
= (Constp
)d2
->nelt
)
} /* while s1 != CHNULL && s2 != CHNULL */
return s1
== CHNULL
&& s2
== CHNULL
;