/* INTERMEDIATE CODE GENERATION FOR S C JOHNSON C COMPILERS */
/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
static long int p2buff
[P2BUFFMAX
];
static long int *p2bufp
= &p2buff
[0];
static long int *p2bufend
= &p2buff
[P2BUFFMAX
];
p2pass( sprintf(buff
, "\t.globl\t_%s", s
) );
/* put out fake copy of left bracket line, to be redone later */
#if FAMILY==SCJ && OUTPUT==BINARY
headoffset
= ftell(textfile
);
p2triple(P2STMT
, (strlen(infname
)+FOUR
-1)/FOUR
, 0);
/* 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.
#if FAMILY==SCJ && OUTPUT==BINARY
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
))->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
->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();
p2icon(p
->const.ci
, types2
[type
]);
p2triple(P2ICON
, 1, P2INT
|P2PTR
);
p2name(memname(STGCONST
, (int) p
->const.ci
) );
if( ISCOMPLEX(p
->vtype
) )
if( ISCOMPLEX(p
->leftp
->vtype
) || ISCOMPLEX(p
->rightp
->vtype
) )
if( ISCOMPLEX(p
->leftp
->vtype
) || ISCOMPLEX(p
->rightp
->vtype
) )
if(INT(p
->leftp
->vtype
) && ISICON(p
->rightp
) &&
( (k
= log2(p
->rightp
->const.ci
))>0) )
if( ISCOMPLEX(p
->vtype
) )
if( ISCOMPLEX(p
->vtype
) )
else if( ISCOMPLEX(p
->leftp
->vtype
) )
realpart(putcx1(p
->leftp
, &ncomma
))));
putcomma(ncomma
, p
->vtype
, NO
);
fatal1("putx: invalid opcode %d", opc
);
fatal1("putx: impossible tag %d", p
->tag
);
switch(p
->opcode
) /* check for special cases and rewrite */
while(p
->tag
==TEXPR
&& p
->opcode
==OPCONV
&&
( (ISREAL(pt
)&&ISREAL(lt
)) ||
(INT(pt
)&&(ONEOF(lt
,MSKINT
|MSKADDR
|MSKCHAR
|M(TYSUBR
)))) ))
if(pt
==TYINT
&& lt
==TYLONG
)
if(lt
==TYINT
&& pt
==TYLONG
)
if(p
->tag
==TEXPR
&& p
->opcode
==OPCONV
)
tp
= mktemp(lp
->vtype
, lp
->vleng
);
putx( mkexpr(OPASSIGN
, cpexpr(tp
), lp
) );
if( (k
= ops2
[p
->opcode
]) <= 0)
fatal1("putop: invalid opcode %d", p
->opcode
);
p2op(k
, types2
[p
->vtype
]);
p
= mkconv(t
, fixtype(p
));
(t
==TYSHORT
? P2SHORT
: (t
==TYLONG
? P2LONG
: P2DREAL
)) );
struct addrblock
*t1
, *t2
;
if(!ISICON(p
->rightp
) || (k
= p
->rightp
->const.ci
)<2)
fatal("putpower: bad call");
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
;
if( ISCOMPLEX(p
->vtype
) )
resp
= mktemp(tyint
, NULL
);
putassign( cpexpr(resp
), p
->memoffset
);
if( ISCOMPLEX(p
->vtype
) )
resp
= mktemp(TYDREAL
, NO
);
putassign( cpexpr(resp
), p
);
fatal1("putcx1: bad tag %d", p
->tag
);
if(opcode
==OPCALL
|| opcode
==OPCCALL
)
else if(opcode
== OPASSIGN
)
resp
= mktemp(p
->vtype
, NULL
);
if(lp
= putcx1(p
->leftp
, ncommap
) )
if(rp
= putcx1(p
->rightp
, ncommap
) )
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
);
fatal1("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();
t
= mktemp(TYCHAR
, cpexpr(p
->vleng
) );
if(!ISICON(p
->vleng
) || p
->vleng
->const.ci
!=1
|| ! INT(p
->leftp
->vtype
) )
fatal("putch1: bad character conversion");
t
= mktemp(TYCHAR
, ICON(1) );
putop( mkexpr(OPASSIGN
, cpexpr(t
), p
) );
fatal1("putch1: invalid opcode %d", p
->opcode
);
fatal1("putch1: bad tag %d", p
->tag
);
putaddr( putch1(p
, &ncomma
) , NO
);
putcomma(ncomma
, TYCHAR
, YES
);
register struct exprblock
*p
;
if( p
->rightp
->tag
==TEXPR
&& p
->rightp
->opcode
==OPCONCAT
)
putcat(p
->leftp
, p
->rightp
);
else if( ISONE(p
->leftp
->vleng
) && ISONE(p
->rightp
->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
->vleng
) && ISONE(p
->rightp
->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
, ICON(n
) ) );
putcomma(ncomma
, TYINT
, NO
);
if(p
->tag
==TEXPR
&& p
->opcode
==OPCONCAT
)
return( ncat(p
->leftp
) + ncat(p
->rightp
) );
LOCAL
putct1(q
, lp
, cp
, ip
, ncommap
)
register struct addrblock
*lp
, *cp
;
struct addrblock
*lp1
, *cp1
;
if(q
->tag
==TEXPR
&& q
->opcode
==OPCONCAT
)
putct1(q
->leftp
, lp
, cp
, ip
, ncommap
);
putct1(q
->rightp
, lp
, cp
, ip
, ncommap
);
lp1
->memoffset
= mkexpr(OPPLUS
, lp1
->memoffset
, ICON(i
*SZLENG
));
cp1
->memoffset
= mkexpr(OPPLUS
, cp1
->memoffset
, ICON(i
*SZADDR
));
putassign( lp1
, cpexpr(q
->vleng
) );
putassign( cp1
, addrof(putch1(q
,ncommap
)) );
register struct addrblock
*p
;
ftnint offset
, simoffset();
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");
fatal1("putaddr: invalid vstg %d", p
->vstg
);
LOCAL
putmem(p
, class, offset
)
funct
= (p
->vclass
==CLPROC
? P2FUNCT
<<2 : 0);
type2
= types2
[p
->vtype
];
name
= memname(p
->vstg
, p
->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
->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
);
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(p
->tag
==TEXPR
&& p
->opcode
==OPSTAR
)
if(ISICON(rp
) && lp
->tag
==TEXPR
&& lp
->opcode
==OPPLUS
&& ISICON(lp
->rightp
))
prod
= rp
->const.ci
* lp
->rightp
->const.ci
;
lp
->rightp
->const.ci
= rp
->const.ci
;
if(p
->tag
==TEXPR
&& p
->opcode
==OPPLUS
&& ISICON(p
->rightp
))
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));