bool RecIntVar( void ) {
//===================
if( !IsVariable() )
return( false );
return( _IsTypeInteger( CITNode->typ ) );
}
void Unit(void) {
//===============
if( RecNOpn() && RecNextOpr( OPR_MUL ) ) {
if( ( StmtProc != PR_READ ) && ( StmtProc != PR_WRITE ) ) {
StmtErr( IL_STAR_NOT_ALLOWED );
}
AdvanceITPtr();
ReqNOpn();
} else {
ProcIOExpr();
if( !AError ) {
if( _IsTypeInteger( CITNode->typ ) && !RecArrName() ) {
GPassValue( FC_SET_UNIT );
} else if( CITNode->typ == FT_CHAR ) {
KWRememb( IO_INTERNAL );
CkAssignOk();
if( RecArrName() ) {
ChkAssumed();
GArrIntlSet();
} else {
GIntlSet();
}
if( ( StmtProc != PR_READ ) &&
( StmtProc != PR_WRITE ) &&
( StmtProc != PR_PRINT ) ) {
Error( IL_BAD_INTL );
}
} else {
Error( IL_NO_UNIT_ID );
}
}
}
}
static void ExpOp( TYPE typ1, TYPE typ2, OPTR op ) {
//======================================================
op = op;
if( !_IsTypeInteger( typ2 ) ) {
Convert();
GenExp( ResultType );
} else {
CnvTo( CITNode, ResultType, TypeSize( ResultType ) );
ExpI( typ1, &CITNode->value, ITIntValue( CITNode->link ) );
}
}
static void LogOp( TYPE typ1, TYPE typ2, OPTR op ) {
//======================================================
typ1 = typ1;
op -= OPTR_FIRST_LOGOP;
if( _IsTypeInteger( typ2 ) ) {
Convert();
XBitWiseTab[ op ]( &CITNode->value, &CITNode->link->value );
} else {
XLogicalTab[ op ]( &CITNode->value, &CITNode->link->value );
}
CITNode->opn.us = USOPN_CON; // this is required for .not. operator
}
void LogOp( TYPE typ1, TYPE typ2, OPTR op ) {
//==============================================
// Generate code for a relational operator.
bool flip;
op -= OPTR_FIRST_LOGOP;
flip = FALSE;
if( ( ( CITNode->opn.us & USOPN_WHERE ) == USOPN_SAFE ) &&
( ( CITNode->link->opn.us & USOPN_WHERE ) != USOPN_SAFE ) ) {
flip = TRUE;
}
PushOpn( CITNode->link );
if( typ1 == TY_NO_TYPE ) { // unary
if( _IsTypeInteger( typ2 ) ) {
EmitOp( FC_BIT_NOT );
} else {
EmitOp( FC_NOT );
}
GenType( CITNode->link );
SetOpn( CITNode, USOPN_SAFE );
} else {
PushOpn( CITNode );
if( _IsTypeInteger( typ2 ) ) {
EmitOp( FC_BITOPS + op );
} else {
EmitOp( FC_LOGOPS + op );
}
if( flip ) {
GenTypes( CITNode->link, CITNode );
} else {
GenTypes( CITNode, CITNode->link );
}
}
}
static bool UnaryMul( TYPE typ1, TYPE typ2 ) {
//============================================
if( typ1 > FT_EXTENDED )
return( FALSE );
if( !_IsTypeInteger( typ2 ) )
return( FALSE );
if( CITNode->link->opn.us != USOPN_CON )
return( FALSE );
if( ITIntValue( CITNode->link ) < 0 )
return( FALSE );
if( ITIntValue( CITNode->link ) > 8 )
return( FALSE );
return( TRUE );
}
void InitDo( signed_32 term )
{
// Initialize a DO or implied DO.
// Process "do i=e1,e2,e3" where e1, e2 and e3 are numeric expressions.
//
do_entry *do_pointer;
sym_id do_var;
if( ( StmtSw & SS_DATA_INIT ) == 0 ) {
CSHead->branch = NextLabel();
CSHead->bottom = NextLabel();
CSHead->cycle = NextLabel();
}
do_pointer = FMemAlloc( sizeof( do_entry ) );
CSHead->cs_info.do_parms = do_pointer;
do_pointer->do_term = term;
do_pointer->do_parm = NULL;
if( ReqDoVar() ) {
CkTypeDeclared();
do_var = CITNode->sym_ptr;
BIOutSymbol( do_var );
do_var->u.ns.flags |= SY_REFERENCED;
do_var->u.ns.u1.s.xflags |= SY_DEFINED;
if( do_var->u.ns.flags & SY_DO_PARM ) {
Error( DO_PARM_REDEFINED );
}
do_pointer->do_parm = do_var; // remember id of "i"
ReqNextOpr( OPR_EQU, EQ_NO_EQUALS );
if( StmtSw & SS_DATA_INIT ) {
if( !_IsTypeInteger( do_var->u.ns.u1.s.typ ) ) {
NameErr( DA_BAD_DO_VAR, do_var );
}
do_var = STShadow( do_var );
CITNode->flags = do_var->u.ns.flags;
}
CITNode->sym_ptr = do_var;
GDoInit( do_var->u.ns.u1.s.typ );
do_var->u.ns.flags |= SY_DO_PARM;
}
}
static void Unary( TYPE typ, OPTR opr ) {
//=======================================
// Generate code for unary plus or unary minus.
PushOpn( CITNode->link );
if( opr == OPTR_SUB ) { // unary minus
if( TypeCmplx( typ ) ) {
EmitOp( FC_CUMINUS );
} else {
EmitOp( FC_UMINUS );
}
GenType( CITNode->link );
} else if( ( _IsTypeInteger( CITNode->link->typ ) ) &&
( CITNode->link->size < sizeof( intstar4 ) ) ) {
// convert INTEGER*1 or INTEGER*2 to INTEGER*4
EmitOp( FC_CONVERT );
DumpTypes( CITNode->link->typ, CITNode->link->size, FT_INTEGER, sizeof( intstar4 ) );
}
SetOpn( CITNode, USOPN_SAFE );
}
static bool DoGenerate( TYPE typ1, TYPE typ2, uint *res_size ) {
//================================================================
if( CITNode->link->opr == OPR_EQU ) {
ResultType = typ1;
*res_size = CITNode->size;
if( (ASType & AST_ASF) || CkAssignOk() ) return( true );
return( false );
} else {
if( ( ( typ1 == FT_DOUBLE ) && ( typ2 == FT_COMPLEX ) ) ||
( ( typ2 == FT_DOUBLE ) && ( typ1 == FT_COMPLEX ) ) ) {
ResultType = FT_DCOMPLEX;
*res_size = TypeSize( FT_DCOMPLEX );
Extension( MD_DBLE_WITH_CMPLX );
} else if( ( ( typ1 == FT_TRUE_EXTENDED ) && ( typ2 == FT_COMPLEX ) )
|| ( ( typ2 == FT_TRUE_EXTENDED ) && ( typ1 == FT_COMPLEX ) )
|| ( ( typ1 == FT_TRUE_EXTENDED ) && ( typ2 == FT_DCOMPLEX ) )
|| ( ( typ2 == FT_TRUE_EXTENDED ) && ( typ1 == FT_DCOMPLEX ) ) ) {
ResultType = FT_XCOMPLEX;
*res_size = TypeSize( FT_XCOMPLEX );
Extension( MD_DBLE_WITH_CMPLX );
} else if( ( typ2 > typ1 ) || ( typ1 == FT_STRUCTURE ) || ( typ1 == FT_NO_TYPE ) ) {
ResultType = typ2;
*res_size = TypeSize( typ2 );
} else {
ResultType = typ1;
if( _IsTypeInteger( ResultType ) ) {
*res_size = CITNode->size;
if( *res_size < CITNode->link->size ) {
*res_size = CITNode->link->size;
}
} else
*res_size = TypeSize( typ1 );
}
return( true );
}
}
static void DoLoop( TYPE do_type ) {
//=====================================
// Generate code for DO statement or implied-DO.
do_entry *doptr;
uint do_size;
intstar4 incr;
intstar4 limit;
sym_id loop_ctrl;
TYPE e1_type;
uint e1_size;
itnode *e2_node;
itnode *e3_node;
bool e2_const;
doptr = CSHead->cs_info.do_parms;
do_size = CITNode->sym_ptr->u.ns.xt.size;
doptr->do_parm = CITNode->sym_ptr; // save ptr to do variable
AdvanceITPtr(); // bump past the '='
EatDoParm(); // process e1
PushOpn( CITNode );
e1_type = CITNode->typ;
e1_size = CITNode->size;
AdvanceITPtr();
if( ReqComma() ) {
EatDoParm(); // process e2
e2_const = CITNode->opn.us == USOPN_CON;
PushOpn( CITNode );
e2_node = CITNode;
AdvanceITPtr();
e3_node = NULL;
if( RecComma() ) {
EatDoParm(); // process e3
e3_node = CITNode;
if( !AError ) {
if( (CITNode->opn.us == USOPN_CON) && _IsTypeInteger( do_type ) ) {
incr = GetIntValue( CITNode );
doptr->incr_value = incr;
doptr->increment = NULL;
if( (OZOpts & OZOPT_O_FASTDO) == 0 ) {
if( e2_const ) {
limit = GetIntValue( e2_node );
if( NeedIncrement( limit, incr, do_type ) ) {
PushOpn( CITNode );
doptr->increment = StaticAlloc( do_size, do_type );
}
} else {
PushOpn( CITNode );
doptr->increment = StaticAlloc( do_size, do_type );
}
}
} else {
PushOpn( CITNode );
doptr->increment = StaticAlloc( do_size, do_type );
}
AdvanceITPtr();
}
} else {
if( _IsTypeInteger( do_type ) ) {
doptr->increment = NULL;
doptr->incr_value = 1;
if( (OZOpts & OZOPT_O_FASTDO) == 0 ) {
if( e2_const ) {
limit = GetIntValue( e2_node );
if( NeedIncrement( limit, 1, do_type ) ) {
PushConst( 1 );
doptr->increment = StaticAlloc( do_size, do_type );
}
} else {
PushConst( 1 );
doptr->increment = StaticAlloc( do_size, do_type );
}
}
} else {
PushConst( 1 );
doptr->increment = StaticAlloc( do_size, do_type );
}
}
EmitOp( FC_DO_BEGIN );
OutPtr( doptr->do_parm );
OutPtr( doptr->increment );
if( doptr->increment == NULL ) { // INTEGER do-loop with constant incr
loop_ctrl = StaticAlloc( do_size, do_type );
OutConst32( doptr->incr_value );
OutPtr( loop_ctrl );
} else {
if( _IsTypeInteger( do_type ) ) {
loop_ctrl = StaticAlloc( do_size, do_type );
} else {
loop_ctrl = StaticAlloc( sizeof( intstar4 ), FT_INTEGER );
}
doptr->iteration = loop_ctrl;
OutPtr( loop_ctrl );
if( e3_node == NULL ) {
DumpType( FT_INTEGER, TypeSize( FT_INTEGER ) );
} else {
GenType( e3_node );
}
}
GenType( e2_node );
DumpType( e1_type, e1_size );
OutU16( CSHead->branch );
OutU16( CSHead->bottom );
}
}
static void Generate( void ) {
//================================
// Generate code.
TYPE typ1;
TYPE typ2;
OPTR op;
OPR opr;
itnode *next;
unsigned_16 mask;
uint res_size;
next = CITNode->link;
if( next->opn.ds == DSOPN_PHI ) {
BadSequence();
} else {
typ1 = CITNode->typ;
typ2 = next->typ;
opr = next->opr;
if( RecNOpn() ) {
typ1 = FT_NO_TYPE;
CITNode->size = next->size;
if( (opr != OPR_PLS) && (opr != OPR_MIN) && (opr != OPR_NOT) ) {
BadSequence();
return;
}
}
op = OprNum[ opr ];
if( typ1 == FT_NO_TYPE ) {
mask = LegalOprsU[ typ2 - FT_FIRST ];
} else {
mask = LegalOprsB[ ( typ2 - FT_FIRST ) * LEGALOPR_TAB_COLS + typ1 - FT_FIRST ];
}
if( (( mask >> ( op - OPTR_FIRST ) ) & 1) == 0 ) {
// illegal combination
MoveDown();
if( typ1 == FT_NO_TYPE ) {
TypeErr( MD_UNARY_OP, typ2 );
} else if( typ1 == typ2 ) {
TypeErr( MD_ILL_OPR, typ1 );
} else {
TypeTypeErr( MD_MIXED, typ1, typ2 );
}
BackTrack();
} else if( DoGenerate( typ1, typ2, &res_size ) ) {
if( ( opr >= OPR_FIRST_RELOP ) && ( opr <= OPR_LAST_RELOP ) &&
( (ResultType == FT_COMPLEX) || (ResultType == FT_DCOMPLEX) ||
(ResultType == FT_XCOMPLEX) ) &&
( opr != OPR_EQ ) && ( opr != OPR_NE ) ) {
// can only compare complex with .EQ. and .NE.
Error( MD_RELOP_OPND_COMPLEX );
} else {
if( ( next->opn.us == USOPN_CON ) &&
( ( CITNode->opn.us == USOPN_CON ) || ( typ1 == FT_NO_TYPE ) ) ) {
// we can do some constant folding
ConstTable[ op ]( typ1, typ2, op );
} else {
// we have to generate code
if( CITNode->opn.us == USOPN_CON ) {
AddConst( CITNode );
} else if( next->opn.us == USOPN_CON ) {
AddConst( next );
}
GenOprTable[ op ]( typ1, typ2, op );
}
}
switch( opr ) {
case OPR_EQV:
case OPR_NEQV:
case OPR_OR:
case OPR_AND:
case OPR_NOT:
if( _IsTypeInteger( typ1 ) ) {
Extension( MD_LOGOPR_INTOPN );
}
break;
case OPR_EQ: // relational operators
case OPR_NE:
case OPR_LT:
case OPR_GE:
case OPR_LE:
case OPR_GT:
ResultType = FT_LOGICAL;
res_size = TypeSize( ResultType );
break;
case OPR_FLD:
case OPR_DPT:
// set result size to size of field
res_size = next->size;
FixFldNode();
break;
}
CITNode->size = res_size;
CITNode->typ = ResultType;
FixList();
}
}