/* start a new procedure */
execerr("missing end statement", 0);
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
*p
;
for(p
= entries
; p
; p
= p
->nextp
)
/* 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 Nameblock
*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 Nameblock
*q
;
register struct Entrypoint
*p
;
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
)
entries
= hookup(entries
, p
);
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
, NULL
);
putbranch( cpexpr(typeaddr
) );
for(i
= 0; i
< NTYPES
; ++i
)
else if(procclass
!= CLBLOCK
)
/* generate code to return value of type t */
register struct Addrblock
*p
;
fatali("retval: impossible type %d", t
);
/* Allocate extra argument array if needed. Generate prologs. */
register struct Entrypoint
*p
;
struct Addrblock
*argvec
;
argvec
= autovar(lastargslot
/SZADDR
, TYADDR
, NULL
);
if(lastargslot
>0 && nentry
>1)
argvec
= autovar(1 + lastargslot
/SZADDR
, TYADDR
, NULL
);
argvec
= autovar(lastargslot
/SZADDR
, TYADDR
, NULL
);
for(p
= entries
; p
; p
= p
->nextp
)
manipulate argument lists (allocate argument slot positions)
* keep track of return types and labels
register struct Nameblock
*np
;
register struct Nameblock
*q
;
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
) 0);
err("noncharacter entry of character function");
else if( (np
->vleng
? np
->vleng
->constblock
.const.ci
: (ftnint
) 0) != 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
= mkarg(TYLENG
, chlgslot
);
else if( ISCOMPLEX(type
) )
cxslot
= nextarg(TYADDR
);
np
->vardesc
.varno
= cxslot
;
retslot
= autovar(1, TYDREAL
, NULL
);
np
->voffset
= retslot
->memoffset
->constblock
.const.ci
;
for(p
= ep
->arglist
; p
; p
= p
->nextp
)
if(! ((q
= p
->datap
)->vdcldone
) )
q
->vardesc
.varno
= nextarg(TYADDR
);
for(p
= ep
->arglist
; p
; p
= p
->nextp
)
if(! ((q
= p
->datap
)->vdcldone
) )
prstab(varstr(VL
,q
->varname
), N_PSYM
,
convic(q
->vardesc
.varno
+ ARGOFFSET
) );
if(q
->vleng
== NULL
) /* character*(*) */
q
->vleng
= mkarg(TYLENG
, nextarg(TYLENG
) );
else if(q
->vclass
==CLPROC
&& nentry
==1)
putlabel(ep
->entrylabel
);
lastargslot
+= typesize
[type
];
/* generate variable references */
register struct Hashentry
*p
;
register struct Nameblock
*q
;
for(p
= hashtab
; p
<lasthash
; ++p
)
if(sdbflag
&&qclass
==CLVAR
&&(qstg
==STGBSS
||qstg
==STGINIT
))
prstab(varstr(VL
,q
->varname
), N_LCSYM
,
stabtype(q
), 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
);
for(p
= extsymtab
; p
<nextext
; ++p
)
prext( varstr(XL
, p
->extname
), p
->maxleng
, p
->extinit
);
register struct Nameblock
*q
;
leng
= typesize
[q
->vtype
];
if( ISICON(q
->vdim
->nelt
) )
leng
*= q
->vdim
->nelt
->constblock
.const.ci
;
leng
*= q
->vleng
->constblock
.const.ci
;
register struct Extsym
*p
;
register struct Nameblock
*v
;
for(p
= extsymtab
; p
<nextext
; ++p
)
prstab(NULL
, 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 */
holdtemps
= mkchain(p
, holdtemps
);
/* allocate an automatic variable slot */
struct Addrblock
*autovar(nelt
, t
, lengp
)
register struct Addrblock
*q
;
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
);
struct Addrblock
*mktmpn(nelt
, type
, lengp
)
register struct Addrblock
*q
;
if(type
==TYUNKNOWN
|| type
==TYERROR
)
fatali("mktmpn: invalid type %d", type
);
leng
= lengp
->constblock
.const.ci
;
err("adjustable length");
for(oldp
= &templist
; p
= oldp
->nextp
; oldp
= p
)
if(q
->vtype
==type
&& q
->ntempelt
==nelt
&&
(type
!=TYCHAR
|| q
->vleng
->constblock
.const.ci
==leng
) )
q
= autovar(nelt
, type
, lengp
);
struct Addrblock
*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
,NULL
) );
register struct Nameblock
* v
;
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
])
fatali("lengtype: invalid type %d", type
);
err("incompatible type-length combination");
register struct Nameblock
* v
;
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
);
register struct Nameblock
* 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 */
register struct Nameblock
* v
;
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
= NULL
;
p
->dims
[i
].dimsize
= autovar(1, tyint
, NULL
);
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
= autovar(1, tyint
, NULL
);