/* start a new procedure */
execerr("missing end statement", CNULL
);
procclass
= CLMAIN
; /* default */
/* 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 number %s", convic(lp
->stateno
) );
procinit(); /* clean up for next procedure */
/* End of declaration section of procedure. Allocate storage. */
register struct Entrypoint
*ep
;
for(ep
= entries
; ep
; ep
= ep
->entnextp
)
/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
/* Main program or Block data */
startproc(progname
, class)
struct Extsym
* progname
;
register struct Entrypoint
*p
;
puthead("MAIN__", CLMAIN
);
newentry( mkname(5, "MAIN_") );
p
->entrylabel
= newlabel();
fprintf(diagfile
, " %s", (class==CLMAIN
? "MAIN" : "BLOCK DATA") );
fprintf(diagfile
, " %s", nounder(XL
, procname
= progname
->extname
) );
fprintf(diagfile
, ":\n");
if(sdbflag
&& class==CLMAIN
)
sprintf(buff
, "L%d", p
->entrylabel
);
prstab("MAIN_", N_FUN
, lineno
, buff
);
p2pass( stabline("MAIN_", N_FNAME
, 0, 0) );
prstab(nounder(XL
,progname
->extname
), N_ENTRY
, lineno
,buff
);
/* p2pass(stabline(nounder(XL,progname->extname),N_FNAME,0,0)); */
/* subroutine or function statement */
struct Extsym
*newentry(v
)
register struct Extsym
*p
;
p
= mkext( varunder(VL
, v
->varname
) );
if(p
==NULL
|| p
->extinit
|| ! ONEOF(p
->extstg
, M(STGUNKNOWN
)|M(STGEXT
)) )
dclerr("invalid entry name", v
);
else dclerr("external name already used", v
);
v
->vprocclass
= PTHISPROC
;
entrypt(class, type
, length
, entry
, args
)
register struct Entrypoint
*p
, *ep
;
puthead( varstr(XL
, procname
= entry
->extname
), class);
fprintf(diagfile
, " entry ");
fprintf(diagfile
, " %s:\n", nounder(XL
, entry
->extname
));
q
= mkname(VL
, nounder(XL
,entry
->extname
) );
if( (type
= lengtype(type
, (int) length
)) != TYCHAR
)
if(entries
) /* put new block at end of entries list */
for(ep
= entries
; ep
->entnextp
; ep
= ep
->entnextp
)
p
->entrylabel
= newlabel();
sprintf(buff
, "L%d", p
->entrylabel
);
prstab(nounder(XL
, entry
->extname
),
(class==CLENTRY
? N_ENTRY
: N_FUN
),
p2pass( stabline( nounder(XL
,entry
->extname
), N_FNAME
, 0, 0) );
q
->vprocclass
= PTHISPROC
;
settype(q
, type
, (int) length
);
/* hold all initial entry points till end of declarations */
putforce(TYINT
, ICON(0) );
typeaddr
= autovar(1, TYADDR
, PNULL
);
putbranch( cpexpr(typeaddr
) );
for(i
= 0; i
< NTYPES
; ++i
)
else if(procclass
!= CLBLOCK
)
/* generate code to return value of type t */
p
= (Addrp
) cpexpr(retslot
);
p
= (Addrp
) cpexpr(retslot
);
/* Allocate extra argument array if needed. Generate prologs. */
register struct Entrypoint
*p
;
argvec
= autovar(lastargslot
/SZADDR
, TYADDR
, PNULL
);
if(lastargslot
>0 && nentry
>1)
argvec
= autovar(1 + lastargslot
/SZADDR
, TYADDR
, PNULL
);
argvec
= autovar(lastargslot
/SZADDR
, TYADDR
, PNULL
);
for(p
= entries
; p
; p
= p
->entnextp
)
manipulate argument lists (allocate argument slot positions)
* keep track of return types and labels
putlabel(ep
->entrylabel
);
else if(procclass
== CLBLOCK
)
impldcl( np
= mkname(VL
, nounder(XL
, ep
->entryname
->extname
) ) );
if(proctype
== TYUNKNOWN
)
if( (proctype
= type
) == TYCHAR
)
procleng
= (np
->vleng
? np
->vleng
->constblock
.const.ci
: (ftnint
) (-1));
err("noncharacter entry of character function");
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
);
np
->vardesc
.varno
= chslot
;
np
->vleng
= (expptr
) mkarg(TYLENG
, chlgslot
);
else if( ISCOMPLEX(type
) )
cxslot
= nextarg(TYADDR
);
np
->vardesc
.varno
= cxslot
;
retslot
= autovar(1, TYDREAL
, PNULL
);
np
->voffset
= retslot
->memoffset
->constblock
.const.ci
;
for(p
= ep
->arglist
; p
; p
= p
->nextp
)
if(! (( q
= (Namep
) (p
->datap
) )->vdcldone
) )
q
->vardesc
.varno
= nextarg(TYADDR
);
for(p
= ep
->arglist
; p
; p
= p
->nextp
)
if(! (( q
= (Namep
) (p
->datap
) )->vdcldone
) )
prstab(varstr(VL
,q
->varname
), N_PSYM
,
convic(q
->vardesc
.varno
+ ARGOFFSET
) );
if(q
->vleng
== NULL
) /* character*(*) */
mkarg(TYLENG
, nextarg(TYLENG
) );
else if(q
->vclass
==CLPROC
&& nentry
==1)
putlabel(ep
->entrylabel
);
lastargslot
+= typesize
[type
];
/* generate variable references */
register struct Hashentry
*p
;
for(p
= hashtab
; p
<lasthash
; ++p
)
if(sdbflag
&& qclass
==CLVAR
) switch(qstg
)
prstab(varstr(VL
,q
->varname
), N_LSYM
,
prstab(varstr(VL
,q
->varname
), N_LCSYM
,
memname(qstg
,q
->vardesc
.varno
) );
prstab(varstr(VL
,q
->varname
), N_STSYM
,
memname(qstg
,q
->vardesc
.varno
) );
if( (qclass
==CLUNKNOWN
&& qstg
!=STGARG
) ||
(qclass
==CLVAR
&& qstg
==STGUNKNOWN
) )
warn1("local variable %s never used", varstr(VL
,q
->varname
) );
else if(qclass
==CLVAR
&& qstg
==STGBSS
)
align
= (qtype
==TYCHAR
? ALILONG
: typealign
[qtype
]);
bssleng
= roundup(bssleng
, align
);
prlocvar(memname(STGBSS
,q
->vardesc
.varno
), iarrl
= iarrlen(q
) );
else if(qclass
==CLPROC
&& q
->vprocclass
==PEXTERNAL
&& qstg
!=STGARG
)
mkext(varunder(VL
, q
->varname
)) ->extstg
= STGEXT
;
if(qclass
==CLVAR
&& qstg
!=STGARG
)
if(q
->vdim
&& !ISICON(q
->vdim
->nelt
) )
dclerr("adjustable dimension on non-argument", q
);
if(qtype
==TYCHAR
&& (q
->vleng
==NULL
|| !ISICON(q
->vleng
)))
dclerr("adjustable leng on nonargument", q
);
for(i
= 0 ; i
< nequiv
; ++i
)
if(eqvclass
[i
].eqvinit
==NO
&& (leng
= eqvclass
[i
].eqvleng
)!=0 )
bssleng
= roundup(bssleng
, ALIDOUBLE
);
prlocvar( memname(STGEQUIV
, i
), leng
);
register struct Hashentry
*p
;
for(p
=hashtab
; p
<lasthash
; ++p
)
if( (q
= p
->varp
) && q
->vclass
==CLNAMELIST
)
for(p
= extsymtab
; p
<nextext
; ++p
)
prext( varstr(XL
, p
->extname
), p
->maxleng
, p
->extinit
);
leng
= typesize
[q
->vtype
];
if( ISICON(q
->vdim
->nelt
) )
leng
*= q
->vdim
->nelt
->constblock
.const.ci
;
leng
*= q
->vleng
->constblock
.const.ci
;
/* This routine creates a static block representing the namelist.
An equivalent declaration of the structure produced is:
int type; # negative means -type= number of chars
struct dimensions *dimp; # null means scalar
int span[numberofdimensions];
where the namelistentry list terminates with a null varname
If dimp is not null, then the corner element of the array is at
varaddr. However, the element with subscripts (i1,...,in) is at
varaddr - dimp->baseoffset + sizeoftype * (i1+span[0]*(i2+span[1]*...)
register struct Dimblock
*dp
;
int type
, dimno
, dimoffset
;
fprintf(asmfile
, LABELFMT
, memname(STGINIT
, np
->vardesc
.varno
));
putstr(asmfile
, varstr(VL
, np
->varname
), 16);
for(q
= np
->varxptr
.namelist
; q
; q
= q
->nextp
)
vardcl( v
= (Namep
) (q
->datap
) );
if( ONEOF(v
->vstg
, MSKSTATIC
) )
putstr(asmfile
, varstr(VL
,v
->varname
), 16);
praddr(asmfile
, v
->vstg
, v
->vardesc
.varno
, v
->voffset
);
-(v
->vleng
->constblock
.const.ci
) : (ftnint
) type
);
praddr(asmfile
, STGINIT
, dimno
, (ftnint
)dimoffset
);
dimoffset
+= 3 + v
->vdim
->ndim
;
praddr(asmfile
, STGNULL
,0,(ftnint
) 0);
dclerr("may not appear in namelist", v
);
fprintf(asmfile
, LABELFMT
, memname(STGINIT
,dimno
));
for(q
= np
->varxptr
.namelist
; q
; q
= q
->nextp
)
if(dp
= q
->datap
->nameblock
.vdim
)
prconi(asmfile
, TYINT
, (ftnint
) (dp
->ndim
) );
(ftnint
) (dp
->nelt
->constblock
.const.ci
) );
(ftnint
) (dp
->baseoffset
->constblock
.const.ci
));
for(i
=0; i
<dp
->ndim
; ++i
)
dp
->dims
[i
].dimsize
->constblock
.const.ci
);
register struct Extsym
*p
;
for(p
= extsymtab
; p
<nextext
; ++p
)
prstab(CNULL
, N_BCOMM
, 0, 0);
for(q
= p
->extp
; q
; q
= q
->nextp
)
if(p
->extleng
% typealign
[type
] != 0)
dclerr("common alignment", v
);
p
->extleng
= roundup(p
->extleng
, typealign
[type
]);
v
->vardesc
.varno
= p
- extsymtab
;
size
= v
->vleng
->constblock
.const.ci
;
else size
= typesize
[type
];
if( (neltp
= t
->nelt
) && ISCONST(neltp
) )
size
*= neltp
->constblock
.const.ci
;
dclerr("adjustable array in common", v
);
prstab(varstr(XL
,p
->extname
), N_ECOMM
, 0, 0);
register struct Extsym
*p
;
for(p
= extsymtab
; p
< nextext
; ++p
)
if(p
->extstg
== STGCOMMON
)
if(p
->maxleng
!=0 && p
->extleng
!=0 && p
->maxleng
!=p
->extleng
&& !eqn(XL
,"_BLNK__ ",p
->extname
) )
warn1("incompatible lengths for common block %s",
nounder(XL
, p
->extname
) );
if(p
->maxleng
< p
->extleng
)
/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
/* restore clobbered character string lengths */
if(p
->vtype
==TYCHAR
&& p
->varleng
!=0)
p
->vleng
= ICON(p
->varleng
);
/* put block on chain of temps to be reclaimed */
holdtemps
= mkchain(p
, holdtemps
);
/* allocate an automatic variable slot */
Addrp
autovar(nelt
, t
, lengp
)
leng
= lengp
->constblock
.const.ci
;
fatal("automatic variable of nonconstant length");
autoleng
= roundup( autoleng
, typealign
[t
]);
#if TARGET==PDP11 || TARGET==VAX
/* stack grows downward */
q
->memoffset
= ICON( - autoleng
);
q
->memoffset
= ICON( autoleng
);
Addrp
mktmpn(nelt
, type
, lengp
)
if(type
==TYUNKNOWN
|| type
==TYERROR
)
leng
= lengp
->constblock
.const.ci
;
err("adjustable length");
* if an temporary of appropriate shape is on the templist,
* remove it from the list and return it
for(oldp
=CHNULL
, p
=templist
; p
; oldp
=p
, p
=p
->nextp
)
if(q
->vtype
==type
&& q
->ntempelt
==nelt
&&
(type
!=TYCHAR
|| q
->vleng
->constblock
.const.ci
==leng
) )
q
= autovar(nelt
, type
, lengp
);
Addrp
mktemp(type
, lengp
)
return( mktmpn(1,type
,lengp
) );
/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
struct Extsym
*comblock(len
, s
)
p
= mkext( varunder(len
, s
) );
if(p
->extstg
== STGUNKNOWN
)
else if(p
->extstg
!= STGCOMMON
)
errstr("%s cannot be a common block name", s
);
if(v
->vstg
!= STGUNKNOWN
)
dclerr("incompatible common declaration", v
);
c
->extp
= hookup(c
->extp
, mkchain(v
,CHNULL
) );
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
)
if( (v
->vtype
= lengtype(type
, length
))==TYCHAR
&& length
>=0)
else if(v
->vtype
!=type
|| (type
==TYCHAR
&& v
->vleng
->constblock
.const.ci
!=length
) )
dclerr("incompatible type declarations", v
);
if(length
== typesize
[TYLOGICAL
])
badtype("lengtype", type
);
err("incompatible type-length combination");
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
->varname
))
dclerr("unknown intrinsic function", v
);
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 */
struct { expptr lb
, ub
; } dims
[ ];
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
;
p
->dims
[i
].dimsize
= (expptr
) autovar(1, tyint
, PNULL
);
p
->nelt
= mkexpr(OPSTAR
, p
->nelt
,
cpexpr(p
->dims
[i
].dimsize
) );
for(i
= nd
-2 ; i
>=0 ; --i
)
q
= mkexpr(OPPLUS
, t
, mkexpr(OPSTAR
, cpexpr(p
->dims
[i
].dimsize
), q
) );
p
->baseoffset
= (expptr
) autovar(1, tyint
, PNULL
);