/****************************************************************
Copyright 1990, 1991, 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
****************************************************************/
#define EXNULL (union Expression *)0
LOCAL
dobss(), docomleng(), docommon(), doentry(),
epicode(), nextarg(), retval();
static char Blank
[] = BLANKCOMMON
;
static char *postfix
[] = { "g", "h", "i",
"r", "d", "c", "z", "g", "h", "i" };
int prev_proc
, proc_argchanges
, proc_protochanges
;
e
= &extsymtab
[q
->vardesc
.varno
];
if (!(at
= e
->arginfo
)) {
else if (at
->changes
& 2 && qtype
!= TYUNKNOWN
&& !at
->defined
)
sprintf(buf
, "%.90s: inconsistent declarations:\n\
here %s%s, previously %s%s.", q
->fvarname
, ftn_types
[qtype
],
qtype
== TYSUBR
? "" : " function",
ftn_types
[type1
], type1
== TYSUBR
? "" : " function");
q
->uname_tag
= UNAM_IDENT
;
q
->uname_tag
= UNAM_CHARP
;
q
->user
.Charp
= t
= mem(k
+1, 0);
fix_entry_returns() /* for multiple entry points */
e
= entries
= (struct Entrypoint
*)revchain((chainp
)entries
);
allargs
= revchain(allargs
);
/* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
for(i
= TYINT1
; i
<= TYLOGICAL
; i
++)
sprintf(a
->user
.ident
, "(*ret_val).%s",
putentries(outfile
) /* put out wrappers for multiple entries */
Namep
*A
, *Ae
, *Ae1
, **Alp
, *a
, **a1
, np
;
chainp args
, lengths
, length_comp();
void listargs(), list_arg_types();
extern char *dfltarg
[], **dfltproc
;
if (!e
->enamep
) /* only possible with erroneous input */
nL
= (nallargs
+ nallchargs
) * sizeof(Namep
*);
A
= (Namep
*)ckalloc(nL
+ nallargs
*sizeof(Namep
**));
Alp
= (Namep
**)(Ae1
= Ae
+ nallchargs
);
for(a1
= Alp
, args
= allargs
; args
; a1
++, args
= args
->nextp
) {
if (np
->vtype
== TYCHAR
&& np
->vclass
!= CLPROC
)
sprintf(base
, "%s0_", e
->enamep
->cvarname
);
lengths
= length_comp(e
, 0);
proctype
= type
= np
->vtype
;
protowrite(protofile
, type
, np
->cvarname
, e
, lengths
);
nice_printf(outfile
, "\n%s ", c_type_decl(type
, 1));
nice_printf(outfile
, "%s", np
->cvarname
);
listargs(outfile
, e
, 0, lengths
);
nice_printf(outfile
, "\n");
list_arg_types(outfile
, e
, lengths
, 0, "\n");
nice_printf(outfile
, "{\n");
"Multitype ret_val;\n%s(%d, &ret_val",
else if (ISCOMPLEX(type
))
nice_printf(outfile
, "%s(%d,%s", base
, k
,
xretslot
[type
]->user
.ident
); /*)*/
"%s(%d, ret_val, ret_val_len", base
, k
); /*)*/
nice_printf(outfile
, "return %s(%d", base
, k
); /*)*/
memset((char *)A
, 0, nL
);
for(args
= e
->arglist
; args
; args
= args
->nextp
) {
if (np
->vtype
== TYCHAR
&& np
->vclass
!= CLPROC
)
for(a
= A
; a
< Ae
; a
++, args
= args
->nextp
)
nice_printf(outfile
, ", %s", (np
= *a
)
: ((Namep
)args
->datap
)->vclass
== CLPROC
? dfltproc
[((Namep
)args
->datap
)->vtype
]
: dfltarg
[((Namep
)args
->datap
)->vtype
]);
nice_printf(outfile
, ", %s_len", np
->fvarname
);
nice_printf(outfile
, ", (ftnint)0");
nice_printf(outfile
, /*(*/ ");\n");
"r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n");
else if (type
== TYDCOMPLEX
)
"r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n");
else if (type
<= TYLOGICAL
)
nice_printf(outfile
, "return ret_val.%s;\n",
nice_printf(outfile
, "}\n");
struct Entrypoint
*e
= entries
;
nice_printf(outfile
, "switch(n__) {\n");
nice_printf(outfile
, "case %d: goto %s;\n", ++k
,
user_label((long)(extsymtab
- e
->entryname
- 1)));
nice_printf(outfile
, "}\n\n");
/* start a new procedure */
execerr("missing end statement", CNULL
);
procclass
= CLMAIN
; /* default */
/* arrange to get correct count of prototypes that would
change by running f2c again */
if (prev_proc
&& proc_argchanges
)
prev_proc
= proc_argchanges
= 0;
for(cp
= new_procs
; cp
; cp
= cp
->nextp
)
if (at
= ((Namep
)cp
->datap
)->arginfo
)
/* end of procedure. generate variables, epilogs, and prologs */
err("DO loop or BLOCK IF not closed");
for(lp
= labeltab
; lp
< labtabend
; ++lp
)
if(lp
->stateno
!=0 && lp
->labdefined
==NO
)
errstr("missing statement label %s",
/* Save copies of the common variables in extptr -> allextp */
for (ext
= extsymtab
; ext
< nextext
; ext
++)
if (ext
-> extstg
== STGCOMMON
&& ext
-> extp
) {
extern int usedefsforcommon
;
/* Write out the abbreviations for common block reference */
wr_abbrevs (c_file
, 1, ext
-> extp
);
procinit(); /* clean up for next procedure */
/* End of declaration section of procedure. Allocate storage. */
register struct Entrypoint
*ep
;
static char comblks
[] = "common blocks";
/* Now the hash table entries for fields of common blocks have STGCOMMON,
vdcldone, voffset, and varno. And the common blocks themselves have
their full sizes in extleng. */
err_proc
= "equivalences";
/* This implies that entry points in the declarations are buffered in
entries but not written out */
if (ep
= ep0
= (struct Entrypoint
*)revchain((chainp
)entries
)) {
/* entries could be 0 in case of an error */
while(ep
= ep
->entnextp
);
entries
= (struct Entrypoint
*)revchain((chainp
)ep0
);
for(cp
= earlylabs
= revchain(earlylabs
); cp
; cp
= cp
->nextp
)
p1_label((long)cp
->datap
);
p1_line_number(lineno
); /* for files that start with a MAIN program */
/* that starts with an executable statement */
/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
/* Main program or Block data */
startproc(progname
, class)
register struct Entrypoint
*p
;
strcpy (main_alias
, progname
->cextname
);
newentry( mkname(" MAIN"), 0 )->extinit
= 1;
fprintf(diagfile
, " %s", (class==CLMAIN
? "MAIN" : "BLOCK DATA") );
fprintf(diagfile
, " %s", progname
->fextname
);
procname
= progname
->cextname
;
fprintf(diagfile
, ":\n");
/* subroutine or function statement */
Extsym
*newentry(v
, substmsg
)
char buf
[128], badname
[64];
static char already
[] = "external name already used";
p
= mkext(v
->fvarname
, addunder(v
->cvarname
));
if(p
->extinit
|| ! ONEOF(p
->extstg
, M(STGUNKNOWN
)|M(STGEXT
)) )
sprintf(badname
, "%s_bad%d", v
->fvarname
, ++nbad
);
sprintf(buf
,"%s\n\tsubstituting \"%s\"",
p
= mkext(v
->fvarname
, badname
);
v
->vprocclass
= PTHISPROC
;
v
->vardesc
.varno
= p
- extsymtab
;
entrypt(class, type
, length
, entry
, args
)
register struct Entrypoint
*p
;
puthead( procname
= entry
->cextname
, class);
fprintf(diagfile
, " entry ");
fprintf(diagfile
, " %s:\n", entry
->fextname
);
q
= mkname(entry
->fextname
);
type
= lengtype(type
, length
);
procleng
= type
== TYCHAR
? length
: 0;
p
->arglist
= revchain(args
);
settype(q
, type
, length
);
q
->vprocclass
= PTHISPROC
;
/* hold all initial entry points till end of declarations */
/* epicode -- write out the proper function return mechanism at the end of
the procedure declaration. Handles multiple return value types, as
well as cooercion into the proper value */
extern int lastwasbranch
;
/* Return a zero only when the alternate return mechanism has been
specified in the function header */
if ((substars
|| Ansi
) && lastwasbranch
!= YES
)
else if (!multitype
&& lastwasbranch
!= YES
)
else if (procclass
== CLMAIN
&& Ansi
&& lastwasbranch
!= YES
)
/* generate code to return value of type t */
p
= (Addrp
) cpexpr((expptr
)retslot
);
p1_subr_ret (mkconv (t
, fixtype((expptr
)p
)));
/* Do parameter adjustments */
prolog(outfile
, allargs
);
/* Finish bound computations now that all variables are declared.
* This used to be in setbound(), but under -u the following incurred
* an erroneous error message:
register struct Dimblock
*p
;
extern expptr
make_int_expr();
if (q
= p
->dims
[i
].dimexpr
) {
q
= p
->dims
[i
].dimexpr
= make_int_expr(putx(fixtype(q
)));
if (!ONEOF(q
->headblock
.vtype
, MSKINT
|MSKREAL
))
errstr("bad dimension type for %.70s",
p
->basexpr
= make_int_expr(putx(fixtype(q
)));
{ errstr("duplicate argument %.80s", q
->fvarname
); }
manipulate argument lists (allocate argument slot positions)
* keep track of return types and labels
extern char dflttype
[26];
Extsym
*entryname
= ep
->entryname
;
p1_label((long)(extsymtab
- entryname
- 1));
/* The main program isn't allowed to have parameters, so any given
parameters are ignored */
if(procclass
== CLMAIN
|| procclass
== CLBLOCK
)
/* So now we're working with something other than CLMAIN or CLBLOCK.
Determine the type of its return value. */
impldcl( np
= mkname(entryname
->fextname
) );
proc_argchanges
= prev_proc
&& type
!= entryname
->extype
;
if(proctype
== TYUNKNOWN
)
if( (proctype
= type
) == TYCHAR
)
procleng
= np
->vleng
? np
->vleng
->constblock
.Const
.ci
err("noncharacter entry of character function");
/* Functions returning type char can only have multiple entries if all
entries return the same length */
else if( (np
->vleng
? np
->vleng
->constblock
.Const
.ci
:
(ftnint
) (-1)) != procleng
)
err("mismatched character entry lengths");
err("character entry of noncharacter function");
else if(type
!= proctype
)
rtvlabel
[type
] = newlabel();
ep
->typelabel
= rtvlabel
[type
];
chslot
= nextarg(TYADDR
);
chlgslot
= nextarg(TYLENG
);
/* Put a new argument in the function, one which will hold the result of
a character function. This will have to be named sometime, probably in
np
->vleng
= (expptr
) mkarg(TYLENG
, chlgslot
);
np
->vleng
->addrblock
.uname_tag
= UNAM_IDENT
;
strcpy (np
-> vleng
-> addrblock
.user
.ident
,
autovar(0, type
, ISCONST(np
->vleng
)
? np
->vleng
: ICON(0), "");
strcpy(rs
->user
.ident
, "ret_val");
/* Handle a complex return type -- declare a new parameter (pointer to
else if( ISCOMPLEX(type
) ) {
autovar(0, type
, EXNULL
, " ret_val");
/* the blank is for use in out_addr */
cxslot
= nextarg(TYADDR
);
else if (type
!= TYSUBR
) {
dclerr("untyped function", np
);
proctype
= type
= np
->vtype
=
dflttype
[letter(np
->fvarname
[0])];
xretslot
[type
] = retslot
=
autovar(1, type
, EXNULL
, " ret_val");
/* the blank is for use in out_addr */
for(p
= ep
->arglist
; p
; p
= p
->nextp
)
if(! (( q
= (Namep
) (p
->datap
) )->vknownarg
) ) {
q
->vardesc
.varno
= nextarg(TYADDR
);
allargs
= mkchain((char *)q
, allargs
);
else for(p1
= ep
->arglist
; p1
!= p
; p1
= p1
->nextp
)
if ((Namep
)p1
->datap
== q
)
for(p
= ep
->arglist
; p
; p
= p
->nextp
) {
if(! (( q
= (Namep
) (p
->datap
) )->vdcldone
) )
/* If we don't know the length of a char*(*) (i.e. a string), we must add
in this additional length argument. */
else if (q
->vleng
== NULL
) {
mkarg(TYLENG
, nextarg(TYLENG
) );
unamstring((Addrp
)q
->vleng
,
if (q
->vtype
== TYCHAR
&& q
->vclass
!= CLPROC
)
if (entryname
->extype
!= type
)
/* save information for checking consistency of arg lists */
save_argtypes(ep
->arglist
, &entryname
->arginfo
, &np
->arginfo
,
0, np
->fvarname
, STGEXT
, k
, np
->vtype
, 2);
{ return(lastargslot
++); }
register struct Dimblock
*vdim
= q
->vdim
;
if(!vdim
->nelt
|| !ISICON(vdim
->nelt
))
dclerr("adjustable dimension on non-argument", q
);
else if (vdim
->nelt
->constblock
.Const
.ci
<= 0)
dclerr("nonpositive dimension", q
);
register struct Hashentry
*p
;
for(p
= hashtab
; p
<lasthash
; ++p
)
if( (qclass
==CLUNKNOWN
&& qstg
!=STGARG
) ||
(qclass
==CLVAR
&& qstg
==STGUNKNOWN
) ) {
if (!(q
->vis_assigned
| q
->vimpldovar
))
warn1("local variable %s never used",
else if(qclass
==CLVAR
&& qstg
==STGBSS
)
/* Give external procedures the proper storage class */
else if(qclass
==CLPROC
&& q
->vprocclass
==PEXTERNAL
e
= mkext(q
->fvarname
,addunder(q
->cvarname
));
q
->vardesc
.varno
= e
- extsymtab
;
if (qstg
!= STGARG
&& q
->vdim
)
} /* if qclass == CLVAR */
register struct Hashentry
*p
;
for(p
=hashtab
; p
<lasthash
; ++p
)
if( (q
= p
->varp
) && q
->vclass
==CLNAMELIST
)
/* iarrlen -- Returns the size of the array in bytes, or -1 */
leng
= typesize
[q
->vtype
];
if( ISICON(q
->vdim
->nelt
) )
leng
*= q
->vdim
->nelt
->constblock
.Const
.ci
;
leng
*= q
->vleng
->constblock
.Const
.ci
;
for(q
= np
->varxptr
.namelist
; q
; q
= q
->nextp
)
vardcl( v
= (Namep
) (q
->datap
) );
if( !ONEOF(v
->vstg
, MSKSTATIC
) )
dclerr("may not appear in namelist", v
);
/* docommon -- called at the end of procedure declarations, before
equivalences and the procedure body */
for(extptr
= extsymtab
; extptr
<nextext
; ++extptr
)
if (extptr
->extstg
== STGCOMMON
&& (q
= extptr
->extp
)) {
/* If a common declaration also had a list of variables ... */
q
= extptr
->extp
= revchain(q
);
for(k
= TYCHAR
; q
; q
= q
->nextp
)
comvar
= (Namep
) (q
->datap
);
if(comvar
->vdcldone
== NO
)
if (pref
< type_pref
[type
])
pref
= type_pref
[k
= type
];
if(extptr
->extleng
% typealign
[type
] != 0) {
dclerr("common alignment", comvar
);
--nerr
; /* don't give bad return code for this */
extptr
->extleng
= roundup(extptr
->extleng
, typealign
[type
]);
} /* if extptr -> extleng % */
/* Set the offset into the common block */
comvar
->voffset
= extptr
->extleng
;
comvar
->vardesc
.varno
= extptr
- extsymtab
;
size
= comvar
->vleng
->constblock
.Const
.ci
;
if( (neltp
= t
->nelt
) && ISCONST(neltp
) )
size
*= neltp
->constblock
.Const
.ci
;
dclerr("adjustable array in common", comvar
);
/* Adjust the length of the common block so far */
/* Determine curno and, if new, save this identifier chain */
for (q
= extptr
->allextp
, i
= 0; q
; i
++, q
= q
->nextp
)
if (struct_eq((chainp
)q
->datap
, q1
))
extptr
->curno
= extptr
->maxno
- i
;
extptr
->curno
= ++extptr
->maxno
;
extptr
->allextp
= mkchain((char *)extptr
->extp
,
} /* if extptr -> extstg == STGCOMMON */
/* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
varno. And the common block itself has its full size in extleng. */
/* copy_data -- copy the Namep entries so they are available even after
the hash table is empty */
for (; list
; list
= list
-> nextp
) {
Namep namep
= ALLOC (Nameblock
);
cpn(sizeof(struct Nameblock
), list
->datap
, (char *)namep
);
namep
->fvarname
= strcpy(gmem(strlen(namep
->fvarname
)+1,0),
namep
->cvarname
= strcmp(namep
->fvarname
, namep
->cvarname
)
? strcpy(gmem(strlen(namep
->cvarname
)+1,0), namep
->cvarname
)
namep
-> vleng
= (expptr
) cpexpr (namep
-> vleng
);
nd
= namep
-> vdim
-> ndim
;
size
= sizeof(int) + (3 + 2 * nd
) * sizeof (expptr
);
dp
= (struct Dimblock
*) ckalloc (size
);
cpn(size
, (char *)namep
->vdim
, (char *)dp
);
dp
->nelt
= (expptr
)cpexpr(dp
->nelt
);
for (i
= 0; i
< nd
; i
++) {
dp
-> dims
[i
].dimsize
= (expptr
) cpexpr (dp
-> dims
[i
].dimsize
);
list
-> datap
= (char *) namep
;
for(p
= extsymtab
; p
< nextext
; ++p
)
if(p
->extstg
== STGCOMMON
)
if(p
->maxleng
!=0 && p
->extleng
!=0 && p
->maxleng
!=p
->extleng
&& strcmp(Blank
, p
->cextname
) )
warn1("incompatible lengths for common block %.60s",
if(p
->maxleng
< p
->extleng
)
/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
/* put block on chain of temps to be reclaimed */
holdtemps
= mkchain((char *)p
, holdtemps
);
if (t
== TYCHAR
&& q
->varleng
!= 0) {
/* restore clobbered character string lengths */
q
->vleng
= ICON(q
->varleng
);
/* allocate an automatic variable slot for each of nelt variables */
Addrp
autovar(nelt0
, t
, lengp
, name
)
register int nelt
= nelt0
> 0 ? nelt0
: 1;
leng
= lengp
->constblock
.Const
.ci
;
Fatal("automatic variable of nonconstant length");
/* kludge for nls so we can have ret_val rather than ret_val_4 */
q
->uname_tag
= UNAM_IDENT
;
temp_name(av_pfix
[t
], ++autonum
[t
], q
->user
.ident
);
/* Returns a temporary of the appropriate type. Will reuse existing
temporaries when possible */
Addrp
mktmpn(nelt
, type
, lengp
)
if(type
==TYUNKNOWN
|| type
==TYERROR
)
if(lengp
&& ISICON(lengp
) )
leng
= lengp
->constblock
.Const
.ci
;
err("adjustable length");
return( (Addrp
) errnode() );
else if (type
> TYCHAR
|| type
< TYADDR
) {
erri("mktmpn: unexpected type %d", type
);
* if a temporary of appropriate shape is on the templist,
* remove it from the list and return it
for(oldp
=CHNULL
, p
=templist
[type
]; p
; oldp
=p
, p
=p
->nextp
)
(type
!=TYCHAR
|| q
->vleng
->constblock
.Const
.ci
==leng
) )
templist
[type
] = p
->nextp
;
q
= autovar(nelt
, type
, lengp
, "");
/* mktmp -- create new local variable; call it something like name
lengp is taken directly, not copied */
/* arrange for temporaries to be recycled */
/* at the end of this statement... */
rv
= mktmpn(1,type
,lengp
);
frtemp((Addrp
)cpexpr((expptr
)rv
));
/* mktmp0 omits frtemp() */
Addrp
mktmp0(type
, lengp
)
/* arrange for temporaries to be recycled */
/* when this Addrp is freed */
rv
= mktmpn(1,type
,lengp
);
/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
/* comblock -- Declare a new common block. Input parameters name the block;
s will be NULL if the block is unnamed */
/* Give the unnamed common block a unique name */
for(i
= 0; c
= *t
= *s
++; t
++)
if(p
->extstg
== STGUNKNOWN
)
else if(p
->extstg
!= STGCOMMON
)
errstr("%.68s cannot be a common block name", s
);
/* incomm -- add a new variable to a common declaration */
if(v
->vstg
!= STGUNKNOWN
&& !v
->vimplstg
)
? "dummy arguments cannot be in common"
: "incompatible common declaration", v
);
c
->extp
= mkchain((char *)v
, c
->extp
);
/* settype -- set the type or storage class of a Namep object. If
v -> vstg == STGUNKNOWN && type < 0, attempt to reset vstg to be
-type. This function will not change any earlier definitions in v,
in will only attempt to fill out more information give the other params */
if(type
==TYSUBR
&& v
->vtype
!=TYUNKNOWN
&& v
->vstg
==STGARG
)
else if(type
< 0) /* storage class set */
if(v
->vstg
== STGUNKNOWN
)
else if(v
->vstg
!= -type
)
dclerr("incompatible storage declarations", v
);
else if(v
->vtype
== TYUNKNOWN
|| v
->vimpltype
&& v
->vtype
!= type
)
if( (v
->vtype
= lengtype(type
, length
))==TYCHAR
)
else if (parstate
>= INDATA
)
v
->vleng
= ICON(1); /* avoid a memory fault */
if (v
->vclass
== CLPROC
) {
&& (type1
= extsymtab
[v
->vardesc
.varno
].extype
)
else if (v
->vprocclass
== PTHISPROC
xretslot
[type
] = autovar(ONEOF(type
,
MSKCOMPLEX
|MSKCHAR
) ? 0 : 1, type
,
"illegal use of %.60s (main program name)",
/* not completely right, but enough to */
/* avoid memory faults; we won't */
/* emit any C as we have illegal Fortran */
else if(v
->vtype
!=type
) {
dclerr("incompatible type declarations", v
);
if (v
->vleng
&& v
->vleng
->constblock
.Const
.ci
!= length
)
else if (parstate
>= INDATA
)
v
->vleng
= ICON(1); /* avoid a memory fault */
/* lengtype -- returns the proper compiler type, given input of Fortran
type and length specifier */
register int length
= (int)len
;
if(length
== typesize
[TYDREAL
])
if(length
== typesize
[TYREAL
])
if(length
== typesize
[TYDCOMPLEX
])
if(length
== typesize
[TYCOMPLEX
])
case 1: return TYLOGICAL1
;
case 2: return TYLOGICAL2
;
if(length
== typesize
[TYLOGICAL
])
if(length
== typesize
[TYSHORT
])
if(length
== typesize
[TYQUAD
] && use_tyquad
)
if(length
== typesize
[TYLONG
])
badtype("lengtype", type
);
err("incompatible type-length combination");
/* setintr -- Set Intrinsic function */
if(v
->vstg
== STGUNKNOWN
)
else if(v
->vstg
!=STGINTR
)
dclerr("incompatible use of intrinsic function", v
);
if(v
->vprocclass
== PUNKNOWN
)
v
->vprocclass
= PINTRINSIC
;
else if(v
->vprocclass
!= PINTRINSIC
)
dclerr("invalid intrinsic declaration", v
);
if(k
= intrfunct(v
->fvarname
)) {
if ((*(struct Intrpacked
*)&k
).f4
)
dclerr("unknown intrinsic function", v
);
/* setext -- Set External declaration -- assume that unknowns will become
if(v
->vclass
== CLUNKNOWN
)
else if(v
->vclass
!= CLPROC
)
dclerr("invalid external declaration", v
);
if(v
->vprocclass
== PUNKNOWN
)
v
->vprocclass
= PEXTERNAL
;
else if(v
->vprocclass
!= PEXTERNAL
)
dclerr("invalid external declaration", v
);
/* create dimensions block for array variable */
register struct Dimblock
*p
;
if(v
->vclass
== CLUNKNOWN
)
else if(v
->vclass
!= CLVAR
)
dclerr("only variables may be arrays", v
);
v
->vdim
= p
= (struct Dimblock
*)
ckalloc( sizeof(int) + (3+2*nd
)*sizeof(expptr
) );
if( (q
= dims
[i
].ub
) == NULL
)
err("only last bound may be asterisk");
p
->dims
[i
].dimsize
= ICON(1);
p
->dims
[i
].dimexpr
= NULL
;
q
= mkexpr(OPMINUS
, q
, cpexpr(dims
[i
].lb
));
q
= mkexpr(OPPLUS
, q
, ICON(1) );
p
->dims
[i
].dimexpr
= (expptr
) PNULL
;
sprintf(buf
, " %s_dim%d", v
->fvarname
, i
+1);
p
->dims
[i
].dimsize
= (expptr
)
autovar(1, tyint
, EXNULL
, buf
);
p
->nelt
= mkexpr(OPSTAR
, p
->nelt
,
cpexpr(p
->dims
[i
].dimsize
) );
for(i
= nd
-1 ; i
>=0 ; --i
)
mkexpr(OPSTAR
, cpexpr(p
->dims
[i
].dimsize
), q
));
sprintf(buf
, " %s_offset", v
->fvarname
);
p
->baseoffset
= (expptr
) autovar(1, tyint
, EXNULL
, buf
);
wr_abbrevs (outfile
, function_head
, vars
)
for (; vars
; vars
= vars
-> nextp
) {
Namep name
= (Namep
) vars
-> datap
;
nice_printf (outfile
, "#define ");
nice_printf (outfile
, "#undef ");
out_name (outfile
, name
);
Extsym
*comm
= &extsymtab
[name
-> vardesc
.varno
];
nice_printf (outfile
, " (");
extern_out (outfile
, comm
);
nice_printf (outfile
, "%d.", comm
->curno
);
nice_printf (outfile
, "%s)", name
->cvarname
);
nice_printf (outfile
, "\n");