|
- /****************************************************************
-
- 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 */
|