static void FoldCatSequence( itnode *cit ) {
//==============================================
// Fold a sequnece of character constants.
uint size;
uint num;
itnode *save;
save = CITNode;
CITNode = cit;
num = 0;
size = 0;
for(;;) {
if( CITNode->opn.us != USOPN_CON ) break;
num++;
if( CITNode->typ != FT_CHAR ) {
TypeErr( MD_ILL_OPR, CITNode->typ );
} else {
size += CITNode->value.cstring.len;
}
AdvanceITPtr();
if( CITNode->opr != OPR_CAT ) break;
}
if( !AError ) {
CITNode = cit;
if( num > 1 ) {
ConstCat( size );
} else if( num == 1 ) {
AddConst( CITNode );
}
}
CITNode = save;
}
static int ScanCat( int *size_ptr ) {
//========================================
// Scan for strings to be concatenated.
uint cat_size;
itnode *itptr;
uint num_cats;
itptr = CITNode;
cat_size = 0;
num_cats = 0;
for(;;) {
if( CITNode->opn.ds == DSOPN_PHI ) {
// no operand (A = B // // C)
TypeErr( SX_WRONG_TYPE, FT_CHAR );
} else if( CITNode->typ != FT_CHAR ) {
TypeTypeErr( MD_MIXED, FT_CHAR, CITNode->typ );
} else if( ( CITNode->size == 0 ) && ( size_ptr != NULL ) ) {
// NULL 'size_ptr' means we are concatenating into a character
// variable so character*(*) variables are allowed.
OpndErr( CV_BAD_LEN );
} else {
cat_size += CITNode->size;
}
CITNode = CITNode->link;
num_cats++;
if( CITNode->opr != OPR_CAT ) break;
}
CITNode = itptr;
if( size_ptr != NULL ) {
*size_ptr = cat_size;
}
return( num_cats );
}
IFF IFSpecific( TYPE typ ) {
//==============================
IFF func;
IFF magic;
sym_id sym;
magic = 0;
func = CITNode->sym_ptr->ns.si.fi.index;
if( IFFlags[ func ].next == MAGIC ) {
magic = MAGIC;
} else if( IFFlags[ func ].flags & IF_GENERIC ) {
for( ; IFFlags[ func ].arg_typ != typ; ) {
func = IFFlags[ func ].next;
if( func == IF_NO_MORE ) {
TypeErr( LI_NO_SPECIFIC, typ );
return( magic );
}
}
sym = IFSymLookup( IFNames[ func ], strlen( IFNames[ func ] ) );
typ = IFFlags[ func ].ret_typ;
// merge flags - don't assign them from CITNode->sym_ptr->ns.flags
// since SY_IF_ARGUMENT may be set in sym->flags
// Consider: DOUBLE PRECISION X
// INTRINSIC DSIN
// CALL F( DSIN )
// PRINT *, SIN( X )
// when we process SIN( X ), the specific function DSIN already
// has SY_IF_ARGUMENT set
sym->ns.flags |= CITNode->sym_ptr->ns.flags | SY_REFERENCED;
sym->ns.u1.s.typ = typ;
sym->ns.xt.size = TypeSize( typ );
sym->ns.si.fi.index = func;
CITNode->sym_ptr = sym;
if( IFFlags[ func ].flags & IF_IN_LINE ) {
magic = MAGIC;
} else {
MarkIFUsed( func );
}
} else if( IFFlags[ func ].flags & IF_IN_LINE ) {
magic = MAGIC;
} else {
MarkIFUsed( func );
}
typ = IFFlags[ func ].ret_typ;
CITNode->typ = typ;
CITNode->size = TypeSize( typ );
return( magic );
}
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();
}
}
