static void FPEHandler( int sig_num, int xcpt ) {
//===========================================================
sig_num = sig_num;
if( (xcpt == FPE_STACKOVERFLOW) || (xcpt == FPE_STACKUNDERFLOW) ) {
RTErr( CP_TERMINATE );
} else if( xcpt == FPE_OVERFLOW ) {
RTErr( KO_FOVERFLOW );
} else if( xcpt == FPE_UNDERFLOW ) {
RTErr( KO_FUNDERFLOW );
} else if( xcpt == FPE_ZERODIVIDE ) {
RTErr( KO_FDIV_ZERO );
} else if( xcpt == FPE_SQRTNEG ) {
RTErr( LI_ARG_NEG );
} else if( xcpt == FPE_LOGERR ) {
RTErr( LI_ARG_GT_ZERO );
} else if( xcpt == FPE_MODERR ) {
RTErr( LI_ARG_GT_ZERO );
} else if( xcpt == FPE_IOVERFLOW ) {
RTErr( KO_IOVERFLOW );
#if (defined( __386__ ) && defined( __OS2__ )) || defined( __NT__ )
} else {
__ExceptionHandled = 0;
#endif
}
}
single __amath1err( unsigned int err_info, single *a1 ) {
//========================================================
a1 = a1;
if( err_info & M_DOMAIN ) {
switch( err_info & FP_FUNC_MASK ) {
case FP_FUNC_COTAN:
RTErr( KO_FOVERFLOW );
break;
}
}
RTErr( CP_TERMINATE );
return( 0.0 );
}
single __amath2err( unsigned int err_info, single *a1, single *a2 ) {
//====================================================================
a1 = a1; a2 = a2;
if( err_info & M_DOMAIN ) {
switch( err_info & FP_FUNC_MASK ) {
case FP_FUNC_MOD:
RTErr( LI_ARG_ZERO );
break;
}
}
RTErr( CP_TERMINATE );
return( 0.0 );
}
intstar4 __imath2err( unsigned int err_info, intstar4 *a1, intstar4 *a2 ) {
//=========================================================================
a1 = a1; a2 = a2;
if( err_info & M_DOMAIN ) {
switch( err_info & FP_FUNC_MASK ) {
case FP_FUNC_POW:
RTErr( EX_Z_2_NOT_POS );
break;
case FP_FUNC_MOD:
RTErr( LI_ARG_ZERO );
break;
}
}
RTErr( CP_TERMINATE );
return( 0 );
}
intstar4 ICHAR( string PGM *arg ) {
//========================================
// Convert character to integer.
if( arg->len > 1 ) {
RTErr( LI_ICHAR_ONE );
}
return( *arg->strptr );
}
dcomplex __qmath2err( unsigned int err_info, dcomplex *a1, dcomplex *a2 ) {
//=========================================================================
dcomplex res;
a1 = a1;
if( err_info & M_DOMAIN ) {
switch( err_info & FP_FUNC_MASK ) {
case FP_FUNC_POW:
if( a2->imagpart != 0 ) {
RTErr( EX_CZ_2_NOT_REAL );
} else {
RTErr( EX_Z_2_NOT_POS );
}
break;
}
}
RTErr( CP_TERMINATE );
res.realpart = 0.0;
res.imagpart = 0.0;
return( res );
}
static void R_FEnd( uint dummy1 , char dummy2 ) {
//========================
int revert;
if( IOCB->typ != PT_NOTYPE ) {
if( ( IOCB->flags & IOF_FMTREP ) == 0 ) {
RTErr( FM_REP );
}
IOCB->flags &= ~IOF_FMTREP;
revert = IOCB->fmtptr->fmt4.fld1;
IOCB->fmtptr = (fmt_desc PGM *)((char PGM *)IOCB->fmtptr -
revert + sizeof( fmt ));
R_NewRec();
} else {
IOCB->flags |= IOF_FMTDONE;
}
}
void SetIOCB( void ) {
//=========================
RTSysInit();
_AccessFIO();
_RWD_XcptFlags |= XF_IO_INTERRUPTABLE;
IOSysInit();
if( IOCB->flags & IOF_SETIOCB ) {
_PartialReleaseFIO();
return;
}
if( IOCB->flags & IOF_ACTIVE ) {
RTErr( IO_ACTIVE_ALREADY );
}
IOCB->fileinfo = NULL;
IOCB->set_flags = 0;
IOCB->status = 0;
IOCB->typ = 0;
IOCB->flags = IOF_ACTIVE | IOF_SETIOCB;
}
static void R_FEH( uint dummy1 , char dummy2 ) {
//======================
ftnfile *fcb;
uint len;
char PGM *str;
fcb = IOCB->fileinfo;
if( IOCB->flags & IOF_OUTPT ) {
len = IOCB->fmtptr->fmtstring.fld1;
if( fcb->col + len > fcb->bufflen ) {
IOErr( IO_BUFF_LEN );
}
str = IOCB->fmtptr->fmtstring.str;
SendStr( str, len );
} else {
RTErr( FM_NOT_INP );
}
R_ChkRecLen();
IOCB->fmtptr = (fmt_desc PGM *)((char PGM *)IOCB->fmtptr + sizeof( fmt4 ) +
len * sizeof( char ));
}
int IOMain( void (*io_rtn)( void ) ) {
//==================================
int io_stmt;
int io_stat;
// turn of IOF_SETIOCB so that we can detect "i/o already active" - by
// the time we call IOMain(), no one should be checking IOF_SETIOCB
IOCB->flags &= ~IOF_SETIOCB;
io_stmt = IOCB->iostmt;
if( ( Spawn( io_rtn ) != 0 ) && ( IOCB->fileinfo != NULL ) &&
( ( io_stmt == IO_READ ) || ( io_stmt == IO_WRITE ) ) ) {
IOCB->fileinfo->col = 0; // so next statement starts new record
if( ( io_stmt == IO_READ ) &&
_LogicalRecordOrganization( IOCB->fileinfo ) ) {
SkipLogicalRecord( IOCB->fileinfo );
}
IOCB->fileinfo->flags &= ~FTN_LOGICAL_RECORD; // in case we got EOF
if( IOCB->set_flags & SET_INTERNAL ) {
DiscoFile( IOCB->fileinfo );
}
}
if( __XcptFlags & XF_IO_INTERRUPTED ) {
RTErr( KO_INTERRUPT );
}
if( __XcptFlags & XF_FATAL_ERROR ) {
__ReleaseIOSys(); // so other threads can continue
Suicide();
}
io_stat = IOCB->status;
if( IOCB->set_flags & SET_IOSPTR ) { // set up IOSTAT
*IOCB->iosptr = io_stat;
}
if( io_stat == 0 ) {
while( IOCB->typ != PT_NOTYPE ) { // flush the io list
IOCB->typ = IOTypeRtn();
}
}
if( io_stmt == IO_READ ) {
// Consider: READ( 1, *, END=10 )
// ...
// 10 WRITE( 1, * ) 'write after EOF'
// the record number got incremented, so if an EOF condition
// was encounterd we must adjust the record number so that
// we don't get IO_PAST_EOF on the write
if( ( IOCB->set_flags & SET_INTERNAL ) == 0 ) {
// Consider: READ(5,*,IOSTAT=IOS) I
// READ(5,*) I
// If the first read gets EOF, then we must clear eof before
// doing the next read so that we don't get EOF again.
// Note: This is to be done only for files that don't have an
// EOF (like TERMINAL).
ClearEOF();
}
}
#if defined( __MT__ ) && !defined( _SA_LIBRARY )
// we cannot release the i/o system for READ/WRITE statements since
// co-routines are not done yet
if( (io_stmt != IO_READ) && (io_stmt != IO_WRITE) )
#endif
__ReleaseIOSys();
__XcptFlags &= ~XF_IO_INTERRUPTABLE;
return( io_stat );
}
static void AbnormalTerm( int dummy ) {
//==============================
RTErr( CP_TERMINATE );
}
static void ProcessIDivZ( void ) {
//==============================
RTErr( KO_IDIV_ZERO );
}
double __math2err( unsigned int err_info, double *a1, double *a2 ) {
//===================================================================
a2 = a2;
if( err_info & M_DOMAIN ) {
switch( err_info & FP_FUNC_MASK ) {
case FP_FUNC_SQRT:
RTErr( LI_ARG_NEG );
break;
case FP_FUNC_ASIN:
case FP_FUNC_ACOS:
RTErr( LI_ARG_LE_ONE );
break;
case FP_FUNC_ATAN2:
RTErr( LI_ARG_ZERO );
break;
case FP_FUNC_POW:
if( *a1 == 0.0 ) { // 0.0**y, y < 0
RTErr( EX_Z_2_NOT_POS );
} else { // base < 0 and non-integer power
RTErr( EX_NOT_INT_ARG );
}
break;
case FP_FUNC_DPOWI:
case FP_FUNC_IPOW:
RTErr( EX_Z_2_NOT_POS );
break;
case FP_FUNC_LOG:
case FP_FUNC_LOG10:
RTErr( LI_ARG_GT_ZERO );
break;
case FP_FUNC_MOD:
RTErr( LI_ARG_ZERO );
break;
case FP_FUNC_COTAN:
RTErr( KO_FOVERFLOW );
break;
}
} else if( err_info & M_SING ) {
switch( err_info & FP_FUNC_MASK ) {
case FP_FUNC_LOG:
case FP_FUNC_LOG10:
RTErr( LI_ARG_ZERO );
break;
}
} else if( err_info & M_OVERFLOW ) {
RTErr( KO_FOVERFLOW );
} else if( err_info & M_UNDERFLOW ) {
return( 0.0 );
}
RTErr( CP_TERMINATE );
return( 0.0 );
}
void _R_FError( int err_code ) {
//=================================
RTErr( err_code );
}
