diff options
Diffstat (limited to 'bwb_fnc.c')
-rw-r--r-- | bwb_fnc.c | 4721 |
1 files changed, 4721 insertions, 0 deletions
diff --git a/bwb_fnc.c b/bwb_fnc.c new file mode 100644 index 0000000..1fb6ee5 --- /dev/null +++ b/bwb_fnc.c @@ -0,0 +1,4721 @@ +/**************************************************************** + + bwb_fnc.c Interpretation Routines + for Predefined Functions + for Bywater BASIC Interpreter + + Copyright (c) 1993, Ted A. Campbell + Bywater Software + + email: tcamp@delphi.com + + Copyright and Permissions Information: + + All U.S. and international rights are claimed by the author, + Ted A. Campbell. + + This software is released under the terms of the GNU General + Public License (GPL), which is distributed with this software + in the file "COPYING". The GPL specifies the terms under + which users may copy and use the software in this distribution. + + A separate license is available for commercial distribution, + for information on which you should contact the author. + +***************************************************************/ + +/*---------------------------------------------------------------*/ +/* NOTE: Modifications marked "JBV" were made by Jon B. Volkoff, */ +/* 11/1995 (eidetics@cerf.net). */ +/* */ +/* Those additionally marked with "DD" were at the suggestion of */ +/* Dale DePriest (daled@cadence.com). */ +/* */ +/* Version 3.00 by Howard Wulf, AF5NE */ +/* */ +/* Version 3.10 by Howard Wulf, AF5NE */ +/* */ +/* Version 3.20 by Howard Wulf, AF5NE */ +/* */ +/*---------------------------------------------------------------*/ + + + +#include "bwbasic.h" + + +#ifndef RAND_MAX +#define RAND_MAX 32767 +#endif /* RAND_MAX */ + +#ifndef PI +#define PI 3.14159265358979323846 +#endif /* PI */ + +#define FromDegreesToRadians( X ) ( X * PI / 180.0 ) +#define FromRadiansToDegrees( X ) ( X * 180.0 / PI ) + +#define FromGradiansToRadians( X ) ( X * PI / 200.0 ) +#define FromRadiansToGradians( X ) ( X * 200.0 / PI ) + + +static time_t t; +static struct tm *lt; + + +/* ORD() Table 1 */ + + /* ACRONYM */ +typedef struct +{ + const int Value; + const char *Name; +} Acronym; + +#define NUM_ACRONYMS (34) + +Acronym AcronymTable[NUM_ACRONYMS] = { + {0, "NUL"}, + {1, "SOH"}, + {2, "STX"}, + {3, "ETX"}, + {4, "EOT"}, + {5, "ENQ"}, + {6, "ACK"}, + {7, "BEL"}, + {8, "BS"}, + {9, "HT"}, + {10, "LF"}, + {11, "VT"}, + {12, "FF"}, + {13, "CR"}, + {14, "SO"}, + {15, "SI"}, + {16, "DLE"}, + {17, "DC1"}, + {18, "DC2"}, + {19, "DC3"}, + {20, "DC4"}, + {21, "NAK"}, + {22, "SYN"}, + {23, "ETB"}, + {24, "CAN"}, + {25, "EM"}, + {26, "SUB"}, + {27, "ESC"}, + {28, "FS"}, + {29, "GS"}, + {30, "RS"}, + {31, "US"}, + {32, "SP"}, + {127, "DEL"} +}; + +/* ... ORD() */ + + + + +extern VariableType * +IntrinsicFunction_execute (int argc, VariableType * argv, + IntrinsicFunctionType * f) +{ + /* this is the generic handler for all intrinsic BASIC functions */ + /* Follow the BASIC naming conventions, so the code is easier to read and maintain */ + + /* assign reasonable default values */ + VariableType *argn; + /* Follow the BASIC naming conventions, so the code is easier to maintain */ + char *S; /* S$ - STRING functions */ + size_t s; /* LEN( S$ ) */ + DoubleType N; /* N - NUMBER functions */ + char *A; /* A$ - 1st STRING parameter */ + size_t a; /* LEN( A$ ) */ + char *B; /* B$ - 2nd STRING parameter */ + size_t b; /* LEN( B$ ) */ +#if FALSE /* keep third parameter */ + char *C; /* C$ - 3rd STRING parameter */ + size_t c; /* LEN( C$ ) */ +#endif + DoubleType X; /* X - 1st NUMBER parameter */ + IntegerType x; /* CINT( X ) */ + DoubleType Y; /* Y - 2nd NUMBER parameter */ + IntegerType y; /* CINT( Y ) */ +#if FALSE /* keep third parameter */ + DoubleType Z; /* Z - 3rd NUMBER parameter */ + IntegerType z; /* CINT( Z ) */ +#endif + + assert (argc >= 0); + assert (argv != NULL); + assert (f != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + assert(My->SYSOUT != NULL); + assert(My->SYSOUT->cfp != NULL); + assert(My->SYSPRN != NULL); + assert(My->SYSPRN->cfp != NULL); + assert(My->SYSIN != NULL); + assert(My->SYSIN->cfp != NULL); + + S = NULL; + s = 0; + N = 0; + A = NULL; + a = 0; + B = NULL; + b = 0; +#if FALSE /* keep third parameter */ + C = NULL; + c = 0; +#endif + X = 0; + x = 0; + Y = 0; + y = 0; +#if FALSE /* keep third parameter */ + Z = 0; + z = 0; +#endif + + if (f == NULL) + { + WARN_INTERNAL_ERROR; + return NULL; + } + if (argc < 0) + { + WARN_INTERNAL_ERROR; + return NULL; + } + /* the RETURN variable is the first variable in the 'argv' vaariable chain */ + if (argv == NULL) + { + WARN_INTERNAL_ERROR; + return NULL; + } + if (VAR_IS_STRING (argv)) + { + if (argv->Value.String == NULL) + { + WARN_INTERNAL_ERROR; + return NULL; + } + if (RESULT_BUFFER == NULL) + { + WARN_INTERNAL_ERROR; + return NULL; + } + RESULT_LENGTH = 0; + RESULT_BUFFER[RESULT_LENGTH] = NulChar; + } + else + { + if (argv->Value.Number == NULL) + { + WARN_INTERNAL_ERROR; + return NULL; + } + RESULT_NUMBER = 0; + } + argn = argv; + /* don't make a bad situation worse */ + if (My->IsErrorPending /* Keep This */ ) + { + /* An unrecognized NON-FATAL ERROR is pending. Just return a sane value. */ + /* LET N = LOG(SQR(X)) ' X = -1 */ + return argv; + } + /* so the following code is easier to read and maintain */ + { + /* assign actual values */ + if (f->ReturnTypeCode == StringTypeCode) + { + S = RESULT_BUFFER; + s = RESULT_LENGTH; + } + else + { + N = RESULT_NUMBER; + } + if (f->ParameterCount == 255 /* (...) */ ) + { + /* ... VARIANT number of parameters */ + } + else + { + int i; + int StrCount; /* count of STRING parameters - NEVER > 3 */ + int NumCount; /* count of NUMBER parameters - NEVER > 3 */ + ParamTestType ParameterTests; + + StrCount = 0; + NumCount = 0; + ParameterTests = f->ParameterTests; + for (i = 0; i < argc && i < MAX_TESTS && My->IsErrorPending == FALSE; + i++) + { + argn = argn->next; + if (argn == NULL) + { + WARN_INTERNAL_ERROR; + return NULL; + } + if (VAR_IS_STRING (argn)) + { + if (argn->Value.String == NULL) + { + WARN_INTERNAL_ERROR; + return NULL; + } + StrCount++; + switch (StrCount) + { + case 1: + /* 1st STRING parameter = A$ */ + A = PARAM_BUFFER; + a = PARAM_LENGTH; + if (StringLengthCheck (ParameterTests, a)) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + A[a] = NulChar; + } + break; + case 2: + /* 2nd STRING parameter = B$ */ + B = PARAM_BUFFER; + b = PARAM_LENGTH; + if (StringLengthCheck (ParameterTests, b)) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + B[b] = NulChar; + } + break; +#if FALSE /* keep third parameter */ + case 3: + /* 3rd STRING parameter = C$ */ + /* not currently used */ + C = PARAM_BUFFER; + c = PARAM_LENGTH; + if (StringLengthCheck (ParameterTests, c)) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + C[c] = NulChar; + } + break; +#endif + default: + /* Nth STRING parameter = ERROR */ + WARN_ILLEGAL_FUNCTION_CALL; + break; + } + } + else + { + if (argn->Value.Number == NULL) + { + WARN_INTERNAL_ERROR; + return NULL; + } + NumCount++; + switch (NumCount) + { + case 1: + /* 1st NUMBER parameter = X */ + X = PARAM_NUMBER; + if (NumberValueCheck (ParameterTests, X)) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + DoubleType R; + R = bwb_rint (X); + if (R < INT_MIN || R > INT_MAX) + { + /* certainly not a + * classic BASIC + * integer */ + } + else + { + /* Many classic BASIC + * intrinsic + * functions use the + * rounded integer + * value. */ + x = (int) R; + } + } + break; + case 2: + /* 2nd NUMBER parameter = Y */ + Y = PARAM_NUMBER; + if (NumberValueCheck (ParameterTests, Y)) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + DoubleType R; + R = bwb_rint (Y); + if (R < INT_MIN || R > INT_MAX) + { + /* certainly not a + * classic BASIC + * integer */ + } + else + { + /* Many classic BASIC + * intrinsic + * functions use the + * rounded integer + * value. */ + y = (int) R; + } + } + break; +#if FALSE /* keep third parameter */ + case 3: + /* 3rd NUMBER parameter = Z */ + /* not currently used */ + Z = PARAM_NUMBER; + if (NumberValueCheck (ParameterTests, Z)) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + DoubleType R; + R = bwb_rint (Z); + if (R < INT_MIN || R > INT_MAX) + { + /* certainly not a + * classic BASIC + * integer */ + } + else + { + /* Many classic BASIC + * intrinsic + * functions use the + * rounded integer + * value. */ + z = (int) R; + } + } + break; +#endif + default: + /* Nth NUMBER parameter = ERROR */ + WARN_ILLEGAL_FUNCTION_CALL; + break; + } + } + ParameterTests = ParameterTests >> 4; + } + } + } + if (My->IsErrorPending /* Keep This */ ) + { + /* An unrecognized NON-FATAL ERROR is pending. Just return a sane value. */ + /* LET N = LOG(SQR(X)) ' X = -1 */ + return argv; + } + /* + ** + ** all parameters have been checked and are OK + ** execute the intrinsic function + ** + */ + switch (f->FunctionID) + { + /* + ** + ** ALL paramters have been checked + ** for TYPE MISMATCH and INVALID RANGE. + ** ONLY A HANDFUL OF ERRORS CAN OCCUR + ** + */ + case 0: + { + /* INTERNAL ERROR */ + WARN_INTERNAL_ERROR; + } + break; + case F_ARGC_N: + /* N = ARGC */ + { + /* determine number of parameters to the current USER DEFINED FUNCTION */ + int n; + n = 0; + if (My->StackHead != NULL) + { + int Loop; + StackType *StackItem; + Loop = TRUE; + for (StackItem = My->StackHead; StackItem != NULL && Loop == TRUE; + StackItem = StackItem->next) + { + if (StackItem->LoopTopLine != NULL) + { + switch (StackItem->LoopTopLine->cmdnum) + { + case C_FUNCTION: + case C_SUB: + /* we have checked all the way to a FUNCTION or SUB boundary */ + /* FOUND */ + { + VariableType *v; + + for (v = StackItem->local_variable; v != NULL && Loop == TRUE; + v = v->next) + { + n++; + } + } + Loop = FALSE; + break; + } + } + } + } + n--; /* FUNCTION or SUB name */ + N = n; + } + break; + case F_ARGT4_X_S: + /* S$ = ARGT$( X ) */ + { + /* determine parameter type to the current USER DEFINED FUNCTION */ + int Found; + int n; + Found = FALSE; + n = 0; + s = 0; + if (x < 1) + { + /* bad param number */ + } + else if (My->StackHead != NULL) + { + int Loop; + StackType *StackItem; + Loop = TRUE; + for (StackItem = My->StackHead; StackItem != NULL && Loop == TRUE; + StackItem = StackItem->next) + { + if (StackItem->LoopTopLine != NULL) + { + switch (StackItem->LoopTopLine->cmdnum) + { + case C_FUNCTION: + case C_SUB: + /* we have checked all the way to a FUNCTION or SUB boundary */ + /* FOUND */ + { + VariableType *v; + + + for (v = StackItem->local_variable; v != NULL && Loop == TRUE; + v = v->next) + { + if (n == x) + { + char Char; + Char = TypeCode_to_Char (v->VariableTypeCode); + if (Char) + { + S[0] = Char; + s = 1; + Found = TRUE; + } + Loop = FALSE; + } + n++; + } + } + Loop = FALSE; + break; + } + } + } + } + if (Found == FALSE) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + } + break; + + case F_ARGV4_X_S: + /* S$ = ARGV$( X ) */ + { + /* determine parameter value to the current + * USER DEFINED FUNCTION */ + int Found; + int n; + Found = FALSE; + n = 0; + if (x < 1) + { + /* bad param number */ + } + else if (My->StackHead != NULL) + { + int Loop; + StackType *StackItem; + Loop = TRUE; + for (StackItem = My->StackHead; StackItem != NULL && Loop == TRUE; + StackItem = StackItem->next) + { + if (StackItem->LoopTopLine != NULL) + { + switch (StackItem->LoopTopLine->cmdnum) + { + case C_FUNCTION: + case C_SUB: + /* we have checked all the way to a FUNCTION or SUB boundary */ + /* FOUND */ + { + VariableType *v; + + + for (v = StackItem->local_variable; v != NULL && Loop == TRUE; + v = v->next) + { + if (n == x) + { + if (VAR_IS_STRING (v)) + { + s = v->Value.String->length; + bwb_memcpy (S, v->Value.String->sbuffer, s); + Found = TRUE; + } + else + { + } + Loop = FALSE; + } + n++; + } + } + Loop = FALSE; + break; + } + } + } + } + if (Found == FALSE) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + } + break; + + case F_ARGV_X_N: + /* S$ = ARGV( X ) */ + { + /* determine parameter value to the current USER DEFINED FUNCTION */ + int Found; + int n; + Found = FALSE; + n = 0; + if (x < 1) + { + /* bad param number */ + } + else if (My->StackHead != NULL) + { + int Loop; + StackType *StackItem; + Loop = TRUE; + for (StackItem = My->StackHead; StackItem != NULL && Loop == TRUE; + StackItem = StackItem->next) + { + if (StackItem->LoopTopLine != NULL) + { + switch (StackItem->LoopTopLine->cmdnum) + { + case C_FUNCTION: + case C_SUB: + /* we have checked all the way to a FUNCTION or SUB boundary */ + /* FOUND */ + { + VariableType *v; + + + for (v = StackItem->local_variable; v != NULL && Loop == TRUE; + v = v->next) + { + if (n == x) + { + if (VAR_IS_STRING (v)) + { + } + else + { + N = *v->Value.Number; + Found = TRUE; + } + Loop = FALSE; + } + n++; + } + } + Loop = FALSE; + break; + } + } + } + } + if (Found == FALSE) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + } + break; + case F_BASE_N: + /* N = BASE */ + { + /* PNONE */ + N = My->CurrentVersion->OptionBaseInteger; /* implicit lower bound */ + } + break; + case F_RESIDUE_N: + /* N = RESIDUE */ + { + /* PNONE */ + N = My->RESIDUE; /* Residue of the last integer divide */ + } + case F_DIGITS_X_N: + /* N = DIGITS( X ) */ + { + /* P1BYT */ + if (x == 0) + { + /* default */ + x = SIGNIFICANT_DIGITS; + } + if (x < MINIMUM_DIGITS || x > MAXIMUM_DIGITS) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + My->OptionDigitsInteger = x; + } + } + break; + case F_SCALE_X_N: + case F_PRECISION_X_N: + /* N = SCALE( X ) */ + /* N = PRECISION( X ) */ + { + /* P1BYT */ + if (x < MINIMUM_SCALE || x > MAXIMUM_SCALE) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + My->OptionScaleInteger = x; + } + } + break; + case F_DIGITS_X_Y_N: + /* N = DIGITS( X, Y ) */ + { + /* P1BYT | P2BYT */ + if (x == 0) + { + /* default */ + x = SIGNIFICANT_DIGITS; + } + if (x < MINIMUM_DIGITS || x > MAXIMUM_DIGITS) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (y < MINIMUM_SCALE || y > MAXIMUM_SCALE) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + My->OptionDigitsInteger = x; + My->OptionScaleInteger = y; + } + } + break; + case F_ASC_A_N: + case F_ASCII_A_N: + case F_CODE_A_N: + /* N = ASC( A$ ) */ + /* N = ASCII( A$ ) */ + /* N = CODE( A$ ) */ + { + /* P1BYT */ + N = A[0]; + } + break; + case F_ASC_A_X_N: + /* N = ASC( A$, X ) */ + { + /* P1BYT|P2POS */ + x--; /* BASIC -> C */ + if (x < a) + { + N = A[x]; + } + else + { + WARN_ILLEGAL_FUNCTION_CALL; + } + } + break; + case F_CDBL_X_N: + /* N = CDBL( X ) */ + { + /* P1DBL */ + N = X; + } + break; + case F_CSNG_X_N: + /* N = CSNG( X ) */ + { + /* P1FLT */ + N = X; + } + break; + case F_CCUR_X_N: + /* N = CCUR( X ) */ + { + /* P1CUR */ + N = bwb_rint (X); + } + break; + case F_CLNG_X_N: + /* N = CLNG( X ) */ + { + /* P1LNG */ + N = bwb_rint (X); + } + break; + case F_CINT_X_N: + /* N = CINT( X ) */ + { + /* P1INT */ + N = bwb_rint (X); + } + break; + case F_MKD4_X_S: + /* S$ = MKD$( X ) */ + { + /* P1DBL */ + DoubleType x; + x = (DoubleType) X; + s = sizeof (DoubleType); + bwb_memcpy (S, &x, s); + } + break; + case F_MKS4_X_S: + /* S$ = MKS$( X ) */ + { + /* P1FLT */ + SingleType x; + x = (SingleType) X; + s = sizeof (SingleType); + bwb_memcpy (S, &x, s); + } + break; + case F_MKI4_X_S: + /* S$ = MKI$( X ) */ + { + /* P1INT */ + IntegerType x; + x = (IntegerType) bwb_rint (X); + s = sizeof (IntegerType); + bwb_memcpy (S, &x, s); + } + break; + case F_MKL4_X_S: + /* S$ = MKL$( X ) */ + { + /* P1LNG */ + LongType x; + x = (LongType) bwb_rint (X); + s = sizeof (LongType); + bwb_memcpy (S, &x, s); + } + break; + case F_MKC4_X_S: + /* S$ = MKC$( X ) */ + { + /* P1CUR */ + CurrencyType x; + x = (CurrencyType) bwb_rint (X); + s = sizeof (CurrencyType); + bwb_memcpy (S, &x, s); + } + break; + case F_CVD_A_N: + /* N = CVD( A$ ) */ + { + /* P1DBL */ + DoubleType n; + a = sizeof (DoubleType); + bwb_memcpy (&n, A, a); + N = n; + } + break; + case F_CVS_A_N: + /* N = CVS( X$ ) */ + { + /* P1FLT */ + SingleType n; + a = sizeof (SingleType); + bwb_memcpy (&n, A, a); + N = n; + } + break; + case F_CVI_A_N: + /* N = CVI( X$ ) */ + { + /* P1INT */ + IntegerType n; + a = sizeof (IntegerType); + bwb_memcpy (&n, A, a); + N = n; + } + break; + case F_CVL_A_N: + /* N = CVL( X$ ) */ + { + /* P1LNG */ + LongType n; + a = sizeof (LongType); + bwb_memcpy (&n, A, a); + N = n; + } + break; + case F_CVC_A_N: + /* N = CVC( X$ ) */ + { + /* P1CUR */ + CurrencyType n; + a = sizeof (CurrencyType); + bwb_memcpy (&n, A, a); + N = n; + } + break; + case F_ENVIRON4_A_S: + /* S$ = ENVIRON$( A$ ) */ + { + /* P1BYT */ + char *CharPointer; + + CharPointer = getenv (A); + if (CharPointer == NULL) + { + /* empty string */ + } + else + { + s = bwb_strlen (CharPointer); + if (s > MAXLEN) + { + WARN_STRING_TOO_LONG; /* F_ENVIRON4_A_S */ + s = MAXLEN; + } + if (s == 0) + { + /* empty string */ + } + else + { + bwb_memcpy (S, CharPointer, s); + } + } + } + break; + case F_ENVIRON_A_N: + /* ENVIRON A$ */ + { + /* P1BYT */ + + char *CharPointer; + + CharPointer = bwb_strchr (A, '='); + if (CharPointer == NULL) + { + /* missing required '=' */ + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + if (putenv (A) == -1) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + /* OK */ + N = 0; + } + } + } + break; + + case F_OPEN_A_X_B_Y_N: + /* OPEN "I"|"O"|"R"|"A", [#]n, filename [,rlen] */ + { + /* P1STR|P2NUM|P3STR|P4NUM */ + /* P1BYT|P2INT|P3BYT|P4INT */ + + while (*A == ' ') + { + A++; /* LTRIM$ */ + } + bwb_file_open (*A, x, B, y); + } + break; + case F_OPEN_A_X_B_N: + /* default LEN is 128 for RANDOM, 0 for all others */ + /* OPEN "I"|"O"|"R"|"A", [#]n, filename [,rlen] */ + { + /* P1STR|P2NUM|P3STR|P4NUM */ + /* P1BYT|P2INT|P3BYT|P4INT */ + y = 0; + while (*A == ' ') + { + A++; /* LTRIM$ */ + } + if (bwb_toupper (*A) == 'R') + { + /* default RANDOM record size */ + y = 128; + } + bwb_file_open (*A, x, B, y); + } + break; + case F_LOC_X_N: + /* N = LOC( X ) */ + { + /* P1INT */ + if (x <= 0) + { + /* Printer and Console */ + N = 0; + } + else + { + FileType *F; + + F = find_file_by_number (x); + if (F == NULL) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSIN) + { + N = 0; + } + else if (F == My->SYSOUT) + { + N = 0; + } + else if (F == My->SYSPRN) + { + N = 0; + } + else + { + FILE *fp; + fp = F->cfp; + N = ftell (fp); + if (My->CurrentVersion->OptionVersionValue & (G65 | G67 | G74)) + { + /* byte position, regardless of 'mode' */ + } + else if (F->DevMode == DEVMODE_RANDOM) + { + /* record number */ + if (F->width == 0) + { + /* byte position */ + } + else + { + N /= F->width; + } + } + else if (F->DevMode == DEVMODE_BINARY) + { + /* byte position */ + } + else + { + /* byte positiion / 128 */ + N /= 128; + } + N = floor (N); + N++; /* C to BASIC */ + } + } + } + break; + case F_SEEK_X_N: + /* N = SEEK( X ) */ + { + /* P1INT */ + if (x <= 0) + { + /* Printer and Console */ + N = 0; + } + else + { + FileType *F; + + F = find_file_by_number (x); + if (F == NULL) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSIN) + { + N = 0; + } + else if (F == My->SYSOUT) + { + N = 0; + } + else if (F == My->SYSPRN) + { + N = 0; + } + else + { + FILE *fp; + fp = F->cfp; + N = ftell (fp); + if (F->DevMode == DEVMODE_RANDOM) + { + /* record number */ + if (F->width > 0) + { + N /= F->width; + } + } + else + { + /* byte positiion */ + } + N = floor (N); + N++; /* C to BASIC */ + } + } + } + break; + case F_SEEK_X_Y_N: + /* SEEK X, Y */ + { + /* P1INT|P2INT */ + if (x <= 0) + { + /* Printer and Console */ + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + FileType *F; + + F = find_file_by_number (x); + if (F == NULL) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSIN) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSOUT) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSPRN) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (y < 1) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + long offset; + offset = y; + offset--; /* BASIC to C */ + if (F->DevMode == DEVMODE_RANDOM) + { + if (F->width > 0) + { + offset *= F->width; + } + } + if (fseek (F->cfp, offset, SEEK_SET) != 0) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + /* OK */ + N = 0; + } + } + } + } + break; + case F_LOF_X_N: + /* N = LOF( X ) */ + { + /* P1INT */ + if (x <= 0) + { + /* Printer and Console */ + N = 0; + } + else + { + FileType *F; + + F = find_file_by_number (x); + if (F == NULL) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSIN) + { + N = 0; + } + else if (F == My->SYSOUT) + { + N = 0; + } + else if (F == My->SYSPRN) + { + N = 0; + } + else + { + /* file size in bytes */ + FILE *fp; + long current; + long total; + fp = F->cfp; + current = ftell (fp); + fseek (fp, 0, SEEK_END); + total = ftell (fp); + if (total == current) + { + /* EOF */ + } + else + { + fseek (fp, current, SEEK_SET); + } + N = total; + } + } + } + break; + case F_EOF_X_N: + /* N = EOF( X ) */ + { + /* P1INT */ + if (x <= 0) + { + /* Printer and Console */ + N = 0; + } + else + { + FileType *F; + + F = find_file_by_number (x); + if (F == NULL) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSIN) + { + N = 0; + } + else if (F == My->SYSOUT) + { + N = 0; + } + else if (F == My->SYSPRN) + { + N = 0; + } + else + { + /* are we at the end? */ + N = bwb_is_eof (F->cfp); + } + } + } + break; + case F_FILEATTR_X_Y_N: + /* N = FILEATTR( X, Y ) */ + { + /* P1INT|P2INT */ + + if (x <= 0) + { + /* Printer and Console */ + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (y == 1) + { + FileType *F; + + F = find_file_by_number (x); + if (F == NULL) + { + /* normal CLOSED file */ + N = 0; + } + else + { + /* normal OPEN file */ + N = F->DevMode; + } + } + else if (y == 2) + { + N = 0; + } + else + { + WARN_ILLEGAL_FUNCTION_CALL; + } + } + break; + case F_CLOSE_X_N: + /* CLOSE X */ + { + /* P1INT */ + if (x <= 0) + { + /* Printer and Console */ + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + FileType *F; + + F = find_file_by_number (x); + if (F == NULL) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSIN) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSOUT) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSPRN) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + field_close_file (F); + file_clear (F); + N = 0; + } + } + } + break; + case F_RESET_N: + case F_CLOSE_N: + /* RESET */ + /* CLOSE */ + { + /* PNONE */ + FileType *F; + + for (F = My->FileHead; F != NULL; F = F->next) + { + field_close_file (F); + file_clear (F); + } + } + break; + case F_FREEFILE_N: + /* N = FREEFILE */ + { + /* PNONE */ + FileType *F; + + x = 0; + y = 0; + for (F = My->FileHead; F != NULL; F = F->next) + { + if (F->DevMode != DEVMODE_CLOSED) + { + if (F->FileNumber > x) + { + x = F->FileNumber; + } + y++; + } + } + /* 'x' is the highest FileNumber that is currently open */ + /* 'y' is the number of files that are currently open */ + x++; + if (y >= MAXDEV) + { + /* no more slots available */ + x = 0; + } + N = x; + } + break; + case F_GET_X_Y_N: + /* GET X, Y */ + { + /* P1INT|P2INT */ + if (x <= 0) + { + /* Printer and Console */ + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + FileType *F; + + F = find_file_by_number (x); + if (F == NULL) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSIN) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSOUT) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSPRN) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F->DevMode != DEVMODE_RANDOM) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (y < 1) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + long offset; + offset = y; + offset--; /* BASIC to C */ + if (F->DevMode == DEVMODE_RANDOM) + { + if (F->width > 0) + { + offset *= F->width; + } + } + if (fseek (F->cfp, offset, SEEK_SET) != 0) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + int i; + for (i = 0; i < F->width; i++) + { + F->buffer[i] = fgetc (F->cfp); + } + field_get (F); + N = 0; + } + } + } + } + break; + case F_GET_X_N: + if (My->CurrentVersion->OptionVersionValue & (D73)) + { + /* GET( X ) == ASC(INKEY$), X is ignored */ + /* P1ANY */ + int c; + + c = fgetc (My->SYSIN->cfp); + N = c; + } + else + { + /* GET X */ + /* P1INT */ + if (x <= 0) + { + /* Printer and Console */ + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + FileType *F; + + F = find_file_by_number (x); + if (F == NULL) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSIN) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSOUT) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSPRN) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F->DevMode != DEVMODE_RANDOM) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + { + int i; + for (i = 0; i < F->width; i++) + { + F->buffer[i] = fgetc (F->cfp); + } + field_get (F); + N = 0; + } + } + } + } + break; + case F_PUT_X_Y_N: + /* PUT X, Y */ + { + /* P1INT|P2INT */ + if (x <= 0) + { + /* Printer and Console */ + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + FileType *F; + + F = find_file_by_number (x); + if (F == NULL) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSIN) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSOUT) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSPRN) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F->DevMode != DEVMODE_RANDOM) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (y < 1) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + long offset; + offset = y; + offset--; /* BASIC to C */ + if (F->DevMode == DEVMODE_RANDOM) + { + if (F->width > 0) + { + offset *= F->width; + } + } + if (fseek (F->cfp, offset, SEEK_SET) != 0) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + int i; + field_put (F); + for (i = 0; i < F->width; i++) + { + fputc (F->buffer[i], F->cfp); + F->buffer[i] = ' '; /* flush */ + } + N = 0; + } + } + } + } + break; + case F_PUT_X_N: + if (My->CurrentVersion->OptionVersionValue & (D73)) + { + /* PUT( X ) == PRINT CHR$(X); */ + /* P1BYT */ + fputc (x, My->SYSOUT->cfp); + N = x; + } + else + { + /* PUT X */ + /* P1INT */ + if (x <= 0) + { + /* Printer and Console */ + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + FileType *F; + + F = find_file_by_number (x); + if (F == NULL) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSIN) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSOUT) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F == My->SYSPRN) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (F->DevMode != DEVMODE_RANDOM) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + { + int i; + field_put (F); + for (i = 0; i < F->width; i++) + { + fputc (F->buffer[i], F->cfp); + F->buffer[i] = ' '; /* flush */ + } + N = 0; + } + } + } + } + break; + case F_WIDTH_X_N: + /* WIDTH X */ + { + /* P1BYT */ + /* console is #0 */ + My->SYSIN->width = x; + My->SYSIN->col = 1; + My->SYSOUT->width = x; + My->SYSOUT->col = 1; + N = 0; + } + break; + case F_WIDTH_X_Y_N: + /* WIDTH X, Y */ + { + /* WIDTH #file, cols */ + /* P1INT|PB2YT */ + if (x == 0) + { + My->SYSIN->width = y; + My->SYSOUT->width = y; + N = 0; + } + else if (x < 0) + { + My->SYSPRN->width = y; + N = 0; + } + else + { + FileType *F; + + F = find_file_by_number (x); + if (F == NULL) + { + /* WIDTH rows, cols */ + My->SCREEN_ROWS = x; + My->SYSIN->width = y; + My->SYSIN->col = 1; + My->SYSOUT->width = y; + My->SYSOUT->col = 1; + N = 0; + } + else if (F->DevMode == DEVMODE_RANDOM) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + /* WIDTH # file, cols */ + F->width = y; + F->col = 1; + N = 0; + } + } + } + break; + case F_INSTR_X_A_B_N: + case F_INSTR_A_B_X_N: + /* N = INSTR( X, A$, B$ ) */ + /* N = INSTR( A$, B$, X ) */ + { + /* P1POS */ + if (a == 0) + { + /* empty searched */ + } + else if (b == 0) + { + /* empty pattern */ + } + else if (b > a) + { + /* pattern is longer than searched */ + } + else + { + /* search */ + int i; + int n; + n = a - b; /* last valid search position */ + n++; + + x--; /* BASIC to C */ + A += x; /* advance to the start + * position */ + for (i = x; i < n; i++) + { + if (bwb_memcmp (A, B, b) == 0) + { + /* FOU ND */ + i++; /* C to BASIC */ + N = i; + i = n; /* exit for */ + } + A++; + } + } + } + break; + case F_INSTR_A_B_N: + case F_INDEX_A_B_N: + /* N = INSTR( A$, B$ ) */ + /* N = INDEX( A$, B$ ) */ + { + if (a == 0) + { + /* empty searched */ + } + else if (b == 0) + { + /* empty pattern */ + } + else if (b > a) + { + /* pattern is longer than searched */ + } + else + { + /* search */ + int i; + int n; + n = a - b; /* last valid search + * position */ + n++; + /* search */ + for (i = 0; i < n; i++) + { + if (bwb_memcmp (A, B, b) == 0) + { + /* FOU ND */ + i++; /* C to BASIC */ + N = i; + i = n; /* exit for */ + } + A++; + } + } + } + break; + case F_SPACE4_X_S: + case F_SPACE_X_S: + case F_SPA_X_S: + /* S$ = SPACE$( X ) */ + /* S$ = SPACE( X ) */ + /* S$ = SPA( X ) */ + { + /* P1LEN */ + if (x == 0) + { + /* no copies */ + } + else + { + bwb_memset (S, (char) ' ', x); + s = x; + } + } + break; + case F_STRING4_X_Y_S: + case F_STRING_X_Y_S: + case F_STR_X_Y_S: + /* S$ = STRING$( X, Y ) */ + /* S$ = STRING( X, Y ) */ + /* S$ = STR( X, Y ) */ + { + /* P1LEN|P2BYT */ + if (x == 0) + { + /* no copies */ + } + else + { + bwb_memset (S, (char) y, x); + s = x; + } + } + break; + case F_STRING4_X_A_S: + /* S$ = STRING$( X, A$ ) */ + { + /* P1LEN|P2BYT */ + if (x == 0) + { + /* no copies */ + } + else + { + bwb_memset (S, (char) A[0], x); + s = x; + } + } + break; + case F_LIN_X_S: + /* S$ = LIN( X ) */ + { + /* P1LEN */ + if (x == 0) + { + /* no copies */ + } + else + { + bwb_memset (S, (char) '\n', x); + s = x; + } + } + break; + case F_MID4_A_X_S: + case F_MID_A_X_S: + /* S$ = MID$( A$, X ) */ + /* S$ = MID( A$, X ) */ + { + /* P1ANY|P2POS */ + if (a == 0) + { + /* empty string */ + } + else if (x > a) + { + /* start beyond length */ + } + else + { + x--; /* BASIC to C */ + a -= x; /* nummber of characters to + * copy */ + A += x; /* pointer to first character + * to copy */ + bwb_memcpy (S, A, a); + s = a; + } + } + break; + case F_MID4_A_X_Y_S: + case F_MID_A_X_Y_S: + case F_SEG4_A_X_Y_S: + case F_SEG_A_X_Y_S: + /* S$ = MID$( A$, X, Y ) */ + /* S$ = MID( A$, X, Y ) */ + /* S$ = SEG$( A$, X, Y ) */ + /* S$ = SEG( A$, X, Y ) */ + { + /* P1ANY|P2POS|P3LEN */ + if (a == 0) + { + /* empty string */ + } + else if (x > a) + { + /* start beyond length */ + } + else if (y == 0) + { + /* empty string */ + } + else + { + x--; /* BASIC to C */ + a -= x; + /* maximum nummber of characters to + * copy */ + a = MIN (a, y); + A += x; + /* pointer to first character to copy */ + bwb_memcpy (S, A, a); + s = a; + } + } + break; + case F_LEFT4_A_X_S: + case F_LEFT_A_X_S: + /* S$ = LEFT$( A$, X ) */ + /* S$ = LEFT( A$, X ) */ + { + /* P1ANY|P2LEN */ + if (a == 0) + { + /* empty string */ + } + else if (x == 0) + { + /* empty string */ + } + else + { + a = MIN (a, x); + bwb_memcpy (S, A, a); + s = a; + } + } + break; + case F_RIGHT4_A_X_S: + case F_RIGHT_A_X_S: + /* S$ = RIGHT$( A$, X ) */ + /* S$ = RIGHT( A$, X ) */ + { + /* P1ANY|P2LEN */ + if (a == 0) + { + /* empty string */ + } + else if (x == 0) + { + /* empty string */ + } + else + { + x = MIN (a, x); + A += a; + A -= x; + bwb_memcpy (S, A, x); + s = x; + } + } + break; + case F_HEX_A_N: + /* N = HEX( A$ ) */ + { + if (a == 0) + { + /* empty string */ + } + else + { + N = strtoul (A, (char **) NULL, 16); + } + } + break; + case F_HEX4_X_S: + /* S$ = HEX$( X ) */ + { + /* P1NUM */ + /* P1INT */ + sprintf (S, "%X", x); + s = bwb_strlen (S); + } + break; + case F_HEX4_X_Y_S: + /* S$ = HEX$( X, Y ) */ + { + /* P1NUM | P2NUM */ + /* P1INT | P2BYT */ + if (y == 0) + { + /* empty string */ + } + else + { + sprintf (S, "%0*X", y, x); + s = bwb_strlen (S); + if (y < s) + { + A = S; + a = s - y; /* number of characters to trim */ + A += a; + bwb_strcpy (S, A); + } + } + } + break; + case F_OCT4_X_S: + /* S$ = OCT$( X ) */ + { + /* P1NUM */ + /* P1INT */ + sprintf (S, "%o", x); + s = bwb_strlen (S); + } + break; + case F_OCT4_X_Y_S: + /* S$ = OCT$( X, Y ) */ + { + /* P1NUM | P2NUM */ + /* P1INT | P2BYT */ + if (y == 0) + { + /* empty string */ + } + else + { + sprintf (S, "%0*o", y, x); + s = bwb_strlen (S); + if (y < s) + { + A = S; + a = s - y; /* number of characters to trim */ + A += a; + bwb_strcpy (S, A); + } + } + } + break; + case F_BIN4_X_S: + /* S$ = BIN$( X ) */ + { + /* P1NUM */ + /* P1INT */ + /* + ** + ** we break this problem into two parts: + ** 1. generate the default string + ** 2. trim leading zeroes on the left + ** + */ + unsigned long z; + z = (unsigned long) x; + A = My->NumLenBuffer; + a = sizeof (z) * CHAR_BIT; + s = a; + bwb_memset (A, '0', a); + A[a] = NulChar; + while (a) + { + /* look at the Least Significant Bit */ + a--; + if (z & 1) + { + A[a] = '1'; + } + z /= 2; + } + /* bwb_strcpy( S, A ); */ + /* same as HEX$(X) and OCT$(X), trim leading zeroes */ + while (*A == '0') + { + A++; + } + if (*A) + { + bwb_strcpy (S, A); + } + else + { + /* special case (x == 0), we trimmed all the zeroes above */ + S[0] = '0'; + s = 1; + } + } + break; + case F_BIN4_X_Y_S: + /* S$ = BIN$( X, Y ) */ + { + /* P1NUM | P2NUM */ + /* P1INT | P2BYT */ + /* + ** + ** we break this problem into two parts: + ** 1. generate the default string + ** 2. pad or trim on the left + ** + */ + if (y == 0) + { + /* empty string */ + } + else + { + unsigned long z; + z = (unsigned long) x; + A = My->NumLenBuffer; + a = sizeof (z) * CHAR_BIT; + s = a; + bwb_memset (A, '0', a); + A[a] = NulChar; + while (a) + { + /* look at the Least Significant Bit */ + a--; + if (z & 1) + { + A[a] = '1'; + } + z /= 2; + } + /* bwb_strcpy( S, A ); */ + if (y > s) + { + /* pad left */ + a = y - s; /* number of characters to pad (at least one) */ + bwb_memset (S, '0', a); + S[a] = NulChar; + bwb_strcat (S, A); + } + else + { + /* trim left (y <= s) */ + a = s - y; /* number of characters to trim (may be zero) */ + A += a; + bwb_strcpy (S, A); + } + s = y; + } + } + break; + case F_EDIT4_A_X_S: + /* S$ = EDIT$( A$, X ) */ + { + /* P1ANY|P2INT */ + if (x < 0) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (a == 0) + { + /* empty string */ + } + else if (x == 0) + { + /* no changes */ + bwb_memcpy (S, A, a); + s = a; + } + else + { + int n; + char IsSuppress; + char LastC; + n = a; + a = 0; + IsSuppress = NulChar; + LastC = NulChar; + + if (x & 8) + { + /* discard leading spaces and tabs */ + while (A[a] == ' ' || A[a] == '\t') + a++; + } + while (a < n) + { + char C; + + C = A[a]; + if (x & 256) + { + /* + ** suppress editing for characters within quotes. + */ + if (IsSuppress) + { + if (C == IsSuppress) + IsSuppress = NulChar; + goto VERBATIM; + } + if (C == '"') + { + IsSuppress = C; + goto VERBATIM; + } + if (C == '\'') + { + IsSuppress = C; + goto VERBATIM; + } + } + /* edit the character */ + if (x & 1) + { + /* discard parity bit */ + C = C & 0x7F; + } + if (x & 2) + { + /* discard all spaces and tabs */ + if (C == ' ') + goto SKIP; + if (C == '\t') + goto SKIP; + } + if (x & 4) + { + /* discard all carriage returns, line feeds, form feeds, deletes, escapes and nulls */ + if (C == '\r') + goto SKIP; + if (C == '\n') + goto SKIP; + if (C == '\f') + goto SKIP; + if (C == 127) + goto SKIP; + if (C == 26) + goto SKIP; + if (C == 0) + goto SKIP; + } + if (x & 16) + { + /* convert multiple spaces and tabs to one space */ + if (C == '\t') + C = ' '; + if (C == ' ' && LastC == ' ') + goto SKIP; + } + if (x & 32) + { + /* convert lower case to upper case */ + C = bwb_toupper (C); + } + if (x & 64) + { + /* convert left brackets to left parentheses and right brackes to right parentheses */ + if (C == '[') + C = '('; + if (C == ']') + C = ')'; + } + /* save results of editing */ + VERBATIM: + S[s] = C; + s++; + SKIP: + LastC = C; + a++; + } + if (x & 128) + { + /* discard trailing spaces and tabs */ + while (s > 0 && (S[s - 1] == ' ' || S[s - 1] == '\t')) + s--; + } + } + } + break; + case F_CHR_X_S: + case F_CHR4_X_S: + case F_CHAR4_X_S: + /* S$ = CHR( X ) */ + /* S$ = CHR$( X ) */ + /* S$ = CHAR$( X ) */ + + /* P1ANY */ + if (My->CurrentVersion->OptionVersionValue & (S70 | I70 | I73)) + { + /* IBM System/360 & System/370 BASIC dialects: the opposite of N = NUM( A$ ) */ + FormatBasicNumber (X, S); + s = bwb_strlen (S); + } + else + { + if (x < MINBYT || x > MAXBYT) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + S[0] = (char) x; + s = 1; + } + } + break; + case F_CHAR_X_Y_S: + /* S$ = CHAR( X, Y ) ' same as STRING$(Y,X) */ + { + /* P1BYT|P2LEN */ + if (y == 0) + { + /* no copies */ + } + else + { + bwb_memset (S, (char) x, y); + s = y; + } + } + break; + case F_LEN_A_N: + /* N = LEN( A$ ) */ + { + N = a; + } + break; + case F_POS_A_B_N: + /* N = POS( A$, B$ ) */ + { + if (b == 0) + { + /* empty pattern */ + N = 1; + } + else if (a == 0) + { + /* empty searched */ + } + else if (b > a) + { + /* pattern is longer than searched */ + } + else + { + /* search */ + int i; + int n; + n = a - b; /* last valid search + * position */ + n++; + /* search */ + for (i = 0; i < n; i++) + { + if (bwb_memcmp (A, B, b) == 0) + { + /* FOU ND */ + i++; /* C to BASIC */ + N = i; + i = n; /* exit for */ + } + A++; + } + } + } + break; + case F_MATCH_A_B_X_N: + /* N = POS( A$, B$, X ) */ + { + N = str_match (A, a, B, b, x); + } + break; + case F_POS_A_B_X_N: + /* N = POS( A$, B$, X ) */ + { + if (b == 0) + { + /* empty pattern */ + N = 1; + } + else if (a == 0) + { + /* empty searched */ + } + else if (b > a) + { + /* pattern is longer than searched */ + } + else + { + /* search */ + int i; + int n; + n = a - b; /* last valid search position */ + n++; + + /* search */ + x--; /* BASIC to C */ + A += x; /* advance to the start + * position */ + for (i = x; i < n; i++) + { + if (bwb_memcmp (A, B, b) == 0) + { + /* FOUND */ + N = i + 1; /* C to BASIC */ + i = n; /* exit for */ + } + A++; + } + } + } + break; + case F_VAL_A_N: + case F_NUM_A_N: + /* N = VAL( A$ ) */ + /* N = NUM( A$ ) */ + { + /* P1ANY */ + int n; /* number of characters read */ + DoubleType Value; + + n = 0; + if (sscanf (A, DecScanFormat, &Value, &n) == 1) + { + /* OK */ + N = Value; + } + else + { + /* not a number */ + if (My->CurrentVersion->OptionFlags & OPTION_BUGS_ON ) /* VAL("X") = 0 */ + { + /* IGNORE */ + N = 0; + } + else + { + /* ERROR */ + WARN_ILLEGAL_FUNCTION_CALL; + } + } + } + break; + case F_STR4_X_S: + case F_NUM4_X_S: + /* S$ = STR$( X ) */ + /* S$ = NUM$( X ) */ + { + /* P1ANY */ + FormatBasicNumber (X, S); + s = bwb_strlen (S); + } + break; + case F_DATE_N: + /* N = DATE ' YYYYDDD */ + { + /* PNONE */ + + /* ECMA-116 */ + time (&t); + lt = localtime (&t); + N = lt->tm_year; + N *= 1000; + N += lt->tm_yday; + N += 1; + } + break; + case F_DATE4_X_S: + case F_DATE4_S: + case F_DAT4_S: + /* S$ = DATE$( X ) ' value of X is ignored */ + /* S$ = DATE$ */ + /* S$ = DAT$ */ + { + /* PNONE */ + if (!is_empty_string (My->CurrentVersion->OptionDateFormat)) + { + time (&t); + lt = localtime (&t); + s = strftime (S, MAXLEN, My->CurrentVersion->OptionDateFormat, lt); + } + } + break; + case F_CLK_X_S: + case F_CLK4_S: + case F_TI4_S: + case F_TIME4_S: + case F_TIME4_X_S: + /* S$ = CLK(X) ' the value of paameter X is ignored */ + /* S$ = CLK$ */ + /* S$ = TI$ */ + /* S$ = TIME$ */ + /* S$ = TIME$(X) ' the value of paameter X is ignored */ + { + /* PNONE */ + if (!is_empty_string (My->CurrentVersion->OptionTimeFormat)) + { + time (&t); + lt = localtime (&t); + s = strftime (S, MAXLEN, My->CurrentVersion->OptionTimeFormat, lt); + } + } + break; + case F_TI_N: + case F_TIM_N: + case F_TIME_N: + case F_TIME_X_N: + case F_TIMER_N: + /* N = TI */ + /* N = TIM */ + /* N = TIME */ + /* N = TIME( X ) ' value of X is ignored */ + /* N = TIMER */ + /* N = CPU */ + { + /* PNONE */ + time (&t); + lt = localtime (&t); + if (My->CurrentVersion->OptionVersionValue & (G67 | G74)) + { + N = lt->tm_hour; + N *= 60; + N += lt->tm_min; + N *= 60; + N += lt->tm_sec; + /* number of seconds since midnight */ + N -= My->StartTimeInteger; + /* elapsed run time */ + } + else + { + N = lt->tm_hour; + N *= 60; + N += lt->tm_min; + N *= 60; + N += lt->tm_sec; + /* number of seconds since midnight */ + } + } + break; + case F_CLK_X_N: + /* N = CLK( X ) ' value of X is ignored */ + { + /* PNONE */ + time (&t); + lt = localtime (&t); + N = lt->tm_hour; + N *= 60; + N += lt->tm_min; + N *= 60; + N += lt->tm_sec; + N /= 3600; + /* decimal hours: 3:30 PM = 15.50 */ + } + break; + + case F_TIM_X_N: + /* N = TIM( X ) */ + { + /* P1BYT */ + time (&t); + lt = localtime (&t); + + if (My->CurrentVersion->OptionVersionValue & (G65 | G67 | G74)) + { + /* value of 'X' is ignored */ + N = lt->tm_hour; + N *= 60; + N += lt->tm_min; + N *= 60; + N += lt->tm_sec; + /* number of seconds since midnight */ + N -= My->StartTimeInteger; + /* elapsed run time */ + } + else + { + switch (x) + { + case 0: + /* TIM(0) == minute (0..59) */ + N += lt->tm_min; + break; + case 1: + /* TIM(1) == hour (0..23) */ + N = lt->tm_hour; + break; + case 2: + /* TIM(2) == day of year (1..366) */ + N = 1 + lt->tm_yday; + break; + case 3: + /* TIM(3) == year since 1900 (0..) */ + N = lt->tm_year; + break; + default: + WARN_ILLEGAL_FUNCTION_CALL; + } + } + } + break; + case F_COMMAND4_S: + /* S$ = COMMAND$ */ + { + S[0] = NulChar; + for (x = 0; x < 10 && My->COMMAND4[x] != NULL; x++) + { + if (x > 0) + { + bwb_strcat (S, " "); + } + bwb_strcat (S, My->COMMAND4[x]); + } + s = bwb_strlen (S); + } + break; + case F_COMMAND4_X_S: + /* S$ = COMMAND$(X) */ + if (x < 0 || x > 9) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + if (My->COMMAND4[x] == NULL) + { + s = 0; + } + else + { + bwb_strcpy (S, My->COMMAND4[x]); + s = bwb_strlen (My->COMMAND4[x]); + } + } + break; + case F_COSH_X_N: + case F_CSH_X_N: + case F_HCS_X_N: + /* N = COSH( X ) */ + /* N = CSH( X ) */ + /* N = HCS( X ) */ + { + /* P1ANY */ + N = cosh (X); + } + break; + case F_SINH_X_N: + case F_SNH_X_N: + case F_HSN_X_N: + /* N = SINH( X ) */ + /* N = SNH( X ) */ + /* N = HSN( X ) */ + { + /* P1ANY */ + N = sinh (X); + } + break; + case F_TANH_X_N: + case F_HTN_X_N: + /* N = TANH( X ) */ + /* N = HTN( X ) */ + { + /* P1ANY */ + N = tanh (X); + } + break; + case F_CLG_X_N: + case F_CLOG_X_N: + case F_LOG10_X_N: + case F_LGT_X_N: + /* N = CLG( X ) */ + /* N = CLOG( X ) */ + /* N = LOG10( X ) */ + /* N = LGT( X ) */ + { + /* P1GTZ */ + N = log10 (X); + } + break; + case F_SLEEP_X_N: + case F_WAIT_X_N: + case F_PAUSE_X_N: + /* N = SLEEP( X ) */ + /* N = WAIT( X ) */ + /* N = PAUSE( X ) */ + { + /* P1ANY */ + X = X * My->OptionSleepDouble; + if (X <= 0 || X > MAXINT) + { + /* do nothing */ + } + else + { + x = (int) bwb_rint (X); + sleep (x); + } + } + break; + case F_LOG2_X_N: + case F_LTW_X_N: + /* N = LOG2( X ) */ + /* N = LTW( X ) */ + { + /* P1GTZ */ + N = log (X) / log ((DoubleType) 2); + } + break; + case F_ACOS_X_N: + case F_ACS_X_N: + case F_ARCCOS_X_N: + /* N = ACOS( X ) */ + /* N = ACS( X ) */ + /* N = ARCCOS( X ) */ + { + /* P1ANY */ + if (X < -1 || X > 1) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + N = acos (X); + if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_DEGREES) + { + N = FromRadiansToDegrees (N); + } + else if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_GRADIANS) + { + N = FromRadiansToGradians (N); + } + } + } + break; + case F_ACSD_X_N: + /* N = ACSD( X ) */ + { + /* P1ANY */ + if (X < -1 || X > 1) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + N = acos (X); + /* result is always in DEGREES, regardless of OPTION ANGLE setting */ + N = FromRadiansToDegrees (N); + } + } + break; + case F_ACSG_X_N: + /* N = ACSG( X ) */ + { + /* P1ANY */ + if (X < -1 || X > 1) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + N = acos (X); + /* result is always in GRADIANS, regardless of OPTION ANGLE setting */ + N = FromRadiansToGradians (N); + } + } + break; + + case F_ASIN_X_N: + case F_ASN_X_N: + case F_ARCSIN_X_N: + /* N = ASIN( X ) */ + /* N = ASN( X ) */ + /* N = ARCSIN( X ) */ + { + /* P1ANY */ + if (X < -1 || X > 1) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + N = asin (X); + if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_DEGREES) + { + N = FromRadiansToDegrees (N); + } + else if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_GRADIANS) + { + N = FromRadiansToGradians (N); + } + } + } + break; + + + case F_ASND_X_N: + /* N = ASND( X ) */ + { + /* P1ANY */ + if (X < -1 || X > 1) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + N = asin (X); + /* result is always in DEGREES, regardless of OPTION ANGLE setting */ + N = FromRadiansToDegrees (N); + } + } + break; + case F_ASNG_X_N: + /* N = ASNG( X ) */ + { + /* P1ANY */ + if (X < -1 || X > 1) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + N = asin (X); + /* result is always in GRADIANS, regardless of OPTION ANGLE setting */ + N = FromRadiansToGradians (N); + } + } + break; + + + case F_COT_X_N: + /* N = COT( X ) ' = 1 / TAN( X ) */ + { + /* P1ANY */ + DoubleType T; + if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_DEGREES) + { + X = FromDegreesToRadians (X); + } + else if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_GRADIANS) + { + X = FromGradiansToRadians (X); + } + T = tan (X); + if (T == 0) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + N = 1.0 / T; + } + } + break; + case F_CSC_X_N: + /* N = CSC( X ) ' = 1 / SIN( X ) */ + { + /* P1ANY */ + DoubleType T; + if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_DEGREES) + { + X = FromDegreesToRadians (X); + } + else if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_GRADIANS) + { + X = FromGradiansToRadians (X); + } + T = sin (X); + if (T == 0) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + N = 1.0 / T; + } + } + break; + case F_SEC_X_N: + /* N = SEC( X ) ' = 1 / COS( X ) */ + { + /* P1ANY */ + DoubleType T; + if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_DEGREES) + { + X = FromDegreesToRadians (X); + } + else if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_GRADIANS) + { + X = FromGradiansToRadians (X); + } + T = cos (X); + if (T == 0) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + N = 1.0 / T; + } + } + break; + case F_UCASE4_A_S: + case F_UPPER4_A_S: + /* S$ = UCASE$( A$ ) */ + /* S$ = UPPER$( A$ ) */ + { + /* P1ANY */ + if (a == 0) + { + /* empty string */ + } + else + { + int i; + bwb_memcpy (S, A, a); + s = a; + /* BASIC allows embedded NULL + * characters */ + for (i = 0; i < a; i++) + { + S[i] = bwb_toupper (S[i]); + } + } + } + break; + case F_LCASE4_A_S: + case F_LOWER4_A_S: + /* S$ = LCASE$( A$ ) */ + /* S$ = LOWER$( A$ ) */ + { + /* P1ANY */ + if (a == 0) + { + /* empty string */ + } + else + { + int i; + bwb_memcpy (S, A, a); + s = a; + /* BASIC allows embedded NULL + * characters */ + for (i = 0; i < a; i++) + { + S[i] = bwb_tolower (S[i]); + } + } + } + break; + case F_ANGLE_X_Y_N: + /* N = ANGLE( X, Y ) */ + { + /* P1ANY|P2ANY */ + if (X == 0 && Y == 0) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + N = atan2 (Y, X); + if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_DEGREES) + { + N = FromRadiansToDegrees (N); + } + else if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_GRADIANS) + { + N = FromRadiansToGradians (N); + } + } + } + break; + case F_CEIL_X_N: + /* N = CEIL( X ) */ + { + /* P1ANY */ + N = ceil (X); + } + break; + case F_DET_N: + /* N = DET */ + { + /* PNONE */ + N = My->LastDeterminant; + } + break; + case F_NUM_N: + /* N = NUM */ + { + /* PNONE */ + N = My->LastInputCount; + } + break; + case F_DEG_N: + case F_DEGREE_N: + /* N = DEG */ + /* N = DEGREE */ + { + /* PNONE */ + My->CurrentVersion->OptionFlags |= OPTION_ANGLE_DEGREES; + My->CurrentVersion->OptionFlags &= ~OPTION_ANGLE_GRADIANS; + N = 0; + } + break; + case F_RAD_N: + case F_RADIAN_N: + /* N = RAD */ + /* N = RADIAN */ + { + /* PNONE */ + My->CurrentVersion->OptionFlags &= ~OPTION_ANGLE_DEGREES; + My->CurrentVersion->OptionFlags &= ~OPTION_ANGLE_GRADIANS; + N = 0; + } + break; + case F_GRAD_N: + case F_GRADIAN_N: + /* N = GRAD */ + /* N = GRADIAN */ + { + /* PNONE */ + My->CurrentVersion->OptionFlags &= ~OPTION_ANGLE_DEGREES; + My->CurrentVersion->OptionFlags |= OPTION_ANGLE_GRADIANS; + N = 0; + } + break; + case F_DEG_X_N: + case F_DEGREE_X_N: + /* N = DEG( X ) */ + /* N = DEGREE( X ) */ + { + /* P1ANY */ + if (My->CurrentVersion->OptionVersionValue & (R86)) + { + if (x == 0) + { + /* DEG 0 */ + My->CurrentVersion->OptionFlags &= ~OPTION_ANGLE_DEGREES; + My->CurrentVersion->OptionFlags &= ~OPTION_ANGLE_GRADIANS; + } + else + { + /* DEG 1 */ + My->CurrentVersion->OptionFlags |= OPTION_ANGLE_DEGREES; + My->CurrentVersion->OptionFlags &= ~OPTION_ANGLE_GRADIANS; + } + N = 0; + } + else + { + N = FromRadiansToDegrees (X); + } + } + break; + case F_RAD_X_N: + /* N = RAD( X ) */ + { + /* P1ANY */ + N = FromDegreesToRadians (X); + } + break; + case F_PI_N: + /* N = PI */ + { + /* PNONE */ + N = PI; + } + break; + case F_PI_X_N: + /* N = PI(X) */ + { + /* P1ANY */ + N = PI * X; + } + break; + case F_LTRIM4_A_S: + /* S$ = LTRIM$( A$ ) */ + { + /* P1ANY */ + if (a == 0) + { + /* empty string */ + } + else + { + int i; + /* BASIC allows embedded NULL characters */ + for (i = 0; i < a && A[i] == ' '; i++) + { + /* skip spaces */ + } + /* 'A[ i ]' is first non-space character */ + if (i >= a) + { + /* empty string */ + } + else + { + A += i; + a -= i; + bwb_memcpy (S, A, a); + s = a; + } + } + } + break; + case F_RTRIM4_A_S: + /* S$ = RTRIM$( A$ ) */ + { + /* P1ANY */ + if (a == 0) + { + /* empty string */ + } + else + { + int i; + /* BASIC allows embedded NULL characters */ + for (i = a - 1; i >= 0 && A[i] == ' '; i--) + { + /* skip spaces */ + } + /* 'A[ i ]' is last non-space character */ + if (i < 0) + { + /* empty string */ + } + else + { + a = i + 1; + bwb_memcpy (S, A, a); + s = a; + } + } + } + break; + case F_STRIP4_A_S: + /* S$ = STRIP$( A$ ) */ + { + /* P1ANY */ + if (a == 0) + { + /* empty string */ + } + else + { + int i; + for (i = 0; i < a; i++) + { + S[i] = A[i] & 0x7F; + } + s = a; + S[s] = NulChar; + } + } + break; + case F_TRIM4_A_S: + /* S$ = TRIM$( A$ ) */ + { + /* P1ANY */ + if (a == 0) + { + /* empty string */ + } + else + { + /* + ** + ** LTRIM + ** + */ + int i; + /* BASIC allows embedded NULL characters */ + for (i = 0; i < a && A[i] == ' '; i++) + { + /* skip spaces */ + } + /* 'A[ i ]' is first non-space character */ + if (i >= a) + { + /* empty string */ + } + else + { + A += i; + a -= i; + bwb_memcpy (S, A, a); + s = a; + /* + ** + ** RTRIM + ** + */ + A = S; + a = s; + if (a == 0) + { + /* empty string */ + } + else + { + int i; + /* BASIC allows embedded NULL characters */ + for (i = a - 1; i >= 0 && A[i] == ' '; i--) + { + /* skip spaces */ + } + /* 'A[ i ]' is last non-space character */ + if (i < 0) + { + /* empty string */ + } + else + { + a = i + 1; + /* bwb_memcpy( S, A, a ); */ + s = a; + } + } + } + } + } + break; + case F_MAX_X_Y_N: + /* N = MAX( X, Y ) */ + { + N = MAX (X, Y); + } + break; + case F_MAX_A_B_S: + /* S$ = MAX( A$, B$ ) */ + { + StringType L; + StringType R; + + L.length = a; + R.length = b; + L.sbuffer = A; + R.sbuffer = B; + if (str_cmp (&L, &R) >= 0) + { + /* A >= B */ + bwb_memcpy (S, A, a); + s = a; + } + else + { + /* A < B */ + bwb_memcpy (S, B, b); + s = b; + } + } + break; + case F_MIN_X_Y_N: + /* N = MIN( X, Y ) */ + { + N = MIN (X, Y); + } + break; + case F_MIN_A_B_S: + /* S$ = MIN( A$, B$ ) */ + { + StringType L; + StringType R; + + L.length = a; + R.length = b; + L.sbuffer = A; + R.sbuffer = B; + if (str_cmp (&L, &R) <= 0) + { + /* A <= B */ + bwb_memcpy (S, A, a); + s = a; + } + else + { + /* A > B */ + bwb_memcpy (S, B, b); + s = b; + } + } + break; + case F_FP_X_N: + case F_FRAC_X_N: + /* N = FP( X ) */ + /* N = FRAC( X ) */ + { + DoubleType FP; + DoubleType IP; + FP = modf (X, &IP); + N = FP; + } + break; + case F_IP_X_N: + /* N = IP( X ) */ + { + DoubleType IP; + modf (X, &IP); + N = IP; + } + break; + case F_EPS_X_N: + /* N = EPS( Number ) */ + { + N = DBL_MIN; + } + break; + case F_MAXLVL_N: + /* N = MAXLVL */ + { + N = EXECLEVELS; + } + break; + case F_MAXNUM_N: + /* N = MAXNUM */ + { + N = MAXDBL; + } + break; + case F_MINNUM_N: + /* N = MINNUM */ + { + N = MINDBL; + } + break; + case F_MAXDBL_N: + /* N = MAXDBL */ + { + N = MAXDBL; + } + break; + case F_MINDBL_N: + /* N = MINDBL */ + { + N = MINDBL; + } + break; + case F_MAXSNG_N: + /* N = MAXSNG */ + { + N = MAXSNG; + } + break; + case F_MINSNG_N: + /* N = MINSNG */ + { + N = MINSNG; + } + break; + case F_MAXCUR_N: + /* N = MAXCUR */ + { + N = MAXCUR; + } + break; + case F_MINCUR_N: + /* N = MINCUR */ + { + N = MINCUR; + } + break; + case F_MAXLNG_N: + /* N = MAXLNG */ + { + N = MAXLNG; + } + break; + case F_MINLNG_N: + /* N = MINLNG */ + { + N = MINLNG; + } + break; + case F_MAXINT_N: + /* N = MAXINT */ + { + N = MAXINT; + } + break; + case F_MININT_N: + /* N = MININT */ + { + N = MININT; + } + break; + case F_MAXBYT_N: + /* N = MAXBYT */ + { + N = MAXBYT; + } + break; + case F_MINBYT_N: + /* N = MINBYT */ + { + N = MINBYT; + } + break; + case F_MAXDEV_N: + /* N = MAXDEV */ + { + N = MAXDEV; + } + break; + case F_MINDEV_N: + /* N = MINDEV */ + { + N = MINDEV; + } + break; + + case F_MOD_X_Y_N: + /* N = MOD( X, Y ) */ + { + /* P1ANY|P2NEZ */ + DoubleType IP; + + IP = floor (X / Y); + N = X - (Y * IP); + } + break; + case F_REMAINDER_X_Y_N: + /* REMAINDER( X, Y ) */ + { + /* P1ANY|P2NEZ */ + DoubleType Value; + DoubleType IP; + + Value = X / Y; + modf (Value, &IP); + N = X - (Y * IP); + } + break; + case F_ROUND_X_Y_N: + /* N = ROUND( X, Y ) == INT(X*10^Y+.5)/10^Y */ + { + /* P1ANY | P2INT */ + if (y < -32 || y > 32) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + DoubleType T; /* 10^Y */ + + T = pow (10.0, Y); + if (T == 0) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + N = floor (X * T + 0.5) / T; + } + } + } + break; + case F_TRUNCATE_X_Y_N: + /* N = TRUNCATE( X, Y ) == INT(X*10^Y)/10^Y */ + { + /* P1ANY | P2INT */ + if (y < -32 || y > 32) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + DoubleType T; /* 10^Y */ + + T = pow (10.0, Y); + if (T == 0) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + N = floor (X * T) / T; + } + } + } + break; + case F_MAXLEN_A_N: + case F_MAXLEN_N: + /* N = MAXLEN( A$ ) */ + /* N = MAXLEN */ + { + N = MAXLEN; + } + break; + case F_ORD_A_N: + /* N = ORD( A$ ) */ + { + /* P1BYT */ + if (a == 1) + { + /* same as ASC(A$) */ + N = A[0]; + } + else + { + /* lookup Acronym */ + N = -1; + for (x = 0; x < NUM_ACRONYMS; x++) + { + if (bwb_stricmp (AcronymTable[x].Name, A) == 0) + { + /* FOUND */ + N = AcronymTable[x].Value; + break; + } + } + if (N < 0) + { + /* NOT FOUND */ + WARN_ILLEGAL_FUNCTION_CALL; + N = 0; + } + } + } + break; + case F_RENAME_A_B_N: + /* N = RENAME( A$, B$ ) */ + { + /* P1BYT | P2BYT */ + if (rename (A, B)) + { + /* ERROR -- return FALSE */ + N = 0; + } + else + { + /* OK -- return TRUE */ + N = -1; + } + } + break; + case F_SIZE_A_N: + /* N = SIZE( A$ ) */ + { + /* P1BYT */ + FILE *F; + + F = fopen (A, "rb"); + if (F != NULL) + { + long n; + + fseek (F, 0, SEEK_END); + n = ftell (F); + bwb_fclose (F); + + if (n > 0) + { + /* round up filesize to next whole kilobyte */ + n += 1023; + n /= 1024; + } + else + { + /* a zero-length file returns 0 */ + n = 0; + } + N = n; + } + /* a non-existing file returns 0 */ + } + break; + case F_REPEAT4_X_Y_S: + /* S$ = REPEAT$( X, Y ) ' X is count, Y is code */ + { + /* P1LEN | P2BYT */ + if (x == 0) + { + /* empty string */ + } + else + { + bwb_memset (S, (char) y, x); + s = x; + } + } + break; + case F_REPEAT4_X_A_S: + /* S$ = REPEAT$( X, A$ ) ' X is count, A$ is code */ + { + /* P1LEN | P2BYT */ + if (x == 0) + { + /* empty string */ + } + else + { + bwb_memset (S, (char) A[0], x); + s = x; + } + } + break; + case F_FIX_X_N: + /* N = FIX( X ) */ + { + /* N = bwb_rint(X); */ + if (X < 0) + { + N = -floor (-X); + } + else + { + N = floor (X); + } + } + break; + case F_ABS_X_N: + /* N = ABS( X ) */ + { + N = fabs (X); + } + break; + case F_ATN_X_N: + case F_ATAN_X_N: + case F_ARCTAN_X_N: + /* N = ATN( X ) */ + /* N = ATAN( X ) */ + /* N = ARCTAN( X ) */ + { + N = atan (X); + if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_DEGREES) + { + N = FromRadiansToDegrees (N); + } + else if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_GRADIANS) + { + N = FromRadiansToGradians (N); + } + } + break; + case F_ATND_X_N: + /* N = ATND( X ) */ + { + N = atan (X); + N = FromRadiansToDegrees (N); + } + break; + case F_ATNG_X_N: + /* N = ATNG( X ) */ + { + N = atan (X); + N = FromRadiansToGradians (N); + } + break; + case F_COS_X_N: + /* N = COS( X ) */ + { + if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_DEGREES) + { + X = FromDegreesToRadians (X); + } + else if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_GRADIANS) + { + X = FromGradiansToRadians (X); + } + N = cos (X); + } + break; + case F_COSD_X_N: + /* N = COSD( X ) */ + { + X = FromDegreesToRadians (X); + N = cos (X); + } + break; + case F_COSG_X_N: + /* N = COSG( X ) */ + { + X = FromGradiansToRadians (X); + N = cos (X); + } + break; + case F_EXP_X_N: + /* N = EXP( X ) */ + { + N = exp (X); + } + break; + case F_INT_X_N: + /* N = INT( X ) */ + { + N = floor (X); + } + break; + case F_FLOAT_X_N: + case F_INT5_X_N: + /* N = FLOAT( X ) */ + /* N = INT%( X ) */ + { + N = bwb_rint (X); + } + break; + case F_INITIALIZE_N: + /* INITIALIZE */ + { + N = 0; + } + break; + case F_LOG_X_N: + case F_LN_X_N: + case F_LOGE_X_N: + /* N = LOG( X ) */ + /* N = LN( X ) */ + /* N = LOGE( X ) */ + { + /* P1GTZ */ + N = log (X); + } + break; + case F_RND_N: + /* N = RND */ + { + N = rand (); + N /= RAND_MAX; + } + break; + case F_RND_X_N: + /* N = RND( X ) */ + { + N = rand (); + N /= RAND_MAX; + } + break; + case F_SGN_X_N: + /* N = SGN( X ) */ + { + if (X > 0) + { + N = 1; + } + else if (X < 0) + { + N = -1; + } + else + { + N = 0; + } + } + break; + case F_SIN_X_N: + /* N = SIN( X ) */ + { + if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_DEGREES) + { + X = FromDegreesToRadians (X); + } + else if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_GRADIANS) + { + X = FromGradiansToRadians (X); + } + N = sin (X); + } + break; + case F_SIND_X_N: + /* N = SIND( X ) */ + { + X = FromDegreesToRadians (X); + N = sin (X); + } + break; + case F_SING_X_N: + /* N = SING( X ) */ + { + X = FromGradiansToRadians (X); + N = sin (X); + } + break; + case F_SQR_X_N: + case F_SQRT_X_N: + /* N = SQR( X ) */ + /* N = SQRT( X ) */ + { + /* P1GEZ */ + N = sqrt (X); + } + break; + case F_TAN_X_N: + /* N = TAN( X ) */ + { + if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_DEGREES) + { + X = FromDegreesToRadians (X); + } + else if (My->CurrentVersion->OptionFlags & OPTION_ANGLE_GRADIANS) + { + X = FromGradiansToRadians (X); + } + N = tan (X); + } + break; + case F_TAND_X_N: + /* N = TAND( X ) */ + { + X = FromDegreesToRadians (X); + N = tan (X); + } + break; + case F_TANG_X_N: + /* N = TANG( X ) */ + { + X = FromGradiansToRadians (X); + N = tan (X); + } + break; + case F_SPC_X_S: + /* S$ = SPC( X ) */ + { + /* P1ANY */ + /* SPECIAL RULES APPLY. PART OF PRINT COMMAND. WIDTH > 0 */ + X = bwb_rint (X); + if (X < 1 || X > 255) + { + if (WARN_OVERFLOW) + { + /* ERROR */ + } + /* CONTINUE */ + X = 1; + } + x = (int) X; + bwb_memset (S, ' ', x); + s = x; + } + break; + case F_TAB_X_S: + /* S$ = TAB( X ) */ + { + /* P1ANY */ + /* SPECIAL RULES APPLY. PART OF PRINT COMMAND. WIDTH > 0 */ + int w; + int c; + + X = bwb_rint (X); + if (X < 1 || X > 255) + { + if (WARN_OVERFLOW) + { + /* ERROR */ + } + /* CONTINUE */ + X = 1; + } + x = (int) X; + if (My->CurrentFile) + { + w = My->CurrentFile->width; + c = My->CurrentFile->col; + } + else + { + w = My->SYSOUT->width; + c = My->SYSOUT->col; + } + if (w > 0) + { + /* WIDTH 80 */ + while (x > w) + { + /* + ** + ** If n is greater than the margin m, then n is + ** reduced by an integral multiple of m so that it is + ** in the range 1 <= n <= m; + ** + */ + x -= w; + } + /* 190 PRINT TAB(A);"X" ' A = 0 */ + if (x == 0) + { + /* use the value of one */ + x = 1; + /* continue processing */ + } + } + if (x < c) + { + S[0] = '\n'; + s = 1; + c = 1; + } + if (c < x) + { + x -= c; + bwb_memset (&(S[s]), ' ', x); + s += x; + } + } + break; + case F_POS_N: + /* N = POS */ + { + /* PNONE */ + N = My->SYSOUT->col; + } + break; + case F_COUNT_N: + /* N = COUNT */ + /* COUNT = POS - 1 */ + { + /* PNONE */ + N = My->SYSOUT->col; + N--; + } + break; + case F_POS_X_N: + /* N = POS( X ) */ + { + /* P1INT */ + if (x == 0) + { + N = My->SYSOUT->col; + } + else if (x < 0) + { + N = My->SYSPRN->col; + } + else + { + FileType *F; + F = find_file_by_number (x); + if (F == NULL) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + N = F->col; + } + } + } + break; + case F_INPUT4_X_Y_S: + /* S$ = INPUT$( X, Y ) */ + { + /* P1LEN|P2INT */ + if (y <= 0) + { + /* Printer and Console */ + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + FileType *F; + + F = find_file_by_number (y); + if (F == NULL) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + if ((F->DevMode & DEVMODE_READ) == 0) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else if (x == 0) + { + /* empty string */ + } + else + { + FILE *fp; + fp = F->cfp; + if (fp == NULL) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + s = fread (S, 1, x, fp); + s = MAX (s, 0); /* if( s < 0 ) s = 0; */ + } + } + } + } + } + break; + case F_ERROR_X_N: + /* ERROR X */ + { + /* P1BYT */ + bwx_Error (x, NULL); + N = 0; + } + break; + case F_ERROR_X_A_N: + /* ERROR X, A$ */ + { + /* P1BYT */ + bwx_Error (x, A); + N = 0; + } + break; + case F_ERR_N: + case F_ERRN_N: + /* N = ERR */ + /* N = ERRN */ + { + /* PNONE */ + N = My->ERR; + } + break; + case F_ERL_N: + case F_ERRL_N: + /* N = ERL */ + /* N = ERRL */ + { + /* PNONE */ + if (My->ERL != NULL) + { + N = My->ERL->number; + } + } + break; + case F_ERR4_S: + case F_ERROR4_S: + /* S = ERR$ */ + /* S = ERROR$ */ + { + /* PNONE */ + s = bwb_strlen (My->ERROR4); + if (s > 0) + { + bwb_strcpy (S, My->ERROR4); + } + } + break; + + + /******************************************************************************************** + ** Keep the platform specific functions together. + *********************************************************************************************/ + case F_INP_X_N: + case F_PIN_X_N: + /* N = INP( X ) */ + /* N = PIN( X ) */ + { + /* P1BYT */ + WARN_ADVANCED_FEATURE; + } + break; + case F_PDL_X_N: + /* N = PDL( X ) */ + { + /* P1BYT */ + WARN_ADVANCED_FEATURE; + } + break; + case F_WAIT_X_Y_N: + /* WAIT X, Y */ + { + /* P1NUM|P2NUM */ + /* P1INT|P2BYT */ + WARN_ADVANCED_FEATURE; + } + break; + case F_WAIT_X_Y_Z_N: + /* WAIT X, Y, Z */ + { + /* P1NUM|P2NUM|P3NUM */ + /* P1INT|P2BYT|P3BYT */ + WARN_ADVANCED_FEATURE; + } + break; + case F_OUT_X_Y_N: + /* OUT X, Y */ + { + /* P1NUM|P2NUM */ + /* P1INT|P2BYT */ + WARN_ADVANCED_FEATURE; + } + break; + case F_PEEK_X_N: + case F_EXAM_X_N: + case F_FETCH_X_N: + case F_DPEEK_X_N: + /* N = PEEK( X ) */ + /* N = EXAM( X ) */ + /* N = FETCH( X ) */ + /* N = DPEEK( X ) */ + { + /* P1INT */ + WARN_ADVANCED_FEATURE; + } + break; + case F_POKE_X_Y_N: + case F_FILL_X_Y_N: + case F_STUFF_X_Y_N: + case F_DPOKE_X_Y_N: + /* POKE X, Y */ + /* FILL X, Y */ + /* STUFF X, Y */ + /* DPOKE X, Y */ + { + /* P1NUM|P2NUM */ + /* P1INT|P2BYT */ + WARN_ADVANCED_FEATURE; + } + break; + case F_LOCK_X_N: + /* LOCK X */ + { + /* P1INT */ + WARN_ADVANCED_FEATURE; + } + break; + case F_UNLOCK_X_N: + /* UNLOCK X */ + { + /* P1INT */ + WARN_ADVANCED_FEATURE; + } + break; + case F_USR_N: + case F_USR0_N: + case F_USR1_N: + case F_USR2_N: + case F_USR3_N: + case F_USR4_N: + case F_USR5_N: + case F_USR6_N: + case F_USR7_N: + case F_USR8_N: + case F_USR9_N: + case F_EXF_N: + case F_UUF_N: + /* N = USR( ... ) */ + /* N = USR0( ... ) */ + /* N = USR1( ... ) */ + /* N = USR2( ... ) */ + /* N = USR3( ... ) */ + /* N = USR4( ... ) */ + /* N = USR5( ... ) */ + /* N = USR6( ... ) */ + /* N = USR7( ... ) */ + /* N = USR8( ... ) */ + /* N = USR9( ... ) */ + /* N = EXF( ... ) */ + /* N = UUF( ... ) */ + { + /* ... */ + WARN_ADVANCED_FEATURE; + } + break; + case F_VARPTR_N: + case F_NAME_N: + case F_PTR_N: + /* N = VARPTR( ... ) */ + /* N = NAME( ... ) */ + /* N = PTR( ... ) */ + { + /* ... */ + WARN_ADVANCED_FEATURE; + } + break; + case F_FRE_N: + case F_FRE_X_N: + case F_FRE_A_N: + case F_FREE_N: + case F_FREE_X_N: + case F_FREE_A_N: + case F_MEM_N: + case F_TOP_N: + /* N = FRE( ) */ + /* N = FRE( X ) */ + /* N = FRE( X$ ) */ + /* N = FREE( ) */ + /* N = FREE( X ) */ + /* N = FREE( X$ ) */ + /* N = MEM( ) */ + /* N = TOP( ) */ + { + N = 32000; /* reasonable value */ + } + break; + case F_CLS_N: + case F_HOME_N: + /* CLS */ + /* HOME */ + { + /* PNONE */ + bwx_CLS (); + } + break; + case F_LOCATE_X_Y_N: + /* LOCATE X, Y */ + { + /* P1NUM|P2NUM */ + /* P1BYT|P2BYT */ + bwx_LOCATE (x, y); + } + break; + case F_CUR_X_Y_S: + /* CUR X, Y */ + { + /* P1NUM|P2NUM */ + /* P1BYT|P2BYT */ + x++; /* 0-based to 1-based row */ + y++; /* 0-based to 1-based col */ + bwx_LOCATE (x, y); + s = 0; + } + break; + case F_VTAB_X_N: + /* VTAB X */ + { + /* P1BYT */ + /* X is 1-based row */ + /* col is 1 */ + bwx_LOCATE (x, 1); + } + break; + case F_COLOR_X_Y_N: + /* COLOR X, Y */ + { + /* P1NUM|P2NUM */ + /* P1BYT|P2BYT */ + /* X is Foreground color */ + /* Y is Background color */ + bwx_COLOR (X, Y); + } + break; + case F_SHELL_A_N: + case F_EXEC_A_N: + /* N = SHELL( A$ ) */ + /* N = EXEC( A$ ) */ + { + /* P1BYT */ + N = system (A); + } + break; + case F_FILES_N: + case F_CATALOG_N: + /* FILES */ + /* CATALOG */ + { + /* PNONE */ + if (is_empty_string (My->OptionFilesString)) + { + WARN_ADVANCED_FEATURE; + } + else + { + N = system (My->OptionFilesString); + } + } + break; + case F_FILES_A_N: + case F_CATALOG_A_N: + /* FILES A$ */ + /* CATALOG A$ */ + { + /* P1BYT */ + if (is_empty_string (My->OptionFilesString)) + { + WARN_ADVANCED_FEATURE; + } + else + { + size_t n; + char *Buffer; + + n = bwb_strlen (My->OptionFilesString) + 1 /* SpaceChar */ + a; + if ((Buffer = + (char *) calloc (n + 1 /* NulChar */ , sizeof (char))) == NULL) + { + WARN_OUT_OF_MEMORY; + } + else + { + bwb_strcpy (Buffer, My->OptionFilesString); + bwb_strcat (Buffer, " "); + bwb_strcat (Buffer, A); + N = system (Buffer); + free (Buffer); + Buffer = NULL; + } + } + } + break; + case F_CHDIR_A_N: + /* CHDIR A$ */ + { + /* P1BYT */ +#if DIRECTORY_CMDS + N = chdir (A); +#else + WARN_ADVANCED_FEATURE; +#endif + } + break; + case F_MKDIR_A_N: + /* MKDIR A$ */ + { + /* P1BYT */ +#if DIRECTORY_CMDS +#if MKDIR_ONE_ARG + N = mkdir (A); +#else + N = mkdir (A, PERMISSIONS); +#endif +#else + WARN_ADVANCED_FEATURE; +#endif + } + break; + case F_RMDIR_A_N: + /* RMDIR A$ */ + { + /* P1BYT */ +#if DIRECTORY_CMDS + N = rmdir (A); +#else + WARN_ADVANCED_FEATURE; +#endif + } + break; + case F_KILL_A_N: + case F_UNSAVE_A_N: + /* KILL A$ */ + /* UNSAVE A$ */ + { + /* P1BYT */ + N = remove (A); + } + break; + case F_NAME_A_B_N: + /* NAME A$ AS B$ */ + /* N = NAME( A$, B$ ) */ + { + /* P1BYT|P2BYT */ + N = rename (A, B); + } + break; + case F_INPUT4_X_S: + /* S$ = INPUT$( X ) */ + { + /* P1LEN */ + if (x == 0) + { + /* empty string */ + } + else + { + for (s = 0; s < x; s++) + { + int c; + c = fgetc (My->SYSIN->cfp); + if ((c == EOF) || (c == '\n') || (c == '\r')) + { + break; + } + S[s] = c; + } + S[s] = 0; + } + } + break; + case F_INKEY4_S: + case F_KEY4_S: + case F_KEY_S: + case F_INCH4_S: + /* S$ = INKEY$ */ + /* S$ = KEY$ */ + /* S$ = KEY */ + /* S$ = INCH$ */ + { + /* PNONE */ + int c; + + c = fgetc (My->SYSIN->cfp); + if (c < MINBYT || c > MAXBYT) + { + /* EOF */ + } + else + { + S[s] = c; + s++; + } + S[s] = 0; + } + break; + case F_NULL_X_N: + /* NULL X */ + { + /* P1NUM */ + /* P1BYT */ + My->LPRINT_NULLS = x; + N = 0; + } + break; + case F_LWIDTH_X_N: + /* LWIDTH X */ + { + /* P1NUM */ + /* P1BYT */ + My->SYSPRN->width = x; + My->SYSPRN->col = 1; + N = 0; + } + break; + case F_LPOS_N: + /* N = LPOS */ + { + /* PNONE */ + /* PNONE */ + N = My->SYSPRN->col; + } + break; + case F_TRON_N: + case F_TRACE_N: + case F_FLOW_N: + /* TRON */ + /* TRACE */ + /* FLOW */ + { + /* PNONE */ + fprintf (My->SYSOUT->cfp, "Trace is ON\n"); + ResetConsoleColumn (); + My->IsTraceOn = TRUE; + N = 0; + } + break; + case F_TROFF_N: + case F_NOTRACE_N: + case F_NOFLOW_N: + /* TROFF */ + /* NOTRACE */ + /* NOFLOW */ + { + /* PNONE */ + fprintf (My->SYSOUT->cfp, "Trace is OFF\n"); + ResetConsoleColumn (); + My->IsTraceOn = FALSE; + N = 0; + } + break; + case F_TRACE_X_N: + /* TRACE X */ + { + /* P1BYTE */ + if (x == 0) + { + fprintf (My->SYSOUT->cfp, "Trace is OFF\n"); + ResetConsoleColumn (); + My->IsTraceOn = FALSE; + } + else + { + fprintf (My->SYSOUT->cfp, "Trace is ON\n"); + ResetConsoleColumn (); + My->IsTraceOn = TRUE; + } + N = 0; + } + break; + case F_RANDOMIZE_N: + case F_RAN_N: + case F_RANDOM_N: + /* RANDOMIZE */ + /* RAN */ + /* RANDOM */ + { + /* PNONE */ + /* USE THE CURRENT TIME AS THE SEED */ + time (&t); + lt = localtime (&t); + x = lt->tm_hour * 3600 + lt->tm_min * 60 + lt->tm_sec; + srand (x); + N = 0; + } + break; + case F_RANDOMIZE_X_N: + case F_RAN_X_N: + case F_RANDOM_X_N: + /* RANDOMIZE X */ + /* RAN X */ + /* RANDOM X */ + { + /* P1NUM */ + /* P1ANY */ + /* USE 'X' AS THE SEED */ + x = (int) bwb_rint (X); + srand (x); + N = 0; + } + break; + case F_LNO_X_N: + /* N = LNO( X, Y ) */ + { + /* P1NUM */ + /* P1ANY */ + N = X; + } + break; + case F_PAD_X_N: + case F_SEG_X_N: + /* N = PAD( X ) */ + /* N = SEG( X ) */ + { + /* P1NUM */ + /* P1ANY */ + N = 0; + } + break; + case F_CNTRL_X_Y_N: + /* N = CNTRL( X, Y ) */ + { + /* P1NUM | P2NUM */ + /* P1INT | P2INT */ + switch (x) + { + case 0: + /* + CNTRL 0,line + This specifies a line to go to when the user presses Ctl-B. + */ + break; + case 1: + /* + CNTRL 1,value + This sets the number of digits (1 to 6) to print + */ + if (y == 0) + { + /* default */ + y = SIGNIFICANT_DIGITS; + } + if (y < MINIMUM_DIGITS || y > MAXIMUM_DIGITS) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + My->OptionDigitsInteger = y; + } + break; + case 2: + /* + CNTRL 2,value + This controls the front panel LED display. + */ + break; + case 3: + /* + CNTRL 3,value + This command sets the width of the print zones. + */ + if (y == 0) + { + /* default */ + y = ZONE_WIDTH; + } + if (y < MINIMUM_ZONE || y > MAXIMUM_ZONE) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + My->OptionZoneInteger = y; + } + break; + case 4: + /* + CNTRL 4,value + This command is used to load and unload the main HDOS overlay. + */ + break; + default: + WARN_ILLEGAL_FUNCTION_CALL; + break; + } + N = 0; + } + break; + case F_ZONE_X_N: + /* N = ZONE( X ) */ + { + /* P1NUM */ + /* P1INT */ + if (x == 0) + { + /* default */ + x = ZONE_WIDTH; + } + if (x < MINIMUM_ZONE || x > MAXIMUM_ZONE) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + My->OptionZoneInteger = x; + } + } + break; + case F_ZONE_X_Y_N: + /* N = ZONE( X, Y ) */ + { + /* P1NUM | P2NUM */ + /* P1INT | P2INT */ + /* value of X is ignored */ + if (y == 0) + { + /* default */ + y = ZONE_WIDTH; + } + if (y < MINIMUM_ZONE || y > MAXIMUM_ZONE) + { + WARN_ILLEGAL_FUNCTION_CALL; + } + else + { + My->OptionZoneInteger = y; + } + } + break; + case F_CIN_X_N: + /* N = CIN( X ) */ + { + /* P1INT */ + if (x <= 0) + { + /* Printer and Console */ + N = -1; + } + else + { + FileType *F; + + F = find_file_by_number (x); + if (F == NULL) + { + N = -1; + } + else if (F->DevMode & DEVMODE_READ) + { + N = fgetc (F->cfp); + } + else + { + N = -1; + } + } + } + break; + case F_TRUE_N: + /* N = TRUE */ + { + /* PNONE */ + N = TRUE; + } + break; + case F_FALSE_N: + /* N = FALSE */ + { + /* PNONE */ + N = FALSE; + } + break; + default: + { + /* an unknown function code */ + WARN_INTERNAL_ERROR; + } + } + /* sanity check */ + if (f->ReturnTypeCode == StringTypeCode) + { + /* STRING */ + if ( /* s < 0 || */ s > MAXLEN) + { + WARN_INTERNAL_ERROR; + s = 0; + } + if (S != RESULT_BUFFER) + { + WARN_INTERNAL_ERROR; + S = RESULT_BUFFER; + } + RESULT_LENGTH = s; + RESULT_BUFFER[RESULT_LENGTH] = NulChar; + } + else + { + /* NUMBER */ + if (isnan (N)) + { + /* ERROR */ + /* this means the parameters were not properly checked */ + WARN_INTERNAL_ERROR; + N = 0; + } + else if (isinf (N)) + { + /* Evaluation of an expression results in an + * overflow (nonfatal, the recommended + * recovery procedure is to supply machine + * in- finity with the algebraically correct + * sign and continue). */ + if (N < 0) + { + N = MINDBL; + } + else + { + N = MAXDBL; + } + WARN_OVERFLOW; + } + RESULT_NUMBER = N; + } + return argv; /* released by exp_function() in bwb_elx.c */ +} + +/* EOF */ |