void CpIntrinsic(void) {
//=====================
// Compile INTRINSIC statement.
// INTRINSIC FUNC {,FUNC1} . . .
unsigned_16 flags;
IFF func;
sym_id sym_ptr;
TYPE func_typ;
for(;;) {
if( ReqName( NAME_INTRINSIC ) ) {
func = IFLookUp();
if( func > 0 ) {
func_typ = IFType( func );
sym_ptr = LkSym();
flags = sym_ptr->u.ns.flags;
if( ( flags & SY_USAGE ) != 0 ) {
if( ( flags & SY_CLASS ) == SY_SUBPROGRAM ) {
if( ( flags & SY_INTRINSIC ) != 0 ) {
Error( SR_PREV_INTRNSC );
} else if( ( flags & SY_EXTERNAL ) != 0 ) {
Error( SR_INTRNSC_EXTRN );
}
} else {
IllName( sym_ptr );
}
} else if( flags & ERR_MASK ) {
IllName( sym_ptr );
} else if( ( flags & SY_TYPE ) &&
( sym_ptr->u.ns.u1.s.typ != func_typ ) ) {
NameTypeErr( TY_TYP_PREV_DEF, sym_ptr );
} else {
// we must OR the flags since SY_TYPE and/or SY_REFERENCED
// bit might already be set in the symbol table
sym_ptr->u.ns.flags |= SY_USAGE | SY_SUBPROGRAM |
SY_FUNCTION | SY_INTRINSIC;
func_typ = IFType( func );
sym_ptr->u.ns.u1.s.typ = func_typ;
sym_ptr->u.ns.xt.size = TypeSize( func_typ );
sym_ptr->u.ns.si.fi.index = func;
}
} else {
Error( SR_NOT_INTRNSC );
}
}
AdvanceITPtr();
if( !RecComma() ) {
break;
}
}
ReqEOS();
}
static void CkIntrinsic( void ) {
//=============================
// Check for intrinsic functions.
//
// CASE 1: integer abs
// y == abs( -1.0 ) -- this should call generic i.f. abs
//
// CASE 2: real iabs
// y == iabs( -1 ) -- this should give type mismatch error
//
sym_id sym_ptr;
TYPE typ;
IFF func;
sym_ptr = CITNode->sym_ptr;
if( ( CITNode->flags & SY_SUB_PARM ) == 0 ) {
typ = CITNode->typ;
func = IFLookUp();
if( func > 0 ) {
sym_ptr->ns.si.fi.index = func;
if( func == IF_ISIZEOF ) {
ASType |= AST_ISIZEOF;
}
sym_ptr->ns.si.fi.num_args = 0;
CITNode->flags |= SY_INTRINSIC;
IFChkExtension( func );
if( !IFIsGeneric( func ) ) {
CITNode->typ = IFType( func );
CITNode->size = TypeSize( CITNode->typ );
sym_ptr->ns.typ = CITNode->typ;
sym_ptr->ns.xt.size = CITNode->size;
if( ( CITNode->typ != typ ) && ( CITNode->flags & SY_TYPE ) ) {
Error( LI_WRONG_TYPE );
}
}
}
}
}
