diff options
Diffstat (limited to 'bwb_exp.c')
| -rw-r--r-- | bwb_exp.c | 3519 |
1 files changed, 3519 insertions, 0 deletions
diff --git a/bwb_exp.c b/bwb_exp.c new file mode 100644 index 0000000..b603d1d --- /dev/null +++ b/bwb_exp.c @@ -0,0 +1,3519 @@ +/**************************************************************** + + bwb_exp.c Expression Parser + 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" + + +/* +-------------------------------------------------------------------------------------------- + EXPRESSION PARSER + +Inspired by https://groups.google.com/forum/m/#!topic/comp.compilers/RCyhEbLfs40 +... +// Permission is given to use this source provided an acknowledgement is given. +// I'd also like to know if you've found it useful. +// +// The following Research Report describes the idea, and shows how the +// parsing method may be understood as an encoding of the usual family-of- +// parsing-procedures technique as used e.g. in Pascal compilers. +// @techreport{QMW-DCS-383-1986a, +// author ="Clarke, Keith", +// title ="The Top-Down Parsing of Expressions", +// institution ="Department of Computer Science, Queen Mary College, University of London, England", +// year ="1986", +// month ="June", +// number ="QMW-DCS-1986-383", +// scope ="theory", +// abstractURL ="http://www.dcs.qmw.ac.uk/publications/report_abstracts/1986/383", +// keywords ="Recursive-descent parsing, expression parsing, operator precedence parsing." +// } +// A formal proof of the algorithm was made, as part of his PhD thesis work, +// by A.M. Abbas of QMC, London, in the framework of Constructive Set Theory. +// copyright Keith Clarke, Dept of Computer Science, QMW, University of London, +// England. email kei...@dcs.qmw.ac.uk +... +-------------------------------------------------------------------------------------------- +*/ + +/* +For all functions named "line_*", "LineType * line" is the first parameter. +For all functions named "buff_*", "char * buffer, int * position" are the first two parameters. +FALSE must be zero. +TRUE must be non-zero. +*/ + + + +/* OperatorType.Arity */ +#define UNARY 1 +#define BINARY 2 + +/* OperatorType.IsAlpha */ +#define IS_ALPHA 'T' +#define NO_ALPHA 'F' + + +#define COPY_VARIANT( X, Y ) if( X != NULL ) { bwb_memcpy( X, Y, sizeof( VariantType ) ); bwb_memset( Y, 0, sizeof( VariantType ) ); } + +typedef ResultType (OperatorFunctionType) (VariantType * X, VariantType * Y); + +struct OperatorStruct +{ + const unsigned char ThisPrec; + const unsigned char NextPrec; /* if BINARY and LEFT assoc, then ThisPrec+1, else ThisPrec */ + const unsigned char Arity; /* UNARY or BINARY */ + const char IsAlpha; /* IS_ALPHA or NO_ALPHA, determines how operator is matched */ + const char *Name; + OperatorFunctionType *Eval; + const char *Syntax; + const char *Description; + OptionVersionType OptionVersionBitmask; /* OPTION VERSION bitmask */ +}; +typedef struct OperatorStruct OperatorType; + +static int both_are_long (VariantType * X, VariantType * Y); +static int both_integer_type (VariantType * X, VariantType * Y); +static int both_number_type (VariantType * X, VariantType * Y); +static int both_string_type (VariantType * X, VariantType * Y); +static ResultType buff_read_expr (char *buffer, int *position, + VariantType * X, unsigned char LastPrec); +static ResultType buff_read_function (char *buffer, int *position, + VariantType * X); +static ResultType buff_read_internal_constant (char *buffer, int *position, + VariantType * X); +static OperatorType *buff_read_operator (char *buffer, int *position, + unsigned char LastPrec, + unsigned char Arity); +static ResultType buff_read_primary (char *buffer, int *position, + VariantType * X); +static ResultType buff_read_string_constant (char *buffer, int *position, + VariantType * X); +static ResultType buff_read_variable (char *buffer, int *position, + VariantType * X); +static int bwb_isodigit (int C); +static int is_integer_type (VariantType * X); +static int is_long_value (VariantType * X); +static int is_number_type (VariantType * X); +static int is_string_type (VariantType * X); +static char Largest_TypeCode (char TypeCode, VariantType * X); +static char math_type (VariantType * X, VariantType * Y); +static char max_number_type (char X, char Y); +static char min_value_type (VariantType * X); +static ResultType OP_ADD (VariantType * X, VariantType * Y); +static ResultType OP_AMP (VariantType * X, VariantType * Y); +static ResultType OP_AND (VariantType * X, VariantType * Y); +static ResultType OP_DIV (VariantType * X, VariantType * Y); +static ResultType OP_EQ (VariantType * X, VariantType * Y); +static ResultType OP_EQV (VariantType * X, VariantType * Y); +static ResultType OP_EXP (VariantType * X, VariantType * Y); +static ResultType OP_GE (VariantType * X, VariantType * Y); +static ResultType OP_GT (VariantType * X, VariantType * Y); +static ResultType OP_IDIV (VariantType * X, VariantType * Y); +static ResultType OP_IMP (VariantType * X, VariantType * Y); +static ResultType OP_LE (VariantType * X, VariantType * Y); +static ResultType OP_LIKE (VariantType * X, VariantType * Y); +static ResultType OP_LT (VariantType * X, VariantType * Y); +static ResultType OP_MAX (VariantType * X, VariantType * Y); +static ResultType OP_MIN (VariantType * X, VariantType * Y); +static ResultType OP_MOD (VariantType * X, VariantType * Y); +static ResultType OP_MUL (VariantType * X, VariantType * Y); +static ResultType OP_NE (VariantType * X, VariantType * Y); +static ResultType OP_NEG (VariantType * X, VariantType * Y); +static ResultType OP_NOT (VariantType * X, VariantType * Y); +static ResultType OP_OR (VariantType * X, VariantType * Y); +static ResultType OP_POS (VariantType * X, VariantType * Y); +static ResultType OP_SUB (VariantType * X, VariantType * Y); +static ResultType OP_XOR (VariantType * X, VariantType * Y); +static void SortAllOperatorsForManual (void); +static ResultType test_eq (VariantType * X, VariantType * Y, int TrueValue, + int FalseValue); +static ResultType test_gt (VariantType * X, VariantType * Y, int TrueValue, + int FalseValue); +static ResultType test_lt (VariantType * X, VariantType * Y, int TrueValue, + int FalseValue); + + +/* table of operators */ + +/* +In BASIC, 2 ^ 3 ^ 2 = ( 2 ^ 3 ) ^ 2 = 64, and -2 ^ 2 = - (2 ^ 2) = -4. +*/ + + +static OperatorType OperatorTable[ /* NUM_OPERATORS */ ] = +{ + /* LOGICAL */ + {0x01, 0x02, BINARY, IS_ALPHA, "IMP", OP_IMP, "X IMP Y", "Bitwise IMP", + B15 | B93 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 | M80 | T80 + | H14}, + {0x02, 0x03, BINARY, IS_ALPHA, "EQV", OP_EQV, "X EQV Y", "Bitwise EQV", + B15 | B93 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 | M80 | T80 + | H14}, + {0x03, 0x04, BINARY, IS_ALPHA, "XOR", OP_XOR, "X XOR Y", + "Bitwise Exclusive OR", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | M80 | T79 | R86 | T80 | H14}, + {0x03, 0x04, BINARY, IS_ALPHA, "XRA", OP_XOR, "X XRA Y", + "Bitwise Exclusive OR", + HB2}, + {0x04, 0x05, BINARY, IS_ALPHA, "OR", OP_OR, "X OR Y", "Bitwise OR", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x05, 0x06, BINARY, IS_ALPHA, "AND", OP_AND, "X AND Y", "Bitwise AND", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x06, 0x06, UNARY, IS_ALPHA, "NOT", OP_NOT, "NOT X", "Bitwise NOT", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, +/* RELATIONAL */ + {0x07, 0x08, BINARY, IS_ALPHA, "NE", OP_NE, "X NE Y", "Not Equal", + 0}, + {0x07, 0x08, BINARY, NO_ALPHA, "#", OP_NE, "X # Y", "Not Equal", + 0}, + {0x07, 0x08, BINARY, NO_ALPHA, "<>", OP_NE, "X <> Y", "Not Equal", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x07, 0x08, BINARY, NO_ALPHA, "><", OP_NE, "X >< Y", "Not Equal", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x07, 0x08, BINARY, IS_ALPHA, "GE", OP_GE, "X GE Y", + "Greater than or Equal", + 0}, + {0x07, 0x08, BINARY, NO_ALPHA, ">=", OP_GE, "X >= Y", + "Greater than or Equal", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x07, 0x08, BINARY, NO_ALPHA, "=>", OP_GE, "X => Y", + "Greater than or Equal", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x07, 0x08, BINARY, IS_ALPHA, "LE", OP_LE, "X LE Y", "Less than or Equal", + 0}, + {0x07, 0x08, BINARY, NO_ALPHA, "<=", OP_LE, "X <= Y", "Less than or Equal", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x07, 0x08, BINARY, NO_ALPHA, "=<", OP_LE, "X =< Y", "Less than or Equal", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x07, 0x08, BINARY, IS_ALPHA, "EQ", OP_EQ, "X EQ Y", "Equal", + 0}, + {0x07, 0x08, BINARY, NO_ALPHA, "=", OP_EQ, "X = Y", "Equal", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x07, 0x08, BINARY, IS_ALPHA, "LT", OP_LT, "X LT Y", "Less than", + 0}, + {0x07, 0x08, BINARY, NO_ALPHA, "<", OP_LT, "X < Y", "Less than", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x07, 0x08, BINARY, IS_ALPHA, "GT", OP_GT, "X GT Y", "Greater than", + 0}, + {0x07, 0x08, BINARY, NO_ALPHA, ">", OP_GT, "X > Y", "Greater than", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x07, 0x08, BINARY, IS_ALPHA, "LIKE", OP_LIKE, "A$ LIKE B$", + "Compare A$ to the pattern in B$", + B15}, + {0x07, 0x08, BINARY, IS_ALPHA, "MAX", OP_MAX, "X MAX Y", "Maximum", + 0}, + {0x07, 0x08, BINARY, IS_ALPHA, "MIN", OP_MIN, "X MIN Y", "Minimum", + 0}, +/* CONCATENATION */ + {0x08, 0x09, BINARY, NO_ALPHA, "&", OP_AMP, "X & Y", "Concatenation", + B15 | B93 | HB2}, +/* ARITHMETIC */ + {0x09, 0x0A, BINARY, NO_ALPHA, "+", OP_ADD, "X + Y", "Addition", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x09, 0x0A, BINARY, NO_ALPHA, "-", OP_SUB, "X - Y", "Subtraction", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x0A, 0x0B, BINARY, IS_ALPHA, "MOD", OP_MOD, "X MOD Y", "Integer Modulus", + B15 | B93 | HB1 | HB2 | D71 | M80 | R86 | T80 | H14}, + {0x0B, 0x0C, BINARY, NO_ALPHA, "\\", OP_IDIV, "X \\ Y", "Integer Division", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | E78 | E86 | M80 | T80 | H14}, + {0x0C, 0x0D, BINARY, NO_ALPHA, "*", OP_MUL, "X * Y", "Multiplication", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x0C, 0x0D, BINARY, NO_ALPHA, "/", OP_DIV, "X / Y", "Division", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x0D, 0x0D, UNARY, NO_ALPHA, "#", OP_POS, "# X", "Posation", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | C77 | D71 | E86 | M80 | T79 + | R86 | T80 | H80 | H14}, + {0x0D, 0x0D, UNARY, NO_ALPHA, "+", OP_POS, "+ X", "Posation", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x0D, 0x0D, UNARY, NO_ALPHA, "-", OP_NEG, "- X", "Negation", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14}, + {0x0E, 0x0F, BINARY, NO_ALPHA, "^", OP_EXP, "X ^ Y", "Exponential", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78 | E86 | M80 | T79 | R86 | H80 | V09 | H14}, + {0x0E, 0x0F, BINARY, NO_ALPHA, "[", OP_EXP, "X [ Y", "Exponential", + B15 | HB1 | HB2 | T80}, + {0x0E, 0x0F, BINARY, NO_ALPHA, "**", OP_EXP, "X ** Y", "Exponential", + B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 + | D70 | D73 | E78}, +}; + +static const size_t NUM_OPERATORS = + sizeof (OperatorTable) / sizeof (OperatorType); + +/* +-------------------------------------------------------------------------------------------- + Helpers +-------------------------------------------------------------------------------------------- +*/ + +extern void +SortAllOperators (void) /* SortAllOperators() should be called by bwb_init() */ +{ + /* sort the operators by decreasing length, so "**" matches before "*" and so on. */ + int i; + + + for (i = 0; i < NUM_OPERATORS - 1; i++) + { + int j; + int k; + int m; + + k = i; + m = bwb_strlen (OperatorTable[i].Name); + + for (j = i + 1; j < NUM_OPERATORS; j++) + { + int n; + n = bwb_strlen (OperatorTable[j].Name); + if (n > m) + { + m = n; + k = j; + } + } + if (k > i) + { + /* swap */ + OperatorType t; + OperatorType *T; + OperatorType *I; + OperatorType *K; + + T = &t; + I = &OperatorTable[i]; + K = &OperatorTable[k]; + + bwb_memcpy (T, I, sizeof (t)); + bwb_memcpy (I, K, sizeof (t)); + bwb_memcpy (K, T, sizeof (t)); + } + } +} + +static void +SortAllOperatorsForManual (void) /* SortAllOperators() should be called aftwards */ +{ + /* sort the operators by by precedence (high-to-low) then name (alphabetically). */ + int i; + + + for (i = 0; i < NUM_OPERATORS - 1; i++) + { + int j; + int k; + int m; + + k = i; + m = OperatorTable[i].ThisPrec; + + for (j = i + 1; j < NUM_OPERATORS; j++) + { + int n; + n = OperatorTable[j].ThisPrec; + if (n > m) + { + m = n; + k = j; + } + else + if (n == m + && bwb_stricmp (OperatorTable[j].Name, OperatorTable[k].Name) < 0) + { + m = n; + k = j; + } + } + if (k > i) + { + /* swap */ + OperatorType t; + OperatorType *T; + OperatorType *I; + OperatorType *K; + + T = &t; + I = &OperatorTable[i]; + K = &OperatorTable[k]; + + bwb_memcpy (T, I, sizeof (t)); + bwb_memcpy (I, K, sizeof (t)); + bwb_memcpy (K, T, sizeof (t)); + } + } +} +static char +min_value_type (VariantType * X) +{ + /* returns the minimal TypeCode, based upon a NUMBER's value */ + + assert (X != NULL); + + + if (isnan (X->Number)) + { + /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ + WARN_INTERNAL_ERROR; + return NulChar; + } + if (X->Number == bwb_rint (X->Number)) + { + /* INTEGER */ + if (MINBYT <= X->Number && X->Number <= MAXBYT) + { + return ByteTypeCode; + } + if (MININT <= X->Number && X->Number <= MAXINT) + { + return IntegerTypeCode; + } + if (MINLNG <= X->Number && X->Number <= MAXLNG) + { + return LongTypeCode; + } + if (MINCUR <= X->Number && X->Number <= MAXCUR) + { + return CurrencyTypeCode; + } + } + /* FLOAT */ + if (MINSNG <= X->Number && X->Number <= MAXSNG) + { + return SingleTypeCode; + } + if (MINDBL <= X->Number && X->Number <= MAXDBL) + { + return DoubleTypeCode; + } + /* OVERFLOW */ + if (X->Number < 0) + { + X->Number = MINDBL; + } + else + { + X->Number = MAXDBL; + } + if (WARN_OVERFLOW) + { + /* ERROR */ + } + /* CONTINUE */ + return DoubleTypeCode; +} + + + +static char +max_number_type (char X, char Y) +{ + /* returns the maximal TypeCode, given two NUMBER TypeCode's */ + + + + if (X == DoubleTypeCode || Y == DoubleTypeCode) + { + return DoubleTypeCode; + } + if (X == SingleTypeCode || Y == SingleTypeCode) + { + return SingleTypeCode; + } + if (X == CurrencyTypeCode || Y == CurrencyTypeCode) + { + return CurrencyTypeCode; + } + if (X == LongTypeCode || Y == LongTypeCode) + { + return LongTypeCode; + } + if (X == IntegerTypeCode || Y == IntegerTypeCode) + { + return IntegerTypeCode; + } + if (X == ByteTypeCode || Y == ByteTypeCode) + { + return ByteTypeCode; + } + /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ + WARN_INTERNAL_ERROR; + return NulChar; +} +static char +math_type (VariantType * X, VariantType * Y) +{ + /* + ** + ** Returns the TypeCode resulting from a math operation, such as addition. + ** The return TypeCode should be the maximal of: + ** a. The original X's TypeCode. + ** b. The original Y's TypeCode. + ** c. The result's minimal TypeCode. + ** + */ + + assert (X != NULL); + assert (Y != NULL); + return + max_number_type (max_number_type (X->VariantTypeCode, Y->VariantTypeCode), + min_value_type (X)); +} + +static char +Largest_TypeCode (char TypeCode, VariantType * X) +{ + assert (X != NULL); + if (is_integer_type (X)) + { + X->Number = bwb_rint (X->Number); + } + return max_number_type (TypeCode, min_value_type (X)); +} +static int +is_string_type (VariantType * X) +{ + /* if value is a STRING, then TRUE, else FALSE */ + + assert (X != NULL); + switch (X->VariantTypeCode) + { + case ByteTypeCode: + case IntegerTypeCode: + case LongTypeCode: + case CurrencyTypeCode: + case SingleTypeCode: + case DoubleTypeCode: + if (X->Buffer != NULL) + { + /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ + WARN_INTERNAL_ERROR; + return FALSE; + } + return FALSE; + case StringTypeCode: + if (X->Buffer == NULL) + { + /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ + WARN_INTERNAL_ERROR; + return FALSE; + } + return TRUE; + } + /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ + WARN_INTERNAL_ERROR; + return FALSE; +} +static int +is_number_type (VariantType * X) +{ + /* if value is a NUMBER, then TRUE, else FALSE */ + + assert (X != NULL); + switch (X->VariantTypeCode) + { + case ByteTypeCode: + case IntegerTypeCode: + case LongTypeCode: + case CurrencyTypeCode: + case SingleTypeCode: + case DoubleTypeCode: + if (X->Buffer != NULL) + { + /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ + WARN_INTERNAL_ERROR; + return FALSE; + } + return TRUE; + case StringTypeCode: + if (X->Buffer == NULL) + { + /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ + WARN_INTERNAL_ERROR; + return FALSE; + } + return FALSE; + } + /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ + WARN_INTERNAL_ERROR; + return FALSE; /* never reached */ +} +static int +is_integer_type (VariantType * X) +{ + /* if value is an INTEGER, then TRUE, else FALSE */ + + assert (X != NULL); + switch (X->VariantTypeCode) + { + case ByteTypeCode: + return TRUE; + case IntegerTypeCode: + return TRUE; + case LongTypeCode: + return TRUE; + case CurrencyTypeCode: + return TRUE; + case SingleTypeCode: + return FALSE; + case DoubleTypeCode: + return FALSE; + case StringTypeCode: + return FALSE; + } + /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ + WARN_INTERNAL_ERROR; + return FALSE; +} +static int +both_string_type (VariantType * X, VariantType * Y) +{ + /* if both values are a STRING, then TRUE, else FALSE */ + + assert (X != NULL); + assert (Y != NULL); + if (is_string_type (X) && is_string_type (Y)) + { + return TRUE; + } + return FALSE; +} +static int +both_number_type (VariantType * X, VariantType * Y) +{ + /* if both values are a NUMBER, then TRUE, else FALSE */ + + assert (X != NULL); + assert (Y != NULL); + if (is_number_type (X) && is_number_type (Y)) + { + return TRUE; + } + return FALSE; +} +static int +both_integer_type (VariantType * X, VariantType * Y) +{ + /* if both values are an INTEGER, then TRUE, else FALSE */ + + assert (X != NULL); + assert (Y != NULL); + if (is_integer_type (X) && is_integer_type (Y)) + { + return TRUE; + } + return FALSE; +} +static int +is_long_value (VariantType * X) +{ + /* if the NUMBER's value can be a LONG, then TRUE, else FALSE */ + + assert (X != NULL); + if (isnan (X->Number)) + { + /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ + WARN_INTERNAL_ERROR; + return FALSE; + } + if (X->Number == bwb_rint (X->Number)) + { + if (MINCUR <= X->Number && X->Number <= MAXCUR) + { + return TRUE; + } + } + return FALSE; +} +static int +both_are_long (VariantType * X, VariantType * Y) +{ + /* if both values can be a LONG, then TRUE, else FALSE */ + + assert (X != NULL); + assert (Y != NULL); + if (is_long_value (X) && is_long_value (Y)) + { + return TRUE; + } + return FALSE; +} +static int +bwb_isodigit (int C) +{ + + switch (C) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + return TRUE; + } + return FALSE; +} + + + +/* +-------------------------------------------------------------------------------------------- + Operators +-------------------------------------------------------------------------------------------- +*/ + +static ResultType +OP_ADD (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + if (both_number_type (X, Y)) + { + /* X = (X + Y) */ + X->Number += Y->Number; + if (both_integer_type (X, Y)) + { + X->Number = bwb_rint (X->Number); + } + X->VariantTypeCode = math_type (X, Y); + return RESULT_SUCCESS; + } + if (both_string_type (X, Y)) + { + /* X$ = (X$ + Y$) */ + return OP_AMP (X, Y); + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_AMP (VariantType * X, VariantType * Y) +{ + /* X$ = (X & Y ) */ + /* X$ = (X & Y$) */ + /* X$ = (X$ & Y ) */ + /* X$ = (X$ & Y$) */ + size_t CharsRemaining; + VariantType t; + VariantType *T; + + assert (X != NULL); + assert (Y != NULL); + + T = &t; + if (X->VariantTypeCode != StringTypeCode) + { + /* coerce X to X$ */ + if ((X->Buffer = (char *) calloc (NUMLEN, sizeof (char))) == NULL) /* free() called by OP_ADD() */ + { + WARN_OUT_OF_MEMORY; + return RESULT_ERROR; + } + FormatBasicNumber (X->Number, X->Buffer); + X->Length = bwb_strlen (X->Buffer); + X->VariantTypeCode = StringTypeCode; + } + if (Y->VariantTypeCode != StringTypeCode) + { + /* coerce Y to Y$ */ + if ((Y->Buffer = (char *) calloc (NUMLEN, sizeof (char))) == NULL) /* free() called by OP_ADD() */ + { + WARN_OUT_OF_MEMORY; + return RESULT_ERROR; + } + FormatBasicNumber (Y->Number, Y->Buffer); + Y->Length = bwb_strlen (Y->Buffer); + Y->VariantTypeCode = StringTypeCode; + } + if (X->Length > MAXLEN) + { + WARN_STRING_TOO_LONG; + X->Length = MAXLEN; + } + if (Y->Length > MAXLEN) + { + WARN_STRING_TOO_LONG; + Y->Length = MAXLEN; + } + T->VariantTypeCode = StringTypeCode; + T->Length = X->Length + Y->Length; + if (T->Length > MAXLEN) + { + WARN_STRING_TOO_LONG; + T->Length = MAXLEN; + } + /* we always allocate a buffer, even for non-empty strings */ + if ((T->Buffer = + (char *) calloc (T->Length + 1 /* NulChar */ , sizeof (char))) == NULL) + { + WARN_OUT_OF_MEMORY; + return RESULT_ERROR; + } + CharsRemaining = T->Length; + if (X->Length > CharsRemaining) + { + X->Length = CharsRemaining; + } + if (X->Length > 0) + { + bwb_memcpy (T->Buffer, X->Buffer, X->Length); + CharsRemaining -= X->Length; + } + if (Y->Length > CharsRemaining) + { + Y->Length = CharsRemaining; + } + if (Y->Length > 0) + { + bwb_memcpy (&T->Buffer[X->Length], Y->Buffer, Y->Length); + CharsRemaining -= Y->Length; + } + if (CharsRemaining != 0) + { + WARN_INTERNAL_ERROR; + return RESULT_ERROR; + } + T->Buffer[T->Length] = NulChar; + RELEASE_VARIANT (X); + RELEASE_VARIANT (Y); + COPY_VARIANT (X, T); + return RESULT_SUCCESS; +} +static ResultType +OP_SUB (VariantType * X, VariantType * Y) +{ + /* X = (X - Y) */ + + assert (X != NULL); + assert (Y != NULL); + if (both_number_type (X, Y)) + { + X->Number -= Y->Number; + if (both_integer_type (X, Y)) + { + X->Number = bwb_rint (X->Number); + } + X->VariantTypeCode = math_type (X, Y); + return RESULT_SUCCESS; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_MUL (VariantType * X, VariantType * Y) +{ + /* X = (X * Y) */ + + assert (X != NULL); + assert (Y != NULL); + if (both_number_type (X, Y)) + { + X->Number *= Y->Number; + if (both_integer_type (X, Y)) + { + X->Number = bwb_rint (X->Number); + } + X->VariantTypeCode = math_type (X, Y); + return RESULT_SUCCESS; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_IDIV (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + if (both_number_type (X, Y)) + { + /* X = (X \ Y) */ + X->Number = bwb_rint (X->Number); + Y->Number = bwb_rint (Y->Number); + if (Y->Number == 0) + { + /* - Evaluation of an expression results in division + * by zero (nonfatal, the recommended recovery + * procedure is to supply machine infinity with the + * sign of the numerator and continue) + */ + if (X->Number < 0) + { + /* NEGATIVE */ + X->Number = MINDBL; /* NEGATIVE INFINITY */ + } + else + { + /* POSITIVE */ + X->Number = MAXDBL; /* POSITIVE INFINITY */ + } + if (WARN_DIVISION_BY_ZERO) + { + return RESULT_ERROR; + } + /* CONTINUE */ + } + else + { + DoubleType N; + + N = bwb_rint (X->Number / Y->Number); + if (My->CurrentVersion->OptionVersionValue & (R86)) + { + /* for RBASIC's RESIDUE function */ + My->RESIDUE = bwb_rint (X->Number - N * Y->Number); + } + X->Number = N; + + } + X->VariantTypeCode = math_type (X, Y); + return RESULT_SUCCESS; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_DIV (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + if (both_number_type (X, Y)) + { + /* X = (X / Y) */ + if (both_integer_type (X, Y)) + { + return OP_IDIV (X, Y); + } + if (Y->Number == 0) + { + /* - Evaluation of an expression results in division + * by zero (nonfatal, the recommended recovery + * procedure is to supply machine infinity with the + * sign of the numerator and continue) + */ + if (X->Number < 0) + { + /* NEGATIVE */ + X->Number = MINDBL; /* NEGATIVE INFINITY */ + } + else + { + /* POSITIVE */ + X->Number = MAXDBL; /* POSITIVE INFINITY */ + } + if (WARN_DIVISION_BY_ZERO) + { + return RESULT_ERROR; + } + /* CONTINUE */ + } + else + { + X->Number /= Y->Number; + } + X->VariantTypeCode = math_type (X, Y); + return RESULT_SUCCESS; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_MOD (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + if (both_number_type (X, Y)) + { + /* X = (X MOD Y) */ + X->Number = bwb_rint (X->Number); + Y->Number = bwb_rint (Y->Number); + if (Y->Number == 0) + { + /* - Evaluation of an expression results in division + * by zero (nonfatal, the recommended recovery + * procedure is to supply machine infinity with the + * sign of the numerator and continue) + */ + if (X->Number < 0) + { + /* NEGATIVE */ + X->Number = MINDBL; /* NEGATIVE INFINITY */ + } + else + { + /* POSITIVE */ + X->Number = MAXDBL; /* POSITIVE INFINITY */ + } + if (WARN_DIVISION_BY_ZERO) + { + return RESULT_ERROR; + } + /* CONTINUE */ + } + else + { + DoubleType N; + DoubleType I; + N = X->Number / Y->Number; + modf (N, &I); + N = X->Number - Y->Number * I; + X->Number = bwb_rint (N); + } + X->VariantTypeCode = math_type (X, Y); + return RESULT_SUCCESS; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_EXP (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + if (both_number_type (X, Y)) + { + /* X = (X ^ Y) */ + if (X->Number < 0 && Y->Number != bwb_rint (Y->Number)) + { + /*** FATAL ***/ + /* - Evaluation of the operation of + * involution results in a negative number + * being raised to a non-integral power + * (fatal). */ + X->Number = 0; + WARN_ILLEGAL_FUNCTION_CALL; + return RESULT_ERROR; + } + if (X->Number == 0 && Y->Number < 0) + { + /* - Evaluation of the operation of + * involution results in a zero being + * raised to a negative value (nonfatal, the + * recommended recovery procedure is to + * supply positive machine infinity and + * continue). */ + + X->Number = MAXDBL; + if (WARN_OVERFLOW) + { + /* ERROR */ + } + /* CONTINUE */ + } + else + { + X->Number = pow (X->Number, Y->Number); + } + X->VariantTypeCode = math_type (X, Y); + return RESULT_SUCCESS; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_NEG (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y == NULL); + if (Y != NULL) + { + WARN_INTERNAL_ERROR; + return RESULT_ERROR; + } + if (is_number_type (X)) + { + /* X = (- X) */ + X->Number = -X->Number; + X->VariantTypeCode = min_value_type (X); + return RESULT_SUCCESS; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_POS (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y == NULL); + if (Y != NULL) + { + WARN_INTERNAL_ERROR; + return RESULT_ERROR; + } + if (is_number_type (X)) + { + /* X = (+ X) */ + /* + X->Number = X->Number; + X->VariantTypeCode = min_value_type( X ); + */ + return RESULT_SUCCESS; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_OR (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + if (both_number_type (X, Y)) + { + /* X = (X OR Y) */ + if (both_are_long (X, Y)) + { + long x; + long y; + + x = (long) bwb_rint (X->Number); + y = (long) bwb_rint (Y->Number); + + if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* OR */ ) + { + if (x) + { + x = -1; + } + if (y) + { + y = -1; + } + } + + x = x | y; + + if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* OR */ ) + { + if (x) + { + x = 1; + } + } + + X->Number = x; + X->VariantTypeCode = min_value_type (X); + return RESULT_SUCCESS; + } + WARN_OVERFLOW; + return RESULT_ERROR; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_AND (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + if (both_number_type (X, Y)) + { + /* X = (X AND Y) */ + if (both_are_long (X, Y)) + { + long x; + long y; + + x = (long) bwb_rint (X->Number); + y = (long) bwb_rint (Y->Number); + + if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* AND */ ) + { + if (x) + { + x = -1; + } + if (y) + { + y = -1; + } + } + + x = x & y; + + if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* AND */ ) + { + if (x) + { + x = 1; + } + } + + X->Number = x; + X->VariantTypeCode = min_value_type (X); + return RESULT_SUCCESS; + } + WARN_OVERFLOW; + return RESULT_ERROR; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_XOR (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + if (both_number_type (X, Y)) + { + /* X = (X XOR Y) */ + if (both_are_long (X, Y)) + { + long x; + long y; + + x = (long) bwb_rint (X->Number); + y = (long) bwb_rint (Y->Number); + + if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* XOR */ ) + { + if (x) + { + x = -1; + } + if (y) + { + y = -1; + } + } + + x = x ^ y; + + if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* XOR */ ) + { + if (x) + { + x = 1; + } + } + + X->Number = x; + X->VariantTypeCode = min_value_type (X); + return RESULT_SUCCESS; + } + WARN_OVERFLOW; + return RESULT_ERROR; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_EQV (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + if (both_number_type (X, Y)) + { + /* X = (X EQV Y) = NOT ( X XOR Y ) */ + if (both_are_long (X, Y)) + { + long x; + long y; + + x = (long) bwb_rint (X->Number); + y = (long) bwb_rint (Y->Number); + + if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* EQV */ ) + { + if (x) + { + x = -1; + } + if (y) + { + y = -1; + } + } + + x = ~(x ^ y); + + if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* EQV */ ) + { + if (x) + { + x = 1; + } + } + + X->Number = x; + X->VariantTypeCode = min_value_type (X); + return RESULT_SUCCESS; + } + WARN_OVERFLOW; + return RESULT_ERROR; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_IMP (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + if (both_number_type (X, Y)) + { + /* X = (X IMP Y) = (X AND Y) OR (NOT X) */ + if (both_are_long (X, Y)) + { + long x; + long y; + + x = (long) bwb_rint (X->Number); + y = (long) bwb_rint (Y->Number); + + if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* IMP */ ) + { + if (x) + { + x = -1; + } + if (y) + { + y = -1; + } + } + + x = (x & y) | (~x); + + if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* IMP */ ) + { + if (x) + { + x = 1; + } + } + + X->Number = x; + X->VariantTypeCode = min_value_type (X); + return RESULT_SUCCESS; + } + WARN_OVERFLOW; + return RESULT_ERROR; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_NOT (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y == NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + if (Y != NULL) + { + WARN_INTERNAL_ERROR; + return RESULT_ERROR; + } + if (is_number_type (X)) + { + /* X = (NOT X) */ + if (is_long_value (X)) + { + long x; + + x = (long) bwb_rint (X->Number); + + if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* NOT */ ) + { + if (x) + { + x = -1; + } + } + + x = ~x; + + if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* NOT */ ) + { + if (x) + { + x = 1; + } + } + + X->Number = x; + X->VariantTypeCode = min_value_type (X); + return RESULT_SUCCESS; + } + WARN_OVERFLOW; + return RESULT_ERROR; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_MAX (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + if (both_number_type (X, Y)) + { + /* X = (X MAX Y) = IIF( X < Y, Y, X ) */ + if (X->Number < Y->Number) + { + X->Number = Y->Number; + } + if (both_integer_type (X, Y)) + { + X->Number = bwb_rint (X->Number); + } + X->VariantTypeCode = math_type (X, Y); + return RESULT_SUCCESS; + } + if (both_string_type (X, Y)) + { + /* X$ = ( X$ MAX Y$ ) == IIF( X$ < Y$, Y$, X$ ) */ + if (bwb_stricmp (X->Buffer, Y->Buffer) < 0) + { + RELEASE_VARIANT (X); + COPY_VARIANT (X, Y); + } + return RESULT_SUCCESS; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_MIN (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + if (both_number_type (X, Y)) + { + /* X = (X MIN Y) = IIF( X > Y, Y, X ) */ + if (X->Number > Y->Number) + { + X->Number = Y->Number; + } + if (both_integer_type (X, Y)) + { + X->Number = bwb_rint (X->Number); + } + X->VariantTypeCode = math_type (X, Y); + return RESULT_SUCCESS; + } + if (both_string_type (X, Y)) + { + /* X$ = ( X$ MIN Y$ ) == IIF( X$ > Y$, Y$, X$ ) */ + if (bwb_stricmp (X->Buffer, Y->Buffer) > 0) + { + RELEASE_VARIANT (X); + COPY_VARIANT (X, Y); + } + return RESULT_SUCCESS; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} + +/* +COMPARISON OPERATORS - these all return a TRUE/FALSE result in X +*/ + + +/* ------------------- equality */ + +static ResultType +test_eq (VariantType * X, VariantType * Y, int TrueValue, int FalseValue) +{ + + assert (X != NULL); + assert (Y != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + if (both_number_type (X, Y)) + { + /* X = IIF( X = Y, TrueValue, FalseValue ) */ + if (both_are_long (X, Y)) + { + long x; + long y; + + x = (long) bwb_rint (X->Number); + y = (long) bwb_rint (Y->Number); + + if (x == y) + { + X->Number = TrueValue; + } + else + { + X->Number = FalseValue; + } + } + else + { + if (X->Number == Y->Number) + { + X->Number = TrueValue; + } + else + { + X->Number = FalseValue; + } + + } + X->VariantTypeCode = IntegerTypeCode; + return RESULT_SUCCESS; + } + if (both_string_type (X, Y)) + { + /* X = IIF( X$ = Y$, TrueValue, FalseValue ) */ + /* NOTE: embedded NulChar terminate comparison */ + if (My->CurrentVersion->OptionFlags & OPTION_COMPARE_TEXT) + { + /* case insensitive */ + if (bwb_stricmp (X->Buffer, Y->Buffer) == 0) + { + X->Number = TrueValue; + } + else + { + X->Number = FalseValue; + } + } + else + { + /* case sensitive */ + if (bwb_strcmp (X->Buffer, Y->Buffer) == 0) + { + X->Number = TrueValue; + } + else + { + X->Number = FalseValue; + } + } + RELEASE_VARIANT (X); + RELEASE_VARIANT (Y); + X->VariantTypeCode = IntegerTypeCode; + return RESULT_SUCCESS; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_EQ (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + return test_eq (X, Y, TRUE, FALSE); +} +static ResultType +OP_NE (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + return test_eq (X, Y, FALSE, TRUE); +} + +/* ------------------- greater */ + +static ResultType +test_gt (VariantType * X, VariantType * Y, int TrueValue, int FalseValue) +{ + + assert (X != NULL); + assert (Y != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + if (both_number_type (X, Y)) + { + /* X = IIF( X > Y, TrueValue, FalseValue ) */ + if (both_are_long (X, Y)) + { + long x; + long y; + + x = (long) bwb_rint (X->Number); + y = (long) bwb_rint (Y->Number); + + if (x > y) + { + X->Number = TrueValue; + } + else + { + X->Number = FalseValue; + } + } + else + { + if (X->Number > Y->Number) + { + X->Number = TrueValue; + } + else + { + X->Number = FalseValue; + } + + } + X->VariantTypeCode = IntegerTypeCode; + return RESULT_SUCCESS; + } + if (both_string_type (X, Y)) + { + /* X = IIF( X$ > Y$, TrueValue, FalseValue ) */ + /* NOTE: embedded NUL characters terminate comparison */ + if (My->CurrentVersion->OptionFlags & OPTION_COMPARE_TEXT) + { + /* case insensitive */ + if (bwb_stricmp (X->Buffer, Y->Buffer) > 0) + { + X->Number = TrueValue; + } + else + { + X->Number = FalseValue; + } + } + else + { + /* case sensitive */ + if (bwb_strcmp (X->Buffer, Y->Buffer) > 0) + { + X->Number = TrueValue; + } + else + { + X->Number = FalseValue; + } + } + RELEASE_VARIANT (X); + RELEASE_VARIANT (Y); + X->VariantTypeCode = IntegerTypeCode; + return RESULT_SUCCESS; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_GT (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + return test_gt (X, Y, TRUE, FALSE); +} +static ResultType +OP_LE (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + return test_gt (X, Y, FALSE, TRUE); +} + +/* ------------------- lesser */ + +static ResultType +test_lt (VariantType * X, VariantType * Y, int TrueValue, int FalseValue) +{ + + assert (X != NULL); + assert (Y != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + if (both_number_type (X, Y)) + { + /* X = IIF( X < Y, TrueValue, FalseValue ) */ + if (both_are_long (X, Y)) + { + long x; + long y; + + x = (long) bwb_rint (X->Number); + y = (long) bwb_rint (Y->Number); + + if (x < y) + { + X->Number = TrueValue; + } + else + { + X->Number = FalseValue; + } + } + else + { + if (X->Number < Y->Number) + { + X->Number = TrueValue; + } + else + { + X->Number = FalseValue; + } + + } + X->VariantTypeCode = IntegerTypeCode; + return RESULT_SUCCESS; + } + if (both_string_type (X, Y)) + { + /* X = IIF( X$ < Y$, TrueValue, FalseValue ) */ + /* NOTE: embedded NUL characters terminate comparison */ + if (My->CurrentVersion->OptionFlags & OPTION_COMPARE_TEXT) + { + /* case insensitive */ + if (bwb_stricmp (X->Buffer, Y->Buffer) < 0) + { + X->Number = TrueValue; + } + else + { + X->Number = FalseValue; + } + } + else + { + /* case sensitive */ + if (bwb_strcmp (X->Buffer, Y->Buffer) < 0) + { + X->Number = TrueValue; + } + else + { + X->Number = FalseValue; + } + } + RELEASE_VARIANT (X); + RELEASE_VARIANT (Y); + X->VariantTypeCode = IntegerTypeCode; + return RESULT_SUCCESS; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} +static ResultType +OP_LT (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + return test_lt (X, Y, TRUE, FALSE); +} +static ResultType +OP_GE (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + return test_lt (X, Y, FALSE, TRUE); +} + +/* ------------------- like */ + +static ResultType +OP_LIKE (VariantType * X, VariantType * Y) +{ + + assert (X != NULL); + assert (Y != NULL); + if (both_string_type (X, Y)) + { + /* X = (X$ LIKE Y$) */ + int X_count; + int Y_count; + + X_count = 0; + Y_count = 0; + + if (IsLike (X->Buffer, &X_count, X->Length, + Y->Buffer, &Y_count, Y->Length)) + { + X->Number = TRUE; + } + else + { + X->Number = FALSE; + } + RELEASE_VARIANT (X); + RELEASE_VARIANT (Y); + X->VariantTypeCode = IntegerTypeCode; + return RESULT_SUCCESS; + } + WARN_TYPE_MISMATCH; + return RESULT_ERROR; +} + + +/* +-------------------------------------------------------------------------------------------- + Line Parsing Utilities +-------------------------------------------------------------------------------------------- +*/ + +static OperatorType * +buff_read_operator (char *buffer, int *position, unsigned char LastPrec, + unsigned char Arity) +{ + int p; + + assert (buffer != NULL); + assert (position != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + p = *position; + if (bwb_isalpha (buffer[p])) + { + /* only consider alphabetic operators */ + /* spaces between any character of the operator is not allowed */ + char name[NameLengthMax + 1]; + + if (buff_read_varname (buffer, &p, name)) + { + int i; + for (i = 0; i < NUM_OPERATORS; i++) + { + OperatorType *T; + + T = &OperatorTable[i]; + if (T->OptionVersionBitmask & My->CurrentVersion->OptionVersionValue) + { + if (T->ThisPrec >= LastPrec && T->Arity == Arity + && T->IsAlpha == IS_ALPHA) + { + /* possible */ + if (bwb_stricmp (T->Name, name) == 0) + { + /* FOUND */ + *position = p; + return T; + } + } + } + } + } + } + else + { + /* only consider non-alphabetic operators */ + /* spaces between any character of the operator is allowed */ + int i; + for (i = 0; i < NUM_OPERATORS; i++) + { + OperatorType *T; + + T = &OperatorTable[i]; + if (T->OptionVersionBitmask & My->CurrentVersion->OptionVersionValue) + { + if (T->ThisPrec >= LastPrec && T->Arity == Arity + && T->IsAlpha == NO_ALPHA) + { + /* possible */ + int m; /* number of characters actually matched */ + int n; /* number of characters to match */ + int q; /* position after skipping the characters */ + + n = bwb_strlen (T->Name); /* number of characters to match */ + q = p; + + for (m = 0; m < n && buff_skip_char (buffer, &q, T->Name[m]); m++); + if (m == n) + { + /* FOUND */ + *position = q; + return T; + } + } + } + } + } + /* NOT FOUND */ + return NULL; +} + +#if FALSE /* keep line_... */ +static OperatorType * +line_read_operator (LineType * line, unsigned char LastPrec, + unsigned char Arity) +{ + + assert (line != NULL); + return buff_read_operator (line->buffer, &(line->position), LastPrec, + Arity); +} +#endif +static ResultType +buff_read_string_constant (char *buffer, int *position, VariantType * X) +{ + int p; + + assert (buffer != NULL); + assert (position != NULL); + assert (X != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + p = *position; + if (buffer[p] == My->CurrentVersion->OptionQuoteChar) + { + int q; /* start of constant */ + X->VariantTypeCode = StringTypeCode; + p++; /* skip leading quote */ + /* determine the length of the quoted string */ + X->Length = 0; + q = p; + while (buffer[p]) + { + if (buffer[p] == My->CurrentVersion->OptionQuoteChar) + { + p++; /* quote */ + if (buffer[p] == My->CurrentVersion->OptionQuoteChar) + { + /* embedded string "...""..." */ + } + else + { + /* properly terminated string "...xx..." */ + break; + } + } + X->Length++; + p++; + } + if ((X->Buffer = + (char *) calloc (X->Length + 1 /* NulChar */ , + sizeof (char))) == NULL) + { + WARN_OUT_OF_MEMORY; + return RESULT_ERROR; + } + /* copy the quoted string */ + X->Length = 0; + p = q; + while (buffer[p]) + { + if (buffer[p] == My->CurrentVersion->OptionQuoteChar) + { + p++; /* skip quote */ + if (buffer[p] == My->CurrentVersion->OptionQuoteChar) + { + /* embedded string "...""..." */ + } + else + { + /* properly terminated string "...xx..." */ + break; + } + } + X->Buffer[X->Length] = buffer[p]; + X->Length++; + p++; + } + X->Buffer[X->Length] = NulChar; + *position = p; + return RESULT_SUCCESS; + } + /* NOT FOUND */ + return RESULT_UNPARSED; +} + +#if FALSE /* keep line_... */ +static ResultType +line_read_string_constant (LineType * line, VariantType * X) +{ + + assert (line != NULL); + assert (X != NULL); + return buff_read_string_constant (line->buffer, &(line->position), X); +} +#endif +extern ResultType +buff_read_hexadecimal_constant (char *buffer, int *position, VariantType * X, + int IsConsoleInput) +{ + /* &h... */ + int p; + + assert (buffer != NULL); + assert (position != NULL); + assert (X != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + + p = *position; + if (My->CurrentVersion->OptionFlags & OPTION_BUGS_ON ) /* allows hexadecimal constants */ + { + if (buffer[p] == '&') + { + p++; /* skip '&' */ + if (bwb_tolower (buffer[p]) == 'h') + { + /* &h... */ + p++; /* skip 'h' */ + if (bwb_isxdigit (buffer[p])) + { + /* &hABCD */ + int n; /* number of characters read */ + unsigned long x; /* value read */ + + n = 0; + x = 0; + + /* if( sscanf( &buffer[ p ], "%lx%n", &x, &n ) == 1 ) */ + if (sscanf (&buffer[p], HexScanFormat, &x, &n) == 1) + { + /* FOUND */ + p += n; + + X->Number = x; + X->VariantTypeCode = min_value_type (X); + if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_ON)) /* TypeSuffix allowed on constants */ + { + char TypeCode; + TypeCode = Char_to_TypeCode (buffer[p]); + switch (TypeCode) + { + case ByteTypeCode: + case IntegerTypeCode: + case LongTypeCode: + case CurrencyTypeCode: + case SingleTypeCode: + case DoubleTypeCode: + p++; /* skip TypeCode */ + /* verify the value actually fits in the declared type */ + X->VariantTypeCode = TypeCode; + TypeCode = Largest_TypeCode (TypeCode, X); + if (X->VariantTypeCode != TypeCode) + { + /* declared type is too small */ + if (IsConsoleInput) + { + /* + ** + ** The user will re-enter the data + ** + */ + return RESULT_UNPARSED; + } + if (WARN_OVERFLOW) + { + /* ERROR */ + return RESULT_ERROR; + } + /* CONTINUE */ + X->VariantTypeCode = TypeCode; + } + break; + case StringTypeCode: + /* oops */ + if (IsConsoleInput) + { + /* + ** + ** The user will re-enter the data + ** + */ + return RESULT_UNPARSED; + } + WARN_SYNTAX_ERROR; + return RESULT_ERROR; + /* break; */ + default: + X->VariantTypeCode = min_value_type (X); + } + } + *position = p; + return RESULT_SUCCESS; + } + } + /* not HEXADECIMAL */ + } + } + } + /* NOT FOUND */ + return RESULT_UNPARSED; +} + +#if FALSE /* keep line_... */ +static ResultType +line_read_hexadecimal_constant (LineType * line, VariantType * X) +{ + + assert (line != NULL); + assert (X != NULL); + return buff_read_hexadecimal_constant (line->buffer, &(line->position), X, + FALSE); +} +#endif +extern ResultType +buff_read_octal_constant (char *buffer, int *position, VariantType * X, + int IsConsoleInput) +{ + /* &o... */ + int p; + + assert (buffer != NULL); + assert (position != NULL); + assert (X != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + + p = *position; + + if (My->CurrentVersion->OptionFlags & OPTION_BUGS_ON ) /* allows octal constants */ + { + if (buffer[p] == '&') + { + p++; /* skip '&' */ + if (bwb_tolower (buffer[p]) == 'o') + { + /* &o777 */ + p++; /* skip 'o' */ + /* fall-thru */ + } + if (bwb_isodigit (buffer[p])) + { + /* &o777 */ + /* &777 */ + int n; /* number of characters read */ + unsigned long x; /* value read */ + + n = 0; + x = 0; + + /* if( sscanf( &buffer[ p ], "%64lo%n", &x, &n ) == 1 ) */ + if (sscanf (&buffer[p], OctScanFormat, &x, &n) == 1) + { + /* FOUND */ + p += n; + + X->Number = x; + X->VariantTypeCode = min_value_type (X); + if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_ON)) /* TypeSuffix allowed on constants */ + { + char TypeCode; + + TypeCode = Char_to_TypeCode (buffer[p]); + switch (TypeCode) + { + case ByteTypeCode: + case IntegerTypeCode: + case LongTypeCode: + case CurrencyTypeCode: + case SingleTypeCode: + case DoubleTypeCode: + p++; /* skip TypeCode */ + /* verify the value actually fits in the declared type */ + X->VariantTypeCode = TypeCode; + TypeCode = Largest_TypeCode (TypeCode, X); + if (X->VariantTypeCode != TypeCode) + { + /* declared type is too small */ + if (IsConsoleInput) + { + /* + ** + ** The user will re-enter the data + ** + */ + return RESULT_UNPARSED; + } + if (WARN_OVERFLOW) + { + /* ERROR */ + return RESULT_ERROR; + } + /* CONTINUE */ + X->VariantTypeCode = TypeCode; + } + break; + case StringTypeCode: + /* oops */ + if (IsConsoleInput) + { + /* + ** + ** The user will re-enter the data + ** + */ + return RESULT_UNPARSED; + } + WARN_SYNTAX_ERROR; + return RESULT_ERROR; + /* break; */ + default: + X->VariantTypeCode = min_value_type (X); + } + } + *position = p; + return RESULT_SUCCESS; + } + } + } + } + /* NOT FOUND */ + return RESULT_UNPARSED; +} + +#if FALSE /* keep line_... */ +static ResultType +line_read_octal_constant (LineType * line, VariantType * X) +{ + + assert (line != NULL); + assert (X != NULL); + return buff_read_octal_constant (line->buffer, &(line->position), X, FALSE); +} +#endif +static ResultType +buff_read_internal_constant (char *buffer, int *position, VariantType * X) +{ + /* &... */ + int p; + + assert (buffer != NULL); + assert (position != NULL); + assert (X != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + + p = *position; + + if (My->CurrentVersion->OptionVersionValue & (S70 | I70 | I73)) + { + /* IBM System/360 and System/370 BASIC dialects */ + if (buffer[p] == '&') + { + p++; /* skip '&' */ + if (bwb_isalpha (buffer[p])) + { + char *S; + S = &(buffer[p]); + if (bwb_strnicmp (S, "PI", 2) == 0) + { + /* &PI */ + p += 2; + X->Number = 3.14159265358979; + X->VariantTypeCode = DoubleTypeCode; + *position = p; + return RESULT_SUCCESS; + } + if (bwb_strnicmp (S, "E", 1) == 0) + { + /* &E */ + p += 1; + X->Number = 2.71828182845905; + X->VariantTypeCode = DoubleTypeCode; + *position = p; + return RESULT_SUCCESS; + } + if (bwb_strnicmp (S, "SQR2", 4) == 0) + { + /* &SQR2 */ + p += 4; + X->Number = 1.41421356237309; + X->VariantTypeCode = DoubleTypeCode; + *position = p; + return RESULT_SUCCESS; + } + /* NOT a magic word */ + } + } + } + /* NOT FOUND */ + return RESULT_UNPARSED; +} + +#if FALSE /* keep line_... */ +static ResultType +line_read_internal_constant (LineType * line, VariantType * X) +{ + + assert (line != NULL); + assert (X != NULL); + return buff_read_internal_constant (line->buffer, &(line->position), X); +} +#endif +extern ResultType +buff_read_decimal_constant (char *buffer, int *position, VariantType * X, + int IsConsoleInput) +{ + int p; + + assert (buffer != NULL); + assert (position != NULL); + assert (X != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + + p = *position; + if (bwb_isdigit (buffer[p]) || buffer[p] == '.') + { + /* .12345 */ + /* 123.45 */ + /* 123456 */ + /* 123E45 */ + /* TODO: 'D' instead of 'E' */ + int n; /* number of characters read */ + DoubleType x; /* value read */ + + + n = 0; + x = 0; + + /* if( sscanf( &buffer[ p ], "%lg%n", &X->Number, &n ) == 1 ) */ + if (sscanf (&buffer[p], DecScanFormat, &x, &n) == 1) + { + /* FOUND */ + p += n; + + /* VerifyNumeric */ + if (isnan (x)) + { + /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ + WARN_INTERNAL_ERROR; + return RESULT_ERROR; + } + if (isinf (x)) + { + /* - 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 (x < 0) + { + x = MINDBL; + } + else + { + x = MAXDBL; + } + if (IsConsoleInput) + { + /* + ** + ** The user will re-enter the data + ** + */ + return RESULT_UNPARSED; + } + if (WARN_OVERFLOW) + { + /* ERROR */ + return RESULT_ERROR; + } + /* CONTINUE */ + } + /* OK */ + X->Number = x; + X->VariantTypeCode = DoubleTypeCode; /* min_value_type( X ); */ + if (My->CurrentVersion->OptionFlags & OPTION_BUGS_ON ) /* TypeSuffix allowed on constants */ + { + char TypeCode; + TypeCode = Char_to_TypeCode (buffer[p]); + switch (TypeCode) + { + case ByteTypeCode: + case IntegerTypeCode: + case LongTypeCode: + case CurrencyTypeCode: + case SingleTypeCode: + case DoubleTypeCode: + p++; /* skip TypeCode */ + /* verify the value actually fits in the declared type */ + X->VariantTypeCode = TypeCode; + TypeCode = Largest_TypeCode (TypeCode, X); + if (X->VariantTypeCode != TypeCode) + { + /* declared type is too small */ + if (IsConsoleInput) + { + /* + ** + ** The user will re-enter the data + ** + */ + return RESULT_UNPARSED; + } + if (WARN_OVERFLOW) + { + /* ERROR */ + return RESULT_ERROR; + } + /* CONTINUE */ + X->VariantTypeCode = TypeCode; + } + break; + case StringTypeCode: + /* oops */ + if (IsConsoleInput) + { + /* + ** + ** The user will re-enter the data + ** + */ + return RESULT_UNPARSED; + } + WARN_SYNTAX_ERROR; + return RESULT_ERROR; + /* break; */ + default: + X->VariantTypeCode = DoubleTypeCode; /* min_value_type( X ); */ + } + } + *position = p; + return RESULT_SUCCESS; + } + } + /* NOT FOUND */ + return RESULT_UNPARSED; +} + +#if FALSE /* keep line_... */ +static int +line_read_decimal_constant (LineType * line, VariantType * X) +{ + + assert (line != NULL); + assert (X != NULL); + return buff_read_decimal_constant (line->buffer, &(line->position), X, + FALSE); +} +#endif + +static ResultType +buff_read_function (char *buffer, int *position, VariantType * X) +{ + int p; + char name[NameLengthMax + 1]; + + assert (buffer != NULL); + assert (position != NULL); + assert (X != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + + p = *position; + if (buff_read_varname (buffer, &p, name)) + { + if (UserFunction_name (name) || IntrinsicFunction_name (name)) + { + /* ---------------------------------------------------------------------------- */ + /* if( TRUE ) */ + { + /* here we handle some pseudo-functions that return information about arrays */ + char Xbound; + + Xbound = NulChar; + if (buff_peek_LparenChar (buffer, &p)) + { + if (bwb_stricmp (name, "DET") == 0) + { + /* N = DET( varname ) */ + /* N = DET is handled by F_DET_N */ + Xbound = 'd'; + } + else if (bwb_stricmp (name, "DIM") == 0) + { + /* N = DIM( varname ) */ + /* return total number of dimensions */ + Xbound = 'D'; + } + else if (bwb_stricmp (name, "SIZE") == 0) + { + if (My->CurrentVersion->OptionVersionValue & (C77)) + { + /* N = SIZE( filename ) is handled by F_SIZE_A_N */ + } + else + { + /* N = SIZE( varname ) */ + /* return total number of elements */ + Xbound = 'S'; + } + } + else if (bwb_stricmp (name, "LBOUND") == 0) + { + /* N = LBOUND( varname [ , dimension ] ) */ + /* return LOWER bound */ + Xbound = 'L'; + } + else if (bwb_stricmp (name, "UBOUND") == 0) + { + /* N = UBOUND( varname [ , dimension ] ) */ + /* return UPPER bound */ + Xbound = 'U'; + } + } + if (Xbound) + { + VariableType *v; + int dimension; + char varname[NameLengthMax + 1]; + + v = NULL; + dimension = 0; /* default */ + + + if (buff_skip_LparenChar (buffer, &p) == FALSE) + { + WARN_SYNTAX_ERROR; + return RESULT_ERROR; + } + if (buff_read_varname (buffer, &p, varname) == FALSE) + { + WARN_SYNTAX_ERROR; + return RESULT_ERROR; + } + /* search for array */ + v = mat_find (varname); + if (v == NULL) + { + WARN_TYPE_MISMATCH; + return RESULT_ERROR; + } + if (v->dimensions == 0) + { + /* calling DET(), DIM(), SIZE(), LBOUND() or UBOUND() on a scalar is an ERROR */ + WARN_TYPE_MISMATCH; + return RESULT_ERROR; + } + switch (Xbound) + { + case 'd': /* DET() */ + case 'D': /* DIM() */ + case 'S': /* SIZE() */ + break; + case 'L': /* LBOUND() */ + case 'U': /* UBOUND() */ + if (buff_skip_seperator (buffer, &p)) + { + ResultType ResultCode; + VariantType t; + VariantType *T; + + T = &t; + ResultCode = buff_read_expr (buffer, &p, T, 1); + if (ResultCode != RESULT_SUCCESS) + { + /* ERROR */ + RELEASE_VARIANT (T); + return ResultCode; + } + if (is_string_type (T)) + { + RELEASE_VARIANT (T); + WARN_TYPE_MISMATCH; + return RESULT_ERROR; + } + T->Number = bwb_rint (T->Number); + if (T->Number < 1 || T->Number > v->dimensions) + { + WARN_TYPE_MISMATCH; + return RESULT_ERROR; + } + dimension = (int) bwb_rint (T->Number); + dimension--; /* BASIC to C */ + } + else + { + dimension = 0; /* default */ + } + break; + default: + WARN_INTERNAL_ERROR; + return RESULT_ERROR; + /* break; */ + } + if (buff_skip_RparenChar (buffer, &p) == FALSE) + { + WARN_SYNTAX_ERROR; + return RESULT_ERROR; + } + /* OK */ + switch (Xbound) + { + case 'd': /* DET() */ + Determinant (v); + X->Number = My->LastDeterminant; + break; + case 'D': /* DIM() */ + X->Number = v->dimensions; + break; + case 'S': /* SIZE() */ + X->Number = v->array_units; + break; + case 'L': /* LBOUND() */ + X->Number = v->LBOUND[dimension]; + break; + case 'U': /* UBOUND() */ + X->Number = v->UBOUND[dimension]; + break; + default: + WARN_INTERNAL_ERROR; + return RESULT_ERROR; + /* break; */ + } + X->VariantTypeCode = LongTypeCode; + *position = p; + return RESULT_SUCCESS; + } + } + /* ---------------------------------------------------------------------------- */ + /* if( TRUE ) */ + { + /* it is a function */ + UserFunctionType *L; + unsigned char ParameterCount; + ParamBitsType ParameterTypes; + VariableType *argv; + VariableType *argn; + + ParameterCount = 0; + ParameterTypes = 0; + argv = var_chain (NULL); /* RETURN variable */ + argn = NULL; + + if (buff_skip_LparenChar (buffer, &p)) + { + if (buff_skip_RparenChar (buffer, &p)) + { + /* RND() */ + } + else + { + /* RND( 1, 2, 3 ) */ + do + { + ResultType ResultCode; + VariantType T; + + ResultCode = buff_read_expr (buffer, &p, &T, 1); + if (ResultCode != RESULT_SUCCESS) + { + /* ERROR */ + var_free (argv); /* free ARGV chain */ + return ResultCode; + } + /* add value to ARGV chain */ + argn = var_chain (argv); + /* 'argn' is the variable to use */ + if (is_string_type (&T)) + { + /* STRING */ + var_make (argn, StringTypeCode); + if ((argn->Value.String = + (StringType *) calloc (1, sizeof (StringType))) == NULL) + { + WARN_OUT_OF_MEMORY; + return RESULT_ERROR; + } + PARAM_LENGTH = T.Length; + /* PARAM_BUFFER = T.Buffer; */ + if ((PARAM_BUFFER = + (char *) calloc (T.Length + 1 /* NulChar */ , + sizeof (char))) == NULL) + { + WARN_OUT_OF_MEMORY; + return RESULT_ERROR; + } + bwb_memcpy (PARAM_BUFFER, T.Buffer, T.Length); + PARAM_BUFFER[PARAM_LENGTH] = NulChar; + /* add type to ParameterTypes */ + if (ParameterCount < MAX_FARGS) + { + ParameterTypes |= (1 << ParameterCount); + } + } + else + { + /* NUMBER */ + var_make (argn, DoubleTypeCode); + PARAM_NUMBER = T.Number; + } + /* increment ParameterCount */ + if (ParameterCount < 255 /* (...) */ ) + { + ParameterCount++; + } + /* RELEASE_VARIANT( &T ); */ + } + while (buff_skip_seperator (buffer, &p)); + + + if (buff_skip_RparenChar (buffer, &p) == FALSE) + { + /* ERROR */ + var_free (argv); /* free ARGV chain */ + WARN_SYNTAX_ERROR; + return RESULT_ERROR; + } + } + } + else + { + /* RND */ + } + + /* search for exact match to the function parameter signature */ + if (ParameterCount > MAX_FARGS) + { + /* FORCE (...) */ + ParameterCount = 255; /* (...) */ + ParameterTypes = 0; + } + /* did we find the correct function above? */ + L = UserFunction_find_exact (name, ParameterCount, ParameterTypes); + if (L == NULL) + { + L = UserFunction_find_exact (name, 255 /* (...) */ , 0); + } + if (L != NULL) + { + /* USER function */ + if (L->line == NULL) + { + var_free (argv); /* free ARGV chain */ + WARN_INTERNAL_ERROR; + return RESULT_ERROR; + } + /* defaullt the return value */ + var_make (argv, L->ReturnTypeCode); + bwb_strcpy (argv->name, name); + if (VAR_IS_STRING (argv)) + { + RESULT_BUFFER = My->MaxLenBuffer; + RESULT_LENGTH = 0; + RESULT_BUFFER[RESULT_LENGTH] = NulChar; + } + else + { + RESULT_NUMBER = 0; + } + /* execute function */ + /* for all USER DEFINED FUNCTIONS: f->UniqueID == line number of DEF FN... */ + switch (L->line->cmdnum) + { + case C_DEF: /* execute a user function declared using DEF FN ...(...) = ... */ + case C_FUNCTION: /* execute a user function declared using FUNCTION ...(...) */ + case C_SUB: /* execute a user subroutine declared using SUB ...(...) */ + IntrinsicFunction_deffn (ParameterCount, argv, L); + break; + case C_DEF8LBL: /* IF ERL > label1 AND ERL < label2 THEN ... */ + if (ParameterCount > 0) + { + var_free (argv); /* free ARGV chain */ + WARN_ILLEGAL_FUNCTION_CALL; + return RESULT_ERROR; + } + /* return the line number associated with the label */ + RESULT_NUMBER = L->line->number; + break; + default: + /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ + var_free (argv); /* free ARGV chain */ + WARN_INTERNAL_ERROR; + return RESULT_ERROR; + /* break; */ + } + } + else + { + /* INTRINSIC */ + IntrinsicFunctionType *f; + + f = + IntrinsicFunction_find_exact (name, ParameterCount, + ParameterTypes); + if (f == NULL) + { + /* NOT FOUND */ + f = IntrinsicFunction_find_exact (name, 255 /* (...) */ , 0); + } + if (f == NULL) + { + /* NOT FOUND */ + var_free (argv); /* free ARGV chain */ + WARN_ILLEGAL_FUNCTION_CALL; + return RESULT_ERROR; + } + /* FOUND */ + /* defaullt the return value */ + var_make (argv, f->ReturnTypeCode); + bwb_strcpy (argv->name, name); + if (VAR_IS_STRING (argv)) + { + RESULT_BUFFER = My->MaxLenBuffer; + RESULT_LENGTH = 0; + RESULT_BUFFER[RESULT_LENGTH] = NulChar; + } + else + { + RESULT_NUMBER = 0; + } + /* execute function */ + /* for all INTRINSIC FUNCTIONS: f->UniqueID == #define F_... */ + IntrinsicFunction_execute (ParameterCount, argv, f); + } + /* return results */ + X->VariantTypeCode = argv->VariableTypeCode; + if (VAR_IS_STRING (argv)) + { + if (RESULT_LENGTH > MAXLEN) + { + WARN_STRING_TOO_LONG; /* buff_read_function */ + RESULT_LENGTH = MAXLEN; + } + X->Length = RESULT_LENGTH; + if ((X->Buffer = + (char *) calloc (X->Length + 1 /* NulChar */ , + sizeof (char))) == NULL) + { + WARN_OUT_OF_MEMORY; + return RESULT_ERROR; + } + bwb_memcpy (X->Buffer, RESULT_BUFFER, X->Length); + X->Buffer[X->Length] = NulChar; + RESULT_BUFFER = NULL; + } + else + { + X->Number = RESULT_NUMBER; + } + /* free ARGV chain */ + var_free (argv); + /* OK */ + *position = p; + return RESULT_SUCCESS; + } + /* ---------------------------------------------------------------------------- */ + } + } + /* NOT FOUND */ + return RESULT_UNPARSED; +} + +#if FALSE /* keep line_... */ +static int +line_read_function (LineType * line, VariantType * X) +{ + + assert (line != NULL); + assert (X != NULL); + return buff_read_function (line->buffer, &(line->position), X); +} +#endif + + +static ResultType +buff_read_variable (char *buffer, int *position, VariantType * X) +{ + int p; + char name[NameLengthMax + 1]; + + assert (buffer != NULL); + assert (position != NULL); + assert (X != NULL); + + + p = *position; + if (buff_read_varname (buffer, &p, name)) + { + VariableType *v; + int n_params; + int pp[MAX_DIMS]; + + if (buff_peek_LparenChar (buffer, &p)) + { + /* array */ + if (buff_peek_array_dimensions (buffer, &p, &n_params) == FALSE) + { + WARN_SYNTAX_ERROR; + return RESULT_ERROR; + } + v = var_find (name, n_params, TRUE); + } + else + { + /* scalar */ + v = var_find (name, 0, TRUE); + } + if (v == NULL) + { + WARN_VARIABLE_NOT_DECLARED; + return RESULT_ERROR; + } + if (v->dimensions > 0) + { + /* array */ + int n; + + if (buff_read_array_dimensions (buffer, &p, &n_params, pp) == FALSE) + { + WARN_SUBSCRIPT_OUT_OF_RANGE; + return RESULT_ERROR; + } + for (n = 0; n < v->dimensions; n++) + { + if (pp[n] < v->LBOUND[n] || pp[n] > v->UBOUND[n]) + { + WARN_SUBSCRIPT_OUT_OF_RANGE; + return RESULT_ERROR; + } + v->VINDEX[n] = pp[n]; + } + } + if (var_get (v, X) == FALSE) + { + WARN_TYPE_MISMATCH; + return RESULT_ERROR; + } + *position = p; + return RESULT_SUCCESS; + } + /* NOT FOUND */ + return RESULT_UNPARSED; +} + +#if FALSE /* keep line_... */ +static int +line_read_variable (LineType * line, VariantType * X) +{ + + assert (line != NULL); + assert (X != NULL); + return buff_read_variable (line->buffer, &(line->position), X); +} +#endif +/* +-------------------------------------------------------------------------------------------- + Precedence Climbing Expression Parser +-------------------------------------------------------------------------------------------- +*/ + +/* +// Read an infix expression containing top-level operators that bind at least +// as tightly as the given precedence. +// Don't consume the first non-digit character after the last number. +// Complain if you can't even find the first number, +// or if there is an operator with no following number. +*/ +static ResultType +buff_read_expr (char *buffer, int *position, VariantType * X, + unsigned char LastPrec) +{ + ResultType ResultCode; + OperatorType *C; + int p; + + assert (buffer != NULL); + assert (position != NULL); + assert (X != NULL); + + + p = *position; + bwb_memset (X, 0, sizeof (VariantType)); /* NOTE */ + + ResultCode = buff_read_primary (buffer, &p, X); + if (ResultCode != RESULT_SUCCESS) + { + return ResultCode; + } + if (X->VariantTypeCode == NulChar) + { + /* we do not know the primary's type */ + WARN_INTERNAL_ERROR; + return RESULT_ERROR; + } + buff_skip_spaces (buffer, &p); /* keep this */ + while ((C = buff_read_operator (buffer, &p, LastPrec, BINARY)) != NULL) + { + VariantType Y; + + ResultCode = buff_read_expr (buffer, &p, &Y, C->NextPrec); + if (ResultCode != RESULT_SUCCESS) + { + /* ERROR */ + if (Y.Buffer != NULL) + { + free (Y.Buffer); + Y.Buffer = NULL; + } + return ResultCode; + } + ResultCode = C->Eval (X, &Y); + if (Y.Buffer != NULL) + { + free (Y.Buffer); + Y.Buffer = NULL; + } + if (ResultCode != RESULT_SUCCESS) + { + /* ERROR */ + return ResultCode; + } + /* OK */ + } + /* + Normal termination, such as end-of-line, ',', or "THEN". + */ + *position = p; + return RESULT_SUCCESS; +} + +#if FALSE /* keep line_... */ +static ResultType +line_read_expr (LineType * line, VariantType * X, unsigned char LastPrec) +{ + + assert (line != NULL); + assert (X != NULL); + return buff_read_expr (line->buffer, &(line->position), X, LastPrec); +} +#endif +static ResultType +buff_read_primary (char *buffer, int *position, VariantType * X) +{ + ResultType ResultCode; + OperatorType *C; + int p; + + assert (buffer != NULL); + assert (position != NULL); + assert (X != NULL); + + + p = *position; + buff_skip_spaces (buffer, &p); /* keep this */ + if (buff_is_eol (buffer, &p)) + { + /* we expected to find something, but there is nothing here */ + WARN_SYNTAX_ERROR; + return RESULT_ERROR; + } + /* there is something to parse */ + if (buff_skip_LparenChar (buffer, &p)) + { + /* nested expression */ + ResultCode = buff_read_expr (buffer, &p, X, 1); + if (ResultCode != RESULT_SUCCESS) + { + return ResultCode; + } + if (buff_skip_RparenChar (buffer, &p) == FALSE) + { + WARN_SYNTAX_ERROR; + return RESULT_ERROR; + } + *position = p; + return RESULT_SUCCESS; + } + /* not a nested expression */ + C = buff_read_operator (buffer, &p, 1, UNARY); + if (C != NULL) + { + ResultCode = buff_read_expr (buffer, &p, X, C->NextPrec); + if (ResultCode != RESULT_SUCCESS) + { + return ResultCode; + } + ResultCode = C->Eval (X, NULL); + if (ResultCode != RESULT_SUCCESS) + { + return ResultCode; + } + *position = p; + return RESULT_SUCCESS; + } + /* not an operator */ + ResultCode = buff_read_string_constant (buffer, &p, X); + if (ResultCode != RESULT_UNPARSED) + { + /* either OK or ERROR */ + if (ResultCode == RESULT_SUCCESS) + { + *position = p; + } + return ResultCode; + } + ResultCode = buff_read_hexadecimal_constant (buffer, &p, X, FALSE); + if (ResultCode != RESULT_UNPARSED) + { + /* either OK or ERROR */ + if (ResultCode == RESULT_SUCCESS) + { + *position = p; + } + return ResultCode; + } + ResultCode = buff_read_octal_constant (buffer, &p, X, FALSE); + if (ResultCode != RESULT_UNPARSED) + { + /* either OK or ERROR */ + if (ResultCode == RESULT_SUCCESS) + { + *position = p; + } + return ResultCode; + } + ResultCode = buff_read_internal_constant (buffer, &p, X); + if (ResultCode != RESULT_UNPARSED) + { + /* either OK or ERROR */ + if (ResultCode == RESULT_SUCCESS) + { + *position = p; + } + return ResultCode; + } + ResultCode = buff_read_decimal_constant (buffer, &p, X, FALSE); + if (ResultCode != RESULT_UNPARSED) + { + /* either OK or ERROR */ + if (ResultCode == RESULT_SUCCESS) + { + *position = p; + } + return ResultCode; + } + /* not a constant */ + ResultCode = buff_read_function (buffer, &p, X); + if (ResultCode != RESULT_UNPARSED) + { + /* either OK or ERROR */ + if (ResultCode == RESULT_SUCCESS) + { + *position = p; + } + return ResultCode; + } + /* not a function */ + ResultCode = buff_read_variable (buffer, &p, X); + /* + the variable will be implicitly created unless: + OPTION EXPLICIT ON, or + the varname matches an existing command/function/operator. + */ + if (ResultCode != RESULT_UNPARSED) + { + /* either OK or ERROR */ + if (ResultCode == RESULT_SUCCESS) + { + *position = p; + } + return ResultCode; + } + /* not a variable */ + WARN_SYNTAX_ERROR; + return RESULT_ERROR; +} + +#if FALSE /* keep line_... */ +static ResultType +line_read_primary (LineType * line, VariantType * X) +{ + + assert (line != NULL); + assert (X != NULL); + return buff_read_primary (line->buffer, &(line->position), X); +} +#endif + + +int +buff_read_expression (char *buffer, int *position, VariantType * X) +{ + int p; + + assert (buffer != NULL); + assert (position != NULL); + assert (X != NULL); + + p = *position; + if (buff_read_expr (buffer, &p, X, 1) == RESULT_SUCCESS) + { + switch (X->VariantTypeCode) + { + case ByteTypeCode: + case IntegerTypeCode: + case LongTypeCode: + case CurrencyTypeCode: + case SingleTypeCode: + case DoubleTypeCode: + case StringTypeCode: + /* OK */ + break; + default: + /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ + RELEASE_VARIANT (X); + WARN_INTERNAL_ERROR; + return FALSE; + /* break; */ + } + *position = p; + return TRUE; + } + RELEASE_VARIANT (X); /* NEW */ + return FALSE; +} + + +int +line_read_expression (LineType * line, VariantType * X) +{ + + assert (line != NULL); + assert (X != NULL); + return buff_read_expression (line->buffer, &(line->position), X); +} + +/* +-------------------------------------------------------------------------------------------- + BASIC commands +-------------------------------------------------------------------------------------------- +*/ + +#if FALSE /* keep line_... */ +LineType * +bwb_EVAL (LineType * line) +{ + /* + EVAL 1 + 2 + 3 + EVAL "ABC" & "DEF" + */ + ResultType ResultCode; + VariantType x; + VariantType *X; + + assert (line != NULL); + + + VX = &x; + ResultCode = line_read_expression (line, X); + if (ResultCode != RESULT_SUCCESS) + { + return (line); + } + + switch (X->VariantTypeCode) + { + case ByteTypeCode: + case IntegerTypeCode: + case LongTypeCode: + case CurrencyTypeCode: + case SingleTypeCode: + case DoubleTypeCode: + printf (" NUMBER: %g, %c\n", X->Number, X->VariantTypeCode); + ResetConsoleColumn (); + break; + case StringTypeCode: + printf (" STRING: %s, %c\n", X->Buffer, X->VariantTypeCode); + ResetConsoleColumn (); + break; + default: + /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ + WARN_INTERNAL_ERROR; + break; + } + RELEASE_VARIANT (X); + return (line); +} +#endif + +LineType * +bwb_OPTION_DISABLE_OPERATOR (LineType * l) +{ + /* OPTION DISABLE OPERATOR name$ */ + int IsFound; + + assert (l != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + assert(My->SYSOUT != NULL); + assert(My->SYSOUT->cfp != NULL); + + IsFound = FALSE; + /* Get OPERATOR */ + { + char *Value; + + Value = NULL; + if (line_read_string_expression (l, &Value) == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + if (Value == NULL) + { + WARN_SYNTAX_ERROR; + return (l); + } + { + /* Name */ + int i; + for (i = 0; i < NUM_OPERATORS; i++) + { + if (bwb_stricmp (Value, OperatorTable[i].Name) == 0) + { + /* FOUND */ + /* DISABLE OPERATOR */ + OperatorTable[i].OptionVersionBitmask &= + ~My->CurrentVersion->OptionVersionValue; + IsFound = TRUE; + } + } + } + free (Value); + Value = NULL; + } + if (IsFound == FALSE) + { + /* display warning message */ + fprintf (My->SYSOUT->cfp, "IGNORED: %s\n", l->buffer); + ResetConsoleColumn (); + } + return (l); +} + +LineType * +bwb_OPTION_ENABLE_OPERATOR (LineType * l) +{ + /* OPTION ENABLE OPERATOR name$ */ + int IsFound; + + assert (l != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + assert(My->SYSOUT != NULL); + assert(My->SYSOUT->cfp != NULL); + + + IsFound = FALSE; + /* Get OPERATOR */ + { + char *Value; + + Value = NULL; + if (line_read_string_expression (l, &Value) == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + if (Value == NULL) + { + WARN_SYNTAX_ERROR; + return (l); + } + { + /* Name */ + int i; + for (i = 0; i < NUM_OPERATORS; i++) + { + if (bwb_stricmp (Value, OperatorTable[i].Name) == 0) + { + /* FOUND */ + /* ENABLE OPERATOR */ + OperatorTable[i].OptionVersionBitmask |= + My->CurrentVersion->OptionVersionValue; + IsFound = TRUE; + } + } + } + free (Value); + Value = NULL; + } + if (IsFound == FALSE) + { + /* display warning message */ + fprintf (My->SYSOUT->cfp, "IGNORED: %s\n", l->buffer); + ResetConsoleColumn (); + } + return (l); +} + +void +DumpOneOperatorSyntax (FILE * file, int IsXref, int n) +{ + + assert (file != NULL); + + if (n < 0 || n >= NUM_OPERATORS) + { + return; + } + /* NAME */ + { + FixDescription (file, " SYNTAX: ", OperatorTable[n].Syntax); + } + /* DESCRIPTION */ + { + + FixDescription (file, "DESCRIPTION: ", OperatorTable[n].Description); + } + /* PRECEDENCE */ + { + fprintf (file, " PRECEDENCE: %d\n", OperatorTable[n].ThisPrec); + } + /* COMPATIBILITY */ + if (IsXref) + { + int i; + fprintf (file, " VERSIONS:\n"); + for (i = 0; i < NUM_VERSIONS; i++) + { + char X; + if (OperatorTable[n].OptionVersionBitmask & bwb_vertable[i]. + OptionVersionValue) + { + /* SUPPORTED */ + X = 'X'; + } + else + { + /* NOT SUPPORTED */ + X = '_'; + } + fprintf (file, " [%c] %s\n", X, bwb_vertable[i].Name); + } + } + + fflush (file); +} + +void +DumpAllOperatorSyntax (FILE * file, int IsXref, + OptionVersionType OptionVersionValue) +{ + /* for the C maintainer */ + int n; + + assert (file != NULL); + + fprintf (file, + "============================================================\n"); + fprintf (file, + " OPERATORS \n"); + fprintf (file, + "============================================================\n"); + fprintf (file, "\n"); + fprintf (file, "\n"); + SortAllOperatorsForManual (); + for (n = 0; n < NUM_OPERATORS; n++) + { + if (OperatorTable[n].OptionVersionBitmask & OptionVersionValue) + { + fprintf (file, + "------------------------------------------------------------\n"); + DumpOneOperatorSyntax (file, IsXref, n); + } + } + SortAllOperators (); + fprintf (file, + "------------------------------------------------------------\n"); + + fprintf (file, "\n"); + fprintf (file, "\n"); + fflush (file); +} + +/* EOF */ |