void AsgnChar( void ) {
//========================
// Perform character assignment.
itnode *save_cit;
uint num_args;
uint i;
uint j;
save_cit = CITNode;
AdvanceITPtr();
num_args = AsgnCat();
i = SrcChar( CITNode );
j = TargChar( save_cit );
if( ( num_args == 1 ) && ( i > 0 ) && ( j > 0 ) ) {
if( OptimalChSize( i ) && OptimalChSize( j ) && ( i == j ) ) {
PushOpn( save_cit );
EmitOp( FC_CHAR_1_MOVE );
DumpType( MapTypes( FT_INTEGER, i ), i );
GenChar1Op( CITNode );
if( ( CITNode->opn.us & USOPN_WHAT ) == USOPN_CON ) {
CITNode->sym_ptr->u.lt.flags &= ~LT_SCB_TMP_REFERENCE;
}
CITNode = save_cit;
} else {
#if ( _CPU == 386 || _CPU == 8086 )
if( j < i ) {
i = j;
}
CITNode = save_cit;
PushOpn( CITNode );
EmitOp( FC_CHAR_N_MOVE );
OutInt( i );
OutInt( j );
#else
CatArgs( num_args );
CITNode = save_cit;
PushOpn( CITNode );
EmitOp( FC_CAT );
OutU16( (uint_16)num_args );
#endif
}
} else {
CatArgs( num_args );
CITNode = save_cit;
PushOpn( CITNode );
EmitOp( FC_CAT );
OutU16( (uint_16)num_args );
}
}
sym_id SymLookup( char *name, int length ) {
//===========================================
// Lookup a symbol in the symbol table.
sym_id sym;
sym = STName( name, length );
if( ( sym->ns.flags & ( SY_TYPE | SY_INTRINSIC ) ) == 0 ) {
sym->ns.xt.size = ImplSize( *name );
sym->ns.typ = MapTypes( ImplType( *name ), sym->ns.xt.size );
}
return( sym );
}
static entry_pt *SubProgName( TYPE typ, unsigned_16 flags,
uint def_size, bool len_spec )
{
// Process the symbolic name of a SUBROUTINE or FUNCTION.
entry_pt *entry;
itnode *name_node;
itnode *next_node;
sym_id sym_ptr;
uint size;
sym_ptr = LkSym();
SubProgId = sym_ptr;
GSegLabel(); // must be before DumpStatement() so that ISN code for
if( Options & OPT_TRACE ) {
GSetSrcLine();
}
name_node = CITNode;
sym_ptr->u.ns.flags = flags;
name_node->flags = flags;
size = def_size;
next_node = CITNode->link;
if( !len_spec ) {
AdvanceITPtr();
if( !LenSpec( typ, &size ) ) {
size = StorageSize( typ );
}
next_node = CITNode;
}
sym_ptr->u.ns.xt.size = size;
name_node->size = size;
typ = MapTypes( typ, size );
sym_ptr->u.ns.u1.s.typ = typ;
name_node->typ = typ;
CITNode = name_node;
entry = AddEntryPt( sym_ptr );
CITNode = next_node;
return( entry );
}
void RelOp( TYPE typ1, TYPE typ2, OPTR optr ) {
//================================================
// Generate code for a relational operator.
bool flip;
bool associative;
bool char_1_cmp;
uint i;
uint j;
OPR opr_code;
FCODE op_code;
optr = optr;
// must check for "flip" before we call "CharLength" since they may
// call "PushOpn"
flip = FALSE;
if( ( ( CITNode->opn.us & USOPN_WHERE ) == USOPN_SAFE ) &&
( ( CITNode->link->opn.us & USOPN_WHERE ) != USOPN_SAFE ) ) {
flip = TRUE;
}
// must do "CITNode->link" first to get operands in the right order
i = CharLength( CITNode->link );
j = CharLength( CITNode );
opr_code = CITNode->link->opr;
if( ( opr_code == OPR_EQ ) || ( opr_code == OPR_NE ) ) {
char_1_cmp = OptimalChSize( i ) && OptimalChSize( j ) && ( i == j );
associative = TRUE;
} else {
char_1_cmp = (i == 1 ) && ( j == 1 );
associative = FALSE;
}
PushOpn( CITNode->link );
PushOpn( CITNode );
op_code = opr_code - OPR_FIRST_RELOP;
if( TypeCmplx( typ1 ) && TypeCmplx( typ2 ) ) {
op_code += FC_CC_RELOPS;
} else if( TypeCmplx( typ1 ) ) {
if( flip ) {
op_code += FC_XC_RELOPS;
} else {
op_code += FC_CX_RELOPS;
}
} else if( TypeCmplx( typ2 ) ) {
if( flip ) {
op_code += FC_CX_RELOPS;
} else {
op_code += FC_XC_RELOPS;
}
} else {
if( flip && !associative ) {
EmitOp( FC_FLIP );
}
if( typ1 == TY_CHAR ) {
if( char_1_cmp ) {
op_code += FC_CHAR_1_RELOPS;
} else {
op_code += FC_CHAR_RELOPS;
}
} else {
op_code += FC_RELOPS;
}
}
EmitOp( op_code );
if( char_1_cmp ) {
if( associative ) {
DumpType( MapTypes( TY_INTEGER, i ), i );
} else {
// Assert: comparing CHARACTER*1 with LT, LE, GT, or GE
// Consider: CHARACTER A/'a'/
// IF( A .lt. CHAR(159) ) PRINT *, 'OK'
// we must generate an unsigned comparison
DumpType( MapTypes( TY_LOGICAL, i ), i );
}
if( flip && associative ) {
GenChar1Op( CITNode->link );
GenChar1Op( CITNode );
} else {
GenChar1Op( CITNode );
GenChar1Op( CITNode->link );
}
} else if( typ1 != TY_CHAR ) {
if( flip && associative ) {
GenTypes( CITNode->link, CITNode );
} else {
GenTypes( CITNode, CITNode->link );
}
}
}
