/* INTERMEDIATE CODE GENERATION FOR S C JOHNSON C COMPILERS */
/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
struct Addrblock
*imagpart();
static long int p2buff
[P2BUFFMAX
];
static long int *p2bufp
= &p2buff
[0];
static long int *p2bufend
= &p2buff
[P2BUFFMAX
];
p2ps("\t.globl\t_%s", s
);
/* put out fake copy of left bracket line, to be redone later */
headoffset
= ftell(textfile
);
p2triple(P2STMT
, (strlen(infname
)+FOUR
-1)/FOUR
, 0);
/* fake jump to start the optimizer */
putgoto( fudgelabel
= newlabel() );
/* It is necessary to precede each procedure with a "left bracket"
* line that tells pass 2 how many register variables and how
* much automatic space is required for the function. This compiler
* does not know how much automatic space is needed until the
* entire procedure has been processed. Therefore, "puthead"
* is called at the begining to record the current location in textfile,
* then to put out a placeholder left bracket line. This procedure
* repositions the file and rewrites that line, then puts the
* file pointer back to the end of the file.
hereoffset
= ftell(textfile
);
if(fseek(textfile
, headoffset
, 0))
if(fseek(textfile
, hereoffset
, 0))
p2triple(P2STMT
, 0, lineno
);
/* put out code for if( ! p) goto l */
if( ( k
= (p
= fixtype(p
))->headblock
.vtype
) != TYLOGICAL
)
err("non-logical expression in IF statement");
p2icon( (long int) l
, P2INT
);
/* put out code for goto l */
p2triple(P2GOTO
, 1, label
);
/* branch to address constant or integer variable */
register struct Addrblock
*p
;
putcmgo(index
, nlab
, labs
)
struct Labelblock
*labs
[];
int i
, labarray
, skiplabel
;
if(! ISINT(index
->headblock
.vtype
) )
execerr("computed goto index must be integer", NULL
);
/* use special case instruction */
vaxgoto(index
, nlab
, labs
);
prlabel(asmfile
, labarray
);
prcona(asmfile
, (ftnint
) (skiplabel
= newlabel()) );
for(i
= 0 ; i
< nlab
; ++i
)
prcona(asmfile
, (ftnint
)(labs
[i
]->labelno
) );
prcmgoto(index
, nlab
, skiplabel
, labarray
);
struct Addrblock
*putcall(), *putcx1(), *realpart();
switch(type
= p
->constblock
.vtype
)
p2icon(p
->constblock
.const.ci
, types2
[type
]);
p2triple(P2ICON
, 1, P2INT
|P2PTR
);
(int) p
->constblock
.const.ci
) );
switch(opc
= p
->exprblock
.opcode
)
if( ISCOMPLEX(p
->exprblock
.vtype
) )
if(ISCOMPLEX(p
->exprblock
.leftp
->headblock
.vtype
)
|| ISCOMPLEX(p
->exprblock
.rightp
->headblock
.vtype
) )
if( ISCOMPLEX(p
->exprblock
.leftp
->headblock
.vtype
) ||
ISCOMPLEX(p
->exprblock
.rightp
->headblock
.vtype
) )
if(ISCHAR(p
->exprblock
.leftp
))
if(INT(p
->exprblock
.leftp
->headblock
.vtype
) &&
ISICON(p
->exprblock
.rightp
) &&
( (k
= log2(p
->exprblock
.rightp
->constblock
.const.ci
))>0) )
p
->exprblock
.opcode
= OPLSHIFT
;
frexpr(p
->exprblock
.rightp
);
p
->exprblock
.rightp
= ICON(k
);
if( ISCOMPLEX(p
->exprblock
.vtype
) )
if( ISCOMPLEX(p
->exprblock
.vtype
) )
else if( ISCOMPLEX(p
->exprblock
.leftp
->headblock
.vtype
) )
putx( mkconv(p
->exprblock
.vtype
,
realpart(putcx1(p
->exprblock
.leftp
,
putcomma(ncomma
, p
->exprblock
.vtype
, NO
);
fatali("putx: invalid opcode %d", opc
);
fatali("putx: impossible tag %d", p
->headblock
.tag
);
switch(p
->exprblock
.opcode
) /* check for special cases and rewrite */
lt
= lp
->headblock
.vtype
;
while(p
->headblock
.tag
==TEXPR
&&
p
->exprblock
.opcode
==OPCONV
&&
( (ISREAL(pt
)&&ISREAL(lt
)) ||
(INT(pt
)&&(ONEOF(lt
,MSKINT
|MSKADDR
|MSKCHAR
|M(TYSUBR
)))) ))
if(lp
->headblock
.tag
!= TEXPR
)
if(pt
==TYINT
&& lt
==TYLONG
)
if(lt
==TYINT
&& pt
==TYLONG
)
if(pt
==TYDREAL
&& lt
==TYREAL
)
if(lp
->headblock
.tag
==TEXPR
&&
lp
->exprblock
.opcode
==OPCONV
&&
lp
->exprblock
.leftp
->headblock
.vtype
==TYDREAL
)
putx(lp
->exprblock
.leftp
);
if(lt
==TYCHAR
&& lp
->headblock
.tag
==TEXPR
&&
lp
->exprblock
.opcode
==OPCALL
)
p
->exprblock
.leftp
= putcall(lp
);
lt
= lp
->headblock
.vtype
;
if(p
->headblock
.tag
==TEXPR
&& p
->exprblock
.opcode
==OPCONV
)
if(lp
->headblock
.tag
!= TADDR
)
tp
= mktemp(lp
->headblock
.vtype
, lp
->headblock
.vleng
);
putx( mkexpr(OPASSIGN
, cpexpr(tp
), lp
) );
if( (k
= ops2
[p
->exprblock
.opcode
]) <= 0)
fatali("putop: invalid opcode %d", p
->exprblock
.opcode
);
putx(p
->exprblock
.leftp
);
putx(p
->exprblock
.rightp
);
p2op(k
, types2
[p
->exprblock
.vtype
]);
frexpr(p
->exprblock
.vleng
);
p
= mkconv(t
, fixtype(p
));
(t
==TYSHORT
? P2SHORT
: (t
==TYLONG
? P2LONG
: P2DREAL
)) );
struct Addrblock
*t1
, *t2
;
if(!ISICON(p
->exprblock
.rightp
) ||
(k
= p
->exprblock
.rightp
->constblock
.const.ci
)<2)
fatal("putpower: bad call");
base
= p
->exprblock
.leftp
;
type
= base
->headblock
.vtype
;
putassign(cpexpr(t1
), cpexpr(base
) );
for( ; (k
&1)==0 && k
>2 ; k
>>=1 )
putx( mkexpr(OPSTAR
, cpexpr(t1
), cpexpr(t1
)) );
putassign(cpexpr(t2
), cpexpr(t1
));
putx( mkexpr(OPSTAR
, cpexpr(t2
),
mkexpr(OPSTAR
, cpexpr(t1
), cpexpr(t1
)) ));
putcomma(ncomma
, type
, NO
);
LOCAL
struct Addrblock
*intdouble(p
, ncommap
)
register struct Addrblock
*t
;
t
= mktemp(TYDREAL
, NULL
);
register struct Exprblock
*p
;
register struct Addrblock
*lp
, *rp
;
lp
= putcx1(p
->leftp
, &ncomma
);
rp
= putcx1(p
->rightp
, &ncomma
);
putassign(realpart(lp
), realpart(rp
));
if( ISCOMPLEX(p
->vtype
) )
putassign(imagpart(lp
), imagpart(rp
));
putcomma(ncomma
, TYREAL
, NO
);
struct Addrblock
*putcx1();
putaddr( putcx1(p
, &ncomma
), NO
);
putcomma(ncomma
, TYINT
, NO
);
LOCAL
struct Addrblock
*putcx1(p
, ncommap
)
struct Addrblock
*q
, *lp
, *rp
;
register struct Addrblock
*resp
;
struct Constblock
*mkrealcon();
if( ISCOMPLEX(p
->constblock
.vtype
) )
resp
= mktemp(tyint
, NULL
);
putassign( cpexpr(resp
), p
->addrblock
.memoffset
);
p
->addrblock
.memoffset
= resp
;
if( ISCOMPLEX(p
->exprblock
.vtype
) )
resp
= mktemp(TYDREAL
, NO
);
putassign( cpexpr(resp
), p
);
fatali("putcx1: bad tag %d", p
->headblock
.tag
);
opcode
= p
->exprblock
.opcode
;
if(opcode
==OPCALL
|| opcode
==OPCCALL
)
else if(opcode
== OPASSIGN
)
resp
= mktemp(p
->exprblock
.vtype
, NULL
);
if(lp
= putcx1(p
->exprblock
.leftp
, ncommap
) )
ltype
= lp
->headblock
.vtype
;
if(rp
= putcx1(p
->headblock
.rightp
, ncommap
) )
rtype
= rp
->headblock
.vtype
;
putassign( realpart(resp
), mkexpr(OPNEG
, realpart(lp
), NULL
) );
putassign( imagpart(resp
), mkexpr(OPNEG
, imagpart(lp
), NULL
) );
putassign( realpart(resp
),
mkexpr(opcode
, realpart(lp
), realpart(rp
) ));
putassign( imagpart(resp
), imagpart(lp
) );
else if(ltype
< TYCOMPLEX
)
putassign( imagpart(resp
), imagpart(rp
) );
else putassign( imagpart(resp
),
mkexpr(OPNEG
, imagpart(rp
), NULL
) );
putassign( imagpart(resp
),
mkexpr(opcode
, imagpart(lp
), imagpart(rp
) ));
lp
= intdouble(lp
, ncommap
);
putassign( realpart(resp
),
mkexpr(OPSTAR
, cpexpr(lp
), realpart(rp
) ));
putassign( imagpart(resp
),
mkexpr(OPSTAR
, cpexpr(lp
), imagpart(rp
) ));
else if(rtype
< TYCOMPLEX
)
rp
= intdouble(rp
, ncommap
);
putassign( realpart(resp
),
mkexpr(OPSTAR
, cpexpr(rp
), realpart(lp
) ));
putassign( imagpart(resp
),
mkexpr(OPSTAR
, cpexpr(rp
), imagpart(lp
) ));
putassign( realpart(resp
), mkexpr(OPMINUS
,
mkexpr(OPSTAR
, realpart(lp
), realpart(rp
)),
mkexpr(OPSTAR
, imagpart(lp
), imagpart(rp
)) ));
putassign( imagpart(resp
), mkexpr(OPPLUS
,
mkexpr(OPSTAR
, realpart(lp
), imagpart(rp
)),
mkexpr(OPSTAR
, imagpart(lp
), realpart(rp
)) ));
/* fixexpr has already replaced all divisions
* by a complex by a function call
rp
= intdouble(rp
, ncommap
);
putassign( realpart(resp
),
mkexpr(OPSLASH
, realpart(lp
), cpexpr(rp
)) );
putassign( imagpart(resp
),
mkexpr(OPSLASH
, imagpart(lp
), cpexpr(rp
)) );
putassign( realpart(resp
), realpart(lp
) );
if( ISCOMPLEX(lp
->vtype
) )
q
= mkrealcon(TYDREAL
, 0.0);
putassign( imagpart(resp
), q
);
fatali("putcx1 of invalid opcode %d", opcode
);
register struct Exprblock
*p
;
register struct Addrblock
*lp
, *rp
;
lp
= putcx1(p
->leftp
, &ncomma
);
rp
= putcx1(p
->rightp
, &ncomma
);
q
= mkexpr( opcode
==OPEQ
? OPAND
: OPOR
,
mkexpr(opcode
, realpart(lp
), realpart(rp
)),
mkexpr(opcode
, imagpart(lp
), imagpart(rp
)) );
putcomma(ncomma
, TYINT
, NO
);
LOCAL
struct Addrblock
*putch1(p
, ncommap
)
register struct Addrblock
*t
;
struct Addrblock
*mktemp(), *putconst();
switch(p
->exprblock
.opcode
)
t
= mktemp(TYCHAR
, cpexpr(p
->exprblock
.vleng
) );
if(!ISICON(p
->exprblock
.vleng
)
|| p
->exprblock
.vleng
->constblock
.const.ci
!=1
|| ! INT(p
->exprblock
.leftp
->headblock
.vtype
) )
fatal("putch1: bad character conversion");
t
= mktemp(TYCHAR
, ICON(1) );
putop( mkexpr(OPASSIGN
, cpexpr(t
), p
) );
fatali("putch1: invalid opcode %d",
fatali("putch1: bad tag %d", p
->tag
);
putaddr( putch1(p
, &ncomma
) , NO
);
putcomma(ncomma
, TYCHAR
, YES
);
register struct Exprblock
*p
;
if( p
->rightp
->headblock
.tag
==TEXPR
&& p
->rightp
->exprblock
.opcode
==OPCONCAT
)
putcat(p
->leftp
, p
->rightp
);
else if( ISONE(p
->leftp
->headblock
.vleng
) && ISONE(p
->rightp
->headblock
.vleng
) )
putaddr( putch1(p
->leftp
, &ncomma
) , YES
);
putaddr( putch1(p
->rightp
, &ncomma
) , YES
);
putcomma(ncomma
, TYINT
, NO
);
putx( call2(TYINT
, "s_copy", p
->leftp
, p
->rightp
) );
putcomma(ncomma
, TYINT
, NO
);
register struct Exprblock
*p
;
if(ISONE(p
->leftp
->headblock
.vleng
) && ISONE(p
->rightp
->headblock
.vleng
) )
putaddr( putch1(p
->leftp
, &ncomma
) , YES
);
putaddr( putch1(p
->rightp
, &ncomma
) , YES
);
p2op(ops2
[p
->opcode
], P2CHAR
);
putcomma(ncomma
, TYINT
, NO
);
p
->leftp
= call2(TYINT
,"s_cmp", p
->leftp
, p
->rightp
);
register struct Addrblock
*lhs
;
struct Addrblock
*lp
, *cp
;
lp
= mktmpn(n
, TYLENG
, NULL
);
cp
= mktmpn(n
, TYADDR
, NULL
);
putct1(rhs
, lp
, cp
, &n
, &ncomma
);
putx( call4(TYSUBR
, "s_cat", lhs
, cp
, lp
, mkconv(TYLONG
, ICON(n
)) ) );
putcomma(ncomma
, TYINT
, NO
);
if(p
->headblock
.tag
==TEXPR
&& p
->exprblock
.opcode
==OPCONCAT
)
return( ncat(p
->exprblock
.leftp
) + ncat(p
->exprblock
.rightp
) );
LOCAL
putct1(q
, lp
, cp
, ip
, ncommap
)
register struct Addrblock
*lp
, *cp
;
struct Addrblock
*lp1
, *cp1
;
if(q
->headblock
.tag
==TEXPR
&& q
->exprblock
.opcode
==OPCONCAT
)
putct1(q
->exprblock
.leftp
, lp
, cp
, ip
, ncommap
);
putct1(q
->exprblock
.rightp
, lp
, cp
, ip
, ncommap
);
frexpr(q
->exprblock
.vleng
);
lp1
->memoffset
= mkexpr(OPPLUS
, lp1
->memoffset
, ICON(i
*SZLENG
));
cp1
->memoffset
= mkexpr(OPPLUS
, cp1
->memoffset
, ICON(i
*SZADDR
));
putassign( lp1
, cpexpr(q
->headblock
.vleng
) );
putassign( cp1
, addrof(putch1(q
,ncommap
)) );
register struct Addrblock
*p
;
ftnint offset
, simoffset();
if( ISERROR(p
) || (p
->memoffset
!=NULL
&& ISERROR(p
->memoffset
)) )
funct
= (p
->vclass
==CLPROC
? P2FUNCT
<<2 : 0);
offp
= (p
->memoffset
? cpexpr(p
->memoffset
) : NULL
);
offp
= mkexpr(OPSTAR
, ICON(FUDGEOFFSET
), offp
);
offset
= simoffset( &offp
);
offp
= mkconv(TYINT
, offp
);
offp
= mkconv(TYINT
, offp
);
p2oreg(offset
, AUTOREG
, type2
);
if(!indir
&& !offp
&& !offset
)
p2reg(AUTOREG
, type2
| P2PTR
);
p2reg(AUTOREG
, type2
| P2PTR
);
p2op(P2PLUS
, type2
| P2PTR
);
p2op(P2PLUS
, type2
| P2PTR
);
(ftnint
) (FUDGEOFFSET
*p
->memno
),
ARGREG
, type2
| P2PTR
| funct
);
p2op(P2PLUS
, type2
| P2PTR
);
p2op(P2PLUS
, type2
| P2PTR
);
(ftnint
) (FUDGEOFFSET
*p
->memno
),
p2reg(ARGREG
, type2
| P2PTR
);
(ftnint
) (FUDGEOFFSET
*p
->memno
), P2INT
);
p2op(P2PLUS
, type2
| P2PTR
);
putmem(p
, P2ICON
, offset
);
p2op(P2PLUS
, type2
| P2PTR
);
putmem(p
, (indir
? P2NAME
: P2ICON
), offset
);
fatal("attempt to take address of a register");
fatali("putaddr: invalid vstg %d", p
->vstg
);
LOCAL
putmem(p
, class, offset
)
funct
= (p
->headblock
.vclass
==CLPROC
? P2FUNCT
<<2 : 0);
type2
= types2
[p
->headblock
.vtype
];
if(p
->headblock
.vclass
== CLPROC
)
name
= memname(p
->addrblock
.vstg
, p
->addrblock
.memno
);
p2triple(P2ICON
, name
[0]!='\0', type2
|P2PTR
);
p2triple(P2NAME
, offset
!=0, type2
);
LOCAL
struct Addrblock
*putcall(p
)
chainp arglist
, charsp
, cp
;
int type
, type2
, ctype
, indir
;
type2
= types2
[type
= p
->vtype
];
indir
= (p
->opcode
== OPCCALL
);
arglist
= p
->rightp
->listblock
.listp
;
for(cp
= arglist
; cp
; cp
= cp
->nextp
)
cp
->datap
= q
= putconst(q
);
charsp
= hookup(charsp
, mkchain(cpexpr(q
->vleng
), 0) );
else if(q
->vclass
== CLPROC
)
charsp
= hookup(charsp
, mkchain( ICON(0) , 0));
fval
= mktemp(TYCHAR
, p
->vleng
);
err("adjustable character function");
else if( ISCOMPLEX(type
) )
fval
= mktemp(type
, NULL
);
ctype
= (fval
? P2INT
: type2
);
putaddr( cpexpr(fval
), NO
);
putx( mkconv(TYLENG
,p
->vleng
) );
for(cp
= arglist
; cp
; cp
= cp
->nextp
)
if(q
->tag
==TADDR
&& (indir
|| q
->vstg
!=STGREG
) )
putaddr(q
, indir
&& q
->vtype
!=TYCHAR
);
else if( ISCOMPLEX(q
->vtype
) )
t
= mktemp(q
->vtype
, q
->vleng
);
putassign( cpexpr(t
), q
);
putcomma(1, q
->vtype
, YES
);
for(cp
= charsp
; cp
; cp
= cp
->nextp
)
putx( mkconv(TYLENG
,cp
->datap
) );
p2op(n
>0 ? P2CALL
: P2CALL0
, ctype
);
register struct Exprblock
*p
;
struct Addrblock
*sp
, *tp
;
op
= (p
->opcode
==OPMIN
? OPLT
: OPGT
);
p0
= p
->leftp
->listblock
.listp
;
qp
= mkexpr(OPCOLON
, cpexpr(tp
), cpexpr(sp
));
qp
= mkexpr(OPQUEST
, mkexpr(op
, cpexpr(tp
),cpexpr(sp
)), qp
);
putassign( cpexpr(sp
), p0
->datap
);
for(p1
= p0
->nextp
; p1
; p1
= p1
->nextp
)
putassign( cpexpr(tp
), p1
->datap
);
putassign( cpexpr(sp
), cpexpr(qp
) );
putcomma(ncomma
, type
, NO
);
LOCAL
putcomma(n
, type
, indir
)
register expptr p
, lp
, rp
;
if( ! ISINT(p
->headblock
.vtype
) )
if(p
->headblock
.tag
==TEXPR
&& p
->exprblock
.opcode
==OPSTAR
)
rp
= p
->exprblock
.rightp
;
if(ISICON(rp
) && lp
->headblock
.tag
==TEXPR
&&
lp
->exprblock
.opcode
==OPPLUS
&& ISICON(lp
->exprblock
.rightp
))
p
->exprblock
.opcode
= OPPLUS
;
prod
= rp
->constblock
.const.ci
*
lp
->exprblock
.rightp
->constblock
.const.ci
;
lp
->exprblock
.rightp
->constblock
.const.ci
= rp
->constblock
.const.ci
;
rp
->constblock
.const.ci
= prod
;
if(p
->headblock
.tag
==TEXPR
&& p
->exprblock
.opcode
==OPPLUS
&&
ISICON(p
->exprblock
.rightp
))
rp
= p
->exprblock
.rightp
;
offset
+= rp
->constblock
.const.ci
;
if(p
->headblock
.tag
== TCONST
)
offset
+= p
->constblock
.const.ci
;
p2triple(P2ICON
, 0, type
);
p2oreg(offset
, reg
, type
)
p2triple(P2OREG
, reg
, type
);
p2triple(P2REG
, reg
, type
);
p2triple(P2PASS
, (strlen(s
) + FOUR
-1)/FOUR
, 0);
union { long int word
; char str
[FOUR
]; } u
;
word
|= ( (long int) type
) <<16;
union { long int word
[2]; char str
[8]; } u
;
u
.word
[0] = u
.word
[1] = 0;
for(i
= 0 ; i
<8 && *s
; ++i
)
write(fileno(textfile
), p2buff
, (p2bufp
-p2buff
)*sizeof(long int));