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 ); }