1 /****************************************************************
2
3 bwb_exp.c Expression Parser
4 for Bywater BASIC Interpreter
5
6 Copyright (c) 1993, Ted A. Campbell
7 Bywater Software
8
9 email: tcamp@delphi.com
10
11 Copyright and Permissions Information:
12
13 All U.S. and international rights are claimed by the author,
14 Ted A. Campbell.
15
16 This software is released under the terms of the GNU General
17 Public License (GPL), which is distributed with this software
18 in the file "COPYING". The GPL specifies the terms under
19 which users may copy and use the software in this distribution.
20
21 A separate license is available for commercial distribution,
22 for information on which you should contact the author.
23
24 ***************************************************************/
25
26 /*---------------------------------------------------------------*/
27 /* NOTE: Modifications marked "JBV" were made by Jon B. Volkoff, */
28 /* 11/1995 (eidetics@cerf.net). */
29 /* */
30 /* Those additionally marked with "DD" were at the suggestion of */
31 /* Dale DePriest (daled@cadence.com). */
32 /* */
33 /* Version 3.00 by Howard Wulf, AF5NE */
34 /* */
35 /* Version 3.10 by Howard Wulf, AF5NE */
36 /* */
37 /* Version 3.20 by Howard Wulf, AF5NE */
38 /* */
39 /*---------------------------------------------------------------*/
40
41
42
43 #include "bwbasic.h"
44
45
46 /*
47 --------------------------------------------------------------------------------------------
48 EXPRESSION PARSER
49
50 Inspired by https://groups.google.com/forum/m/#!topic/comp.compilers/RCyhEbLfs40
51 ...
52 // Permission is given to use this source provided an acknowledgement is given.
53 // I'd also like to know if you've found it useful.
54 //
55 // The following Research Report describes the idea, and shows how the
56 // parsing method may be understood as an encoding of the usual family-of-
57 // parsing-procedures technique as used e.g. in Pascal compilers.
58 // @techreport{QMW-DCS-383-1986a,
59 // author ="Clarke, Keith",
60 // title ="The Top-Down Parsing of Expressions",
61 // institution ="Department of Computer Science, Queen Mary College, University of London, England",
62 // year ="1986",
63 // month ="June",
64 // number ="QMW-DCS-1986-383",
65 // scope ="theory",
66 // abstractURL ="http://www.dcs.qmw.ac.uk/publications/report_abstracts/1986/383",
67 // keywords ="Recursive-descent parsing, expression parsing, operator precedence parsing."
68 // }
69 // A formal proof of the algorithm was made, as part of his PhD thesis work,
70 // by A.M. Abbas of QMC, London, in the framework of Constructive Set Theory.
71 // copyright Keith Clarke, Dept of Computer Science, QMW, University of London,
72 // England. email kei...@dcs.qmw.ac.uk
73 ...
74 --------------------------------------------------------------------------------------------
75 */
76
77 /*
78 For all functions named "line_*", "LineType * line" is the first parameter.
79 For all functions named "buff_*", "char * buffer, int * position" are the first two parameters.
80 FALSE must be zero.
81 TRUE must be non-zero.
82 */
83
84
85
86 /* OperatorType.Arity */
87 #define UNARY 1
88 #define BINARY 2
89
90 /* OperatorType.IsAlpha */
91 #define IS_ALPHA 'T'
92 #define NO_ALPHA 'F'
93
94
95 #define COPY_VARIANT( X, Y ) if( X != NULL ) { bwb_memcpy( X, Y, sizeof( VariantType ) ); bwb_memset( Y, 0, sizeof( VariantType ) ); }
96
97 typedef ResultType (OperatorFunctionType) (VariantType * X, VariantType * Y);
98
99 struct OperatorStruct
100 {
101 const unsigned char ThisPrec;
102 const unsigned char NextPrec; /* if BINARY and LEFT assoc, then ThisPrec+1, else ThisPrec */
103 const unsigned char Arity; /* UNARY or BINARY */
104 const char IsAlpha; /* IS_ALPHA or NO_ALPHA, determines how operator is matched */
105 const char *Name;
106 OperatorFunctionType *Eval;
107 const char *Syntax;
108 const char *Description;
109 OptionVersionType OptionVersionBitmask; /* OPTION VERSION bitmask */
110 };
111 typedef struct OperatorStruct OperatorType;
112
113 static int both_are_long (VariantType * X, VariantType * Y);
114 static int both_integer_type (VariantType * X, VariantType * Y);
115 static int both_number_type (VariantType * X, VariantType * Y);
116 static int both_string_type (VariantType * X, VariantType * Y);
117 static ResultType buff_read_expr (char *buffer, int *position,
118 VariantType * X, unsigned char LastPrec);
119 static ResultType buff_read_function (char *buffer, int *position,
120 VariantType * X);
121 static ResultType buff_read_internal_constant (char *buffer, int *position,
122 VariantType * X);
123 static OperatorType *buff_read_operator (char *buffer, int *position,
124 unsigned char LastPrec,
125 unsigned char Arity);
126 static ResultType buff_read_primary (char *buffer, int *position,
127 VariantType * X);
128 static ResultType buff_read_string_constant (char *buffer, int *position,
129 VariantType * X);
130 static ResultType buff_read_variable (char *buffer, int *position,
131 VariantType * X);
132 static int bwb_isodigit (int C);
133 static int is_integer_type (VariantType * X);
134 static int is_long_value (VariantType * X);
135 static int is_number_type (VariantType * X);
136 static int is_string_type (VariantType * X);
137 static char Largest_TypeCode (char TypeCode, VariantType * X);
138 static char math_type (VariantType * X, VariantType * Y);
139 static char max_number_type (char X, char Y);
140 static char min_value_type (VariantType * X);
141 static ResultType OP_ADD (VariantType * X, VariantType * Y);
142 static ResultType OP_AMP (VariantType * X, VariantType * Y);
143 static ResultType OP_AND (VariantType * X, VariantType * Y);
144 static ResultType OP_DIV (VariantType * X, VariantType * Y);
145 static ResultType OP_EQ (VariantType * X, VariantType * Y);
146 static ResultType OP_EQV (VariantType * X, VariantType * Y);
147 static ResultType OP_EXP (VariantType * X, VariantType * Y);
148 static ResultType OP_GE (VariantType * X, VariantType * Y);
149 static ResultType OP_GT (VariantType * X, VariantType * Y);
150 static ResultType OP_IDIV (VariantType * X, VariantType * Y);
151 static ResultType OP_IMP (VariantType * X, VariantType * Y);
152 static ResultType OP_LE (VariantType * X, VariantType * Y);
153 static ResultType OP_LIKE (VariantType * X, VariantType * Y);
154 static ResultType OP_LT (VariantType * X, VariantType * Y);
155 static ResultType OP_MAX (VariantType * X, VariantType * Y);
156 static ResultType OP_MIN (VariantType * X, VariantType * Y);
157 static ResultType OP_MOD (VariantType * X, VariantType * Y);
158 static ResultType OP_MUL (VariantType * X, VariantType * Y);
159 static ResultType OP_NE (VariantType * X, VariantType * Y);
160 static ResultType OP_NEG (VariantType * X, VariantType * Y);
161 static ResultType OP_NOT (VariantType * X, VariantType * Y);
162 static ResultType OP_OR (VariantType * X, VariantType * Y);
163 static ResultType OP_POS (VariantType * X, VariantType * Y);
164 static ResultType OP_SUB (VariantType * X, VariantType * Y);
165 static ResultType OP_XOR (VariantType * X, VariantType * Y);
166 static void SortAllOperatorsForManual (void);
167 static ResultType test_eq (VariantType * X, VariantType * Y, int TrueValue,
168 int FalseValue);
169 static ResultType test_gt (VariantType * X, VariantType * Y, int TrueValue,
170 int FalseValue);
171 static ResultType test_lt (VariantType * X, VariantType * Y, int TrueValue,
172 int FalseValue);
173
174
175 /* table of operators */
176
177 /*
178 In BASIC, 2 ^ 3 ^ 2 = ( 2 ^ 3 ) ^ 2 = 64, and -2 ^ 2 = - (2 ^ 2) = -4.
179 */
180
181
182 static OperatorType OperatorTable[ /* NUM_OPERATORS */ ] =
183 {
184 /* LOGICAL */
185 {0x01, 0x02, BINARY, IS_ALPHA, "IMP", OP_IMP, "X IMP Y", "Bitwise IMP",
186 B15 | B93 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 | M80 | T80
187 | H14},
188 {0x02, 0x03, BINARY, IS_ALPHA, "EQV", OP_EQV, "X EQV Y", "Bitwise EQV",
189 B15 | B93 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71 | M80 | T80
190 | H14},
191 {0x03, 0x04, BINARY, IS_ALPHA, "XOR", OP_XOR, "X XOR Y",
192 "Bitwise Exclusive OR",
193 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
194 | M80 | T79 | R86 | T80 | H14},
195 {0x03, 0x04, BINARY, IS_ALPHA, "XRA", OP_XOR, "X XRA Y",
196 "Bitwise Exclusive OR",
197 HB2},
198 {0x04, 0x05, BINARY, IS_ALPHA, "OR", OP_OR, "X OR Y", "Bitwise OR",
199 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
200 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
201 {0x05, 0x06, BINARY, IS_ALPHA, "AND", OP_AND, "X AND Y", "Bitwise AND",
202 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
203 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
204 {0x06, 0x06, UNARY, IS_ALPHA, "NOT", OP_NOT, "NOT X", "Bitwise NOT",
205 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
206 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
207 /* RELATIONAL */
208 {0x07, 0x08, BINARY, IS_ALPHA, "NE", OP_NE, "X NE Y", "Not Equal",
209 0},
210 {0x07, 0x08, BINARY, NO_ALPHA, "#", OP_NE, "X # Y", "Not Equal",
211 0},
212 {0x07, 0x08, BINARY, NO_ALPHA, "<>", OP_NE, "X <> Y", "Not Equal",
213 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
214 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
215 {0x07, 0x08, BINARY, NO_ALPHA, "><", OP_NE, "X >< Y", "Not Equal",
216 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
217 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
218 {0x07, 0x08, BINARY, IS_ALPHA, "GE", OP_GE, "X GE Y",
219 "Greater than or Equal",
220 0},
221 {0x07, 0x08, BINARY, NO_ALPHA, ">=", OP_GE, "X >= Y",
222 "Greater than or Equal",
223 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
224 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
225 {0x07, 0x08, BINARY, NO_ALPHA, "=>", OP_GE, "X => Y",
226 "Greater than or Equal",
227 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
228 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
229 {0x07, 0x08, BINARY, IS_ALPHA, "LE", OP_LE, "X LE Y", "Less than or Equal",
230 0},
231 {0x07, 0x08, BINARY, NO_ALPHA, "<=", OP_LE, "X <= Y", "Less than or Equal",
232 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
233 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
234 {0x07, 0x08, BINARY, NO_ALPHA, "=<", OP_LE, "X =< Y", "Less than or Equal",
235 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
236 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
237 {0x07, 0x08, BINARY, IS_ALPHA, "EQ", OP_EQ, "X EQ Y", "Equal",
238 0},
239 {0x07, 0x08, BINARY, NO_ALPHA, "=", OP_EQ, "X = Y", "Equal",
240 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
241 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
242 {0x07, 0x08, BINARY, IS_ALPHA, "LT", OP_LT, "X LT Y", "Less than",
243 0},
244 {0x07, 0x08, BINARY, NO_ALPHA, "<", OP_LT, "X < Y", "Less than",
245 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
246 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
247 {0x07, 0x08, BINARY, IS_ALPHA, "GT", OP_GT, "X GT Y", "Greater than",
248 0},
249 {0x07, 0x08, BINARY, NO_ALPHA, ">", OP_GT, "X > Y", "Greater than",
250 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
251 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
252 {0x07, 0x08, BINARY, IS_ALPHA, "LIKE", OP_LIKE, "A$ LIKE B$",
253 "Compare A$ to the pattern in B$",
254 B15},
255 {0x07, 0x08, BINARY, IS_ALPHA, "MAX", OP_MAX, "X MAX Y", "Maximum",
256 0},
257 {0x07, 0x08, BINARY, IS_ALPHA, "MIN", OP_MIN, "X MIN Y", "Minimum",
258 0},
259 /* CONCATENATION */
260 {0x08, 0x09, BINARY, NO_ALPHA, "&", OP_AMP, "X & Y", "Concatenation",
261 B15 | B93 | HB2},
262 /* ARITHMETIC */
263 {0x09, 0x0A, BINARY, NO_ALPHA, "+", OP_ADD, "X + Y", "Addition",
264 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
265 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
266 {0x09, 0x0A, BINARY, NO_ALPHA, "-", OP_SUB, "X - Y", "Subtraction",
267 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
268 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
269 {0x0A, 0x0B, BINARY, IS_ALPHA, "MOD", OP_MOD, "X MOD Y", "Integer Modulus",
270 B15 | B93 | HB1 | HB2 | D71 | M80 | R86 | T80 | H14},
271 {0x0B, 0x0C, BINARY, NO_ALPHA, "\\", OP_IDIV, "X \\ Y", "Integer Division",
272 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
273 | E78 | E86 | M80 | T80 | H14},
274 {0x0C, 0x0D, BINARY, NO_ALPHA, "*", OP_MUL, "X * Y", "Multiplication",
275 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
276 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
277 {0x0C, 0x0D, BINARY, NO_ALPHA, "/", OP_DIV, "X / Y", "Division",
278 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
279 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
280 {0x0D, 0x0D, UNARY, NO_ALPHA, "#", OP_POS, "# X", "Posation",
281 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | C77 | D71 | E86 | M80 | T79
282 | R86 | T80 | H80 | H14},
283 {0x0D, 0x0D, UNARY, NO_ALPHA, "+", OP_POS, "+ X", "Posation",
284 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
285 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
286 {0x0D, 0x0D, UNARY, NO_ALPHA, "-", OP_NEG, "- X", "Negation",
287 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
288 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | T80 | H80 | V09 | H14},
289 {0x0E, 0x0F, BINARY, NO_ALPHA, "^", OP_EXP, "X ^ Y", "Exponential",
290 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
291 | D70 | D73 | E78 | E86 | M80 | T79 | R86 | H80 | V09 | H14},
292 {0x0E, 0x0F, BINARY, NO_ALPHA, "[", OP_EXP, "X [ Y", "Exponential",
293 B15 | HB1 | HB2 | T80},
294 {0x0E, 0x0F, BINARY, NO_ALPHA, "**", OP_EXP, "X ** Y", "Exponential",
295 B15 | B93 | HB1 | HB2 | D64 | G65 | G67 | G74 | S70 | I70 | I73 | C77 | D71
296 | D70 | D73 | E78},
297 };
298
299 static const size_t NUM_OPERATORS =
300 sizeof (OperatorTable) / sizeof (OperatorType);
301
302 /*
303 --------------------------------------------------------------------------------------------
304 Helpers
305 --------------------------------------------------------------------------------------------
306 */
307
308 extern void
SortAllOperators(void)309 SortAllOperators (void) /* SortAllOperators() should be called by bwb_init() */
310 {
311 /* sort the operators by decreasing length, so "**" matches before "*" and so on. */
312 int i;
313
314
315 for (i = 0; i < NUM_OPERATORS - 1; i++)
316 {
317 int j;
318 int k;
319 int m;
320
321 k = i;
322 m = bwb_strlen (OperatorTable[i].Name);
323
324 for (j = i + 1; j < NUM_OPERATORS; j++)
325 {
326 int n;
327 n = bwb_strlen (OperatorTable[j].Name);
328 if (n > m)
329 {
330 m = n;
331 k = j;
332 }
333 }
334 if (k > i)
335 {
336 /* swap */
337 OperatorType t;
338 OperatorType *T;
339 OperatorType *I;
340 OperatorType *K;
341
342 T = &t;
343 I = &OperatorTable[i];
344 K = &OperatorTable[k];
345
346 bwb_memcpy (T, I, sizeof (t));
347 bwb_memcpy (I, K, sizeof (t));
348 bwb_memcpy (K, T, sizeof (t));
349 }
350 }
351 }
352
353 static void
SortAllOperatorsForManual(void)354 SortAllOperatorsForManual (void) /* SortAllOperators() should be called aftwards */
355 {
356 /* sort the operators by by precedence (high-to-low) then name (alphabetically). */
357 int i;
358
359
360 for (i = 0; i < NUM_OPERATORS - 1; i++)
361 {
362 int j;
363 int k;
364 int m;
365
366 k = i;
367 m = OperatorTable[i].ThisPrec;
368
369 for (j = i + 1; j < NUM_OPERATORS; j++)
370 {
371 int n;
372 n = OperatorTable[j].ThisPrec;
373 if (n > m)
374 {
375 m = n;
376 k = j;
377 }
378 else
379 if (n == m
380 && bwb_stricmp (OperatorTable[j].Name, OperatorTable[k].Name) < 0)
381 {
382 m = n;
383 k = j;
384 }
385 }
386 if (k > i)
387 {
388 /* swap */
389 OperatorType t;
390 OperatorType *T;
391 OperatorType *I;
392 OperatorType *K;
393
394 T = &t;
395 I = &OperatorTable[i];
396 K = &OperatorTable[k];
397
398 bwb_memcpy (T, I, sizeof (t));
399 bwb_memcpy (I, K, sizeof (t));
400 bwb_memcpy (K, T, sizeof (t));
401 }
402 }
403 }
404 static char
min_value_type(VariantType * X)405 min_value_type (VariantType * X)
406 {
407 /* returns the minimal TypeCode, based upon a NUMBER's value */
408
409 assert (X != NULL);
410
411
412 if (isnan (X->Number))
413 {
414 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
415 WARN_INTERNAL_ERROR;
416 return NulChar;
417 }
418 if (X->Number == bwb_rint (X->Number))
419 {
420 /* INTEGER */
421 if (MINBYT <= X->Number && X->Number <= MAXBYT)
422 {
423 return ByteTypeCode;
424 }
425 if (MININT <= X->Number && X->Number <= MAXINT)
426 {
427 return IntegerTypeCode;
428 }
429 if (MINLNG <= X->Number && X->Number <= MAXLNG)
430 {
431 return LongTypeCode;
432 }
433 if (MINCUR <= X->Number && X->Number <= MAXCUR)
434 {
435 return CurrencyTypeCode;
436 }
437 }
438 /* FLOAT */
439 if (MINSNG <= X->Number && X->Number <= MAXSNG)
440 {
441 return SingleTypeCode;
442 }
443 if (MINDBL <= X->Number && X->Number <= MAXDBL)
444 {
445 return DoubleTypeCode;
446 }
447 /* OVERFLOW */
448 if (X->Number < 0)
449 {
450 X->Number = MINDBL;
451 }
452 else
453 {
454 X->Number = MAXDBL;
455 }
456 if (WARN_OVERFLOW)
457 {
458 /* ERROR */
459 }
460 /* CONTINUE */
461 return DoubleTypeCode;
462 }
463
464
465
466 static char
max_number_type(char X,char Y)467 max_number_type (char X, char Y)
468 {
469 /* returns the maximal TypeCode, given two NUMBER TypeCode's */
470
471
472
473 if (X == DoubleTypeCode || Y == DoubleTypeCode)
474 {
475 return DoubleTypeCode;
476 }
477 if (X == SingleTypeCode || Y == SingleTypeCode)
478 {
479 return SingleTypeCode;
480 }
481 if (X == CurrencyTypeCode || Y == CurrencyTypeCode)
482 {
483 return CurrencyTypeCode;
484 }
485 if (X == LongTypeCode || Y == LongTypeCode)
486 {
487 return LongTypeCode;
488 }
489 if (X == IntegerTypeCode || Y == IntegerTypeCode)
490 {
491 return IntegerTypeCode;
492 }
493 if (X == ByteTypeCode || Y == ByteTypeCode)
494 {
495 return ByteTypeCode;
496 }
497 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
498 WARN_INTERNAL_ERROR;
499 return NulChar;
500 }
501 static char
math_type(VariantType * X,VariantType * Y)502 math_type (VariantType * X, VariantType * Y)
503 {
504 /*
505 **
506 ** Returns the TypeCode resulting from a math operation, such as addition.
507 ** The return TypeCode should be the maximal of:
508 ** a. The original X's TypeCode.
509 ** b. The original Y's TypeCode.
510 ** c. The result's minimal TypeCode.
511 **
512 */
513
514 assert (X != NULL);
515 assert (Y != NULL);
516 return
517 max_number_type (max_number_type (X->VariantTypeCode, Y->VariantTypeCode),
518 min_value_type (X));
519 }
520
521 static char
Largest_TypeCode(char TypeCode,VariantType * X)522 Largest_TypeCode (char TypeCode, VariantType * X)
523 {
524 assert (X != NULL);
525 if (is_integer_type (X))
526 {
527 X->Number = bwb_rint (X->Number);
528 }
529 return max_number_type (TypeCode, min_value_type (X));
530 }
531 static int
is_string_type(VariantType * X)532 is_string_type (VariantType * X)
533 {
534 /* if value is a STRING, then TRUE, else FALSE */
535
536 assert (X != NULL);
537 switch (X->VariantTypeCode)
538 {
539 case ByteTypeCode:
540 case IntegerTypeCode:
541 case LongTypeCode:
542 case CurrencyTypeCode:
543 case SingleTypeCode:
544 case DoubleTypeCode:
545 if (X->Buffer != NULL)
546 {
547 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
548 WARN_INTERNAL_ERROR;
549 return FALSE;
550 }
551 return FALSE;
552 case StringTypeCode:
553 if (X->Buffer == NULL)
554 {
555 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
556 WARN_INTERNAL_ERROR;
557 return FALSE;
558 }
559 return TRUE;
560 }
561 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
562 WARN_INTERNAL_ERROR;
563 return FALSE;
564 }
565 static int
is_number_type(VariantType * X)566 is_number_type (VariantType * X)
567 {
568 /* if value is a NUMBER, then TRUE, else FALSE */
569
570 assert (X != NULL);
571 switch (X->VariantTypeCode)
572 {
573 case ByteTypeCode:
574 case IntegerTypeCode:
575 case LongTypeCode:
576 case CurrencyTypeCode:
577 case SingleTypeCode:
578 case DoubleTypeCode:
579 if (X->Buffer != NULL)
580 {
581 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
582 WARN_INTERNAL_ERROR;
583 return FALSE;
584 }
585 return TRUE;
586 case StringTypeCode:
587 if (X->Buffer == NULL)
588 {
589 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
590 WARN_INTERNAL_ERROR;
591 return FALSE;
592 }
593 return FALSE;
594 }
595 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
596 WARN_INTERNAL_ERROR;
597 return FALSE; /* never reached */
598 }
599 static int
is_integer_type(VariantType * X)600 is_integer_type (VariantType * X)
601 {
602 /* if value is an INTEGER, then TRUE, else FALSE */
603
604 assert (X != NULL);
605 switch (X->VariantTypeCode)
606 {
607 case ByteTypeCode:
608 return TRUE;
609 case IntegerTypeCode:
610 return TRUE;
611 case LongTypeCode:
612 return TRUE;
613 case CurrencyTypeCode:
614 return TRUE;
615 case SingleTypeCode:
616 return FALSE;
617 case DoubleTypeCode:
618 return FALSE;
619 case StringTypeCode:
620 return FALSE;
621 }
622 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
623 WARN_INTERNAL_ERROR;
624 return FALSE;
625 }
626 static int
both_string_type(VariantType * X,VariantType * Y)627 both_string_type (VariantType * X, VariantType * Y)
628 {
629 /* if both values are a STRING, then TRUE, else FALSE */
630
631 assert (X != NULL);
632 assert (Y != NULL);
633 if (is_string_type (X) && is_string_type (Y))
634 {
635 return TRUE;
636 }
637 return FALSE;
638 }
639 static int
both_number_type(VariantType * X,VariantType * Y)640 both_number_type (VariantType * X, VariantType * Y)
641 {
642 /* if both values are a NUMBER, then TRUE, else FALSE */
643
644 assert (X != NULL);
645 assert (Y != NULL);
646 if (is_number_type (X) && is_number_type (Y))
647 {
648 return TRUE;
649 }
650 return FALSE;
651 }
652 static int
both_integer_type(VariantType * X,VariantType * Y)653 both_integer_type (VariantType * X, VariantType * Y)
654 {
655 /* if both values are an INTEGER, then TRUE, else FALSE */
656
657 assert (X != NULL);
658 assert (Y != NULL);
659 if (is_integer_type (X) && is_integer_type (Y))
660 {
661 return TRUE;
662 }
663 return FALSE;
664 }
665 static int
is_long_value(VariantType * X)666 is_long_value (VariantType * X)
667 {
668 /* if the NUMBER's value can be a LONG, then TRUE, else FALSE */
669
670 assert (X != NULL);
671 if (isnan (X->Number))
672 {
673 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
674 WARN_INTERNAL_ERROR;
675 return FALSE;
676 }
677 if (X->Number == bwb_rint (X->Number))
678 {
679 if (MINCUR <= X->Number && X->Number <= MAXCUR)
680 {
681 return TRUE;
682 }
683 }
684 return FALSE;
685 }
686 static int
both_are_long(VariantType * X,VariantType * Y)687 both_are_long (VariantType * X, VariantType * Y)
688 {
689 /* if both values can be a LONG, then TRUE, else FALSE */
690
691 assert (X != NULL);
692 assert (Y != NULL);
693 if (is_long_value (X) && is_long_value (Y))
694 {
695 return TRUE;
696 }
697 return FALSE;
698 }
699 static int
bwb_isodigit(int C)700 bwb_isodigit (int C)
701 {
702
703 switch (C)
704 {
705 case '0':
706 case '1':
707 case '2':
708 case '3':
709 case '4':
710 case '5':
711 case '6':
712 case '7':
713 return TRUE;
714 }
715 return FALSE;
716 }
717
718
719
720 /*
721 --------------------------------------------------------------------------------------------
722 Operators
723 --------------------------------------------------------------------------------------------
724 */
725
726 static ResultType
OP_ADD(VariantType * X,VariantType * Y)727 OP_ADD (VariantType * X, VariantType * Y)
728 {
729
730 assert (X != NULL);
731 assert (Y != NULL);
732 if (both_number_type (X, Y))
733 {
734 /* X = (X + Y) */
735 X->Number += Y->Number;
736 if (both_integer_type (X, Y))
737 {
738 X->Number = bwb_rint (X->Number);
739 }
740 X->VariantTypeCode = math_type (X, Y);
741 return RESULT_SUCCESS;
742 }
743 if (both_string_type (X, Y))
744 {
745 /* X$ = (X$ + Y$) */
746 return OP_AMP (X, Y);
747 }
748 WARN_TYPE_MISMATCH;
749 return RESULT_ERROR;
750 }
751 static ResultType
OP_AMP(VariantType * X,VariantType * Y)752 OP_AMP (VariantType * X, VariantType * Y)
753 {
754 /* X$ = (X & Y ) */
755 /* X$ = (X & Y$) */
756 /* X$ = (X$ & Y ) */
757 /* X$ = (X$ & Y$) */
758 size_t CharsRemaining;
759 VariantType t;
760 VariantType *T;
761
762 assert (X != NULL);
763 assert (Y != NULL);
764
765 T = &t;
766 if (X->VariantTypeCode != StringTypeCode)
767 {
768 /* coerce X to X$ */
769 if ((X->Buffer = (char *) calloc (NUMLEN, sizeof (char))) == NULL) /* free() called by OP_ADD() */
770 {
771 WARN_OUT_OF_MEMORY;
772 return RESULT_ERROR;
773 }
774 FormatBasicNumber (X->Number, X->Buffer);
775 X->Length = bwb_strlen (X->Buffer);
776 X->VariantTypeCode = StringTypeCode;
777 }
778 if (Y->VariantTypeCode != StringTypeCode)
779 {
780 /* coerce Y to Y$ */
781 if ((Y->Buffer = (char *) calloc (NUMLEN, sizeof (char))) == NULL) /* free() called by OP_ADD() */
782 {
783 WARN_OUT_OF_MEMORY;
784 return RESULT_ERROR;
785 }
786 FormatBasicNumber (Y->Number, Y->Buffer);
787 Y->Length = bwb_strlen (Y->Buffer);
788 Y->VariantTypeCode = StringTypeCode;
789 }
790 if (X->Length > MAXLEN)
791 {
792 WARN_STRING_TOO_LONG;
793 X->Length = MAXLEN;
794 }
795 if (Y->Length > MAXLEN)
796 {
797 WARN_STRING_TOO_LONG;
798 Y->Length = MAXLEN;
799 }
800 T->VariantTypeCode = StringTypeCode;
801 T->Length = X->Length + Y->Length;
802 if (T->Length > MAXLEN)
803 {
804 WARN_STRING_TOO_LONG;
805 T->Length = MAXLEN;
806 }
807 /* we always allocate a buffer, even for non-empty strings */
808 if ((T->Buffer =
809 (char *) calloc (T->Length + 1 /* NulChar */ , sizeof (char))) == NULL)
810 {
811 WARN_OUT_OF_MEMORY;
812 return RESULT_ERROR;
813 }
814 CharsRemaining = T->Length;
815 if (X->Length > CharsRemaining)
816 {
817 X->Length = CharsRemaining;
818 }
819 if (X->Length > 0)
820 {
821 bwb_memcpy (T->Buffer, X->Buffer, X->Length);
822 CharsRemaining -= X->Length;
823 }
824 if (Y->Length > CharsRemaining)
825 {
826 Y->Length = CharsRemaining;
827 }
828 if (Y->Length > 0)
829 {
830 bwb_memcpy (&T->Buffer[X->Length], Y->Buffer, Y->Length);
831 CharsRemaining -= Y->Length;
832 }
833 if (CharsRemaining != 0)
834 {
835 WARN_INTERNAL_ERROR;
836 return RESULT_ERROR;
837 }
838 T->Buffer[T->Length] = NulChar;
839 RELEASE_VARIANT (X);
840 RELEASE_VARIANT (Y);
841 COPY_VARIANT (X, T);
842 return RESULT_SUCCESS;
843 }
844 static ResultType
OP_SUB(VariantType * X,VariantType * Y)845 OP_SUB (VariantType * X, VariantType * Y)
846 {
847 /* X = (X - Y) */
848
849 assert (X != NULL);
850 assert (Y != NULL);
851 if (both_number_type (X, Y))
852 {
853 X->Number -= Y->Number;
854 if (both_integer_type (X, Y))
855 {
856 X->Number = bwb_rint (X->Number);
857 }
858 X->VariantTypeCode = math_type (X, Y);
859 return RESULT_SUCCESS;
860 }
861 WARN_TYPE_MISMATCH;
862 return RESULT_ERROR;
863 }
864 static ResultType
OP_MUL(VariantType * X,VariantType * Y)865 OP_MUL (VariantType * X, VariantType * Y)
866 {
867 /* X = (X * Y) */
868
869 assert (X != NULL);
870 assert (Y != NULL);
871 if (both_number_type (X, Y))
872 {
873 X->Number *= Y->Number;
874 if (both_integer_type (X, Y))
875 {
876 X->Number = bwb_rint (X->Number);
877 }
878 X->VariantTypeCode = math_type (X, Y);
879 return RESULT_SUCCESS;
880 }
881 WARN_TYPE_MISMATCH;
882 return RESULT_ERROR;
883 }
884 static ResultType
OP_IDIV(VariantType * X,VariantType * Y)885 OP_IDIV (VariantType * X, VariantType * Y)
886 {
887
888 assert (X != NULL);
889 assert (Y != NULL);
890 assert(My != NULL);
891 assert(My->CurrentVersion != NULL);
892
893 if (both_number_type (X, Y))
894 {
895 /* X = (X \ Y) */
896 X->Number = bwb_rint (X->Number);
897 Y->Number = bwb_rint (Y->Number);
898 if (Y->Number == 0)
899 {
900 /* - Evaluation of an expression results in division
901 * by zero (nonfatal, the recommended recovery
902 * procedure is to supply machine infinity with the
903 * sign of the numerator and continue)
904 */
905 if (X->Number < 0)
906 {
907 /* NEGATIVE */
908 X->Number = MINDBL; /* NEGATIVE INFINITY */
909 }
910 else
911 {
912 /* POSITIVE */
913 X->Number = MAXDBL; /* POSITIVE INFINITY */
914 }
915 if (WARN_DIVISION_BY_ZERO)
916 {
917 return RESULT_ERROR;
918 }
919 /* CONTINUE */
920 }
921 else
922 {
923 DoubleType N;
924
925 N = bwb_rint (X->Number / Y->Number);
926 if (My->CurrentVersion->OptionVersionValue & (R86))
927 {
928 /* for RBASIC's RESIDUE function */
929 My->RESIDUE = bwb_rint (X->Number - N * Y->Number);
930 }
931 X->Number = N;
932
933 }
934 X->VariantTypeCode = math_type (X, Y);
935 return RESULT_SUCCESS;
936 }
937 WARN_TYPE_MISMATCH;
938 return RESULT_ERROR;
939 }
940 static ResultType
OP_DIV(VariantType * X,VariantType * Y)941 OP_DIV (VariantType * X, VariantType * Y)
942 {
943
944 assert (X != NULL);
945 assert (Y != NULL);
946 if (both_number_type (X, Y))
947 {
948 /* X = (X / Y) */
949 if (both_integer_type (X, Y))
950 {
951 return OP_IDIV (X, Y);
952 }
953 if (Y->Number == 0)
954 {
955 /* - Evaluation of an expression results in division
956 * by zero (nonfatal, the recommended recovery
957 * procedure is to supply machine infinity with the
958 * sign of the numerator and continue)
959 */
960 if (X->Number < 0)
961 {
962 /* NEGATIVE */
963 X->Number = MINDBL; /* NEGATIVE INFINITY */
964 }
965 else
966 {
967 /* POSITIVE */
968 X->Number = MAXDBL; /* POSITIVE INFINITY */
969 }
970 if (WARN_DIVISION_BY_ZERO)
971 {
972 return RESULT_ERROR;
973 }
974 /* CONTINUE */
975 }
976 else
977 {
978 X->Number /= Y->Number;
979 }
980 X->VariantTypeCode = math_type (X, Y);
981 return RESULT_SUCCESS;
982 }
983 WARN_TYPE_MISMATCH;
984 return RESULT_ERROR;
985 }
986 static ResultType
OP_MOD(VariantType * X,VariantType * Y)987 OP_MOD (VariantType * X, VariantType * Y)
988 {
989
990 assert (X != NULL);
991 assert (Y != NULL);
992 if (both_number_type (X, Y))
993 {
994 /* X = (X MOD Y) */
995 X->Number = bwb_rint (X->Number);
996 Y->Number = bwb_rint (Y->Number);
997 if (Y->Number == 0)
998 {
999 /* - Evaluation of an expression results in division
1000 * by zero (nonfatal, the recommended recovery
1001 * procedure is to supply machine infinity with the
1002 * sign of the numerator and continue)
1003 */
1004 if (X->Number < 0)
1005 {
1006 /* NEGATIVE */
1007 X->Number = MINDBL; /* NEGATIVE INFINITY */
1008 }
1009 else
1010 {
1011 /* POSITIVE */
1012 X->Number = MAXDBL; /* POSITIVE INFINITY */
1013 }
1014 if (WARN_DIVISION_BY_ZERO)
1015 {
1016 return RESULT_ERROR;
1017 }
1018 /* CONTINUE */
1019 }
1020 else
1021 {
1022 DoubleType N;
1023 DoubleType I;
1024 N = X->Number / Y->Number;
1025 modf (N, &I);
1026 N = X->Number - Y->Number * I;
1027 X->Number = bwb_rint (N);
1028 }
1029 X->VariantTypeCode = math_type (X, Y);
1030 return RESULT_SUCCESS;
1031 }
1032 WARN_TYPE_MISMATCH;
1033 return RESULT_ERROR;
1034 }
1035 static ResultType
OP_EXP(VariantType * X,VariantType * Y)1036 OP_EXP (VariantType * X, VariantType * Y)
1037 {
1038
1039 assert (X != NULL);
1040 assert (Y != NULL);
1041 if (both_number_type (X, Y))
1042 {
1043 /* X = (X ^ Y) */
1044 if (X->Number < 0 && Y->Number != bwb_rint (Y->Number))
1045 {
1046 /*** FATAL ***/
1047 /* - Evaluation of the operation of
1048 * involution results in a negative number
1049 * being raised to a non-integral power
1050 * (fatal). */
1051 X->Number = 0;
1052 WARN_ILLEGAL_FUNCTION_CALL;
1053 return RESULT_ERROR;
1054 }
1055 if (X->Number == 0 && Y->Number < 0)
1056 {
1057 /* - Evaluation of the operation of
1058 * involution results in a zero being
1059 * raised to a negative value (nonfatal, the
1060 * recommended recovery procedure is to
1061 * supply positive machine infinity and
1062 * continue). */
1063
1064 X->Number = MAXDBL;
1065 if (WARN_OVERFLOW)
1066 {
1067 /* ERROR */
1068 }
1069 /* CONTINUE */
1070 }
1071 else
1072 {
1073 X->Number = pow (X->Number, Y->Number);
1074 }
1075 X->VariantTypeCode = math_type (X, Y);
1076 return RESULT_SUCCESS;
1077 }
1078 WARN_TYPE_MISMATCH;
1079 return RESULT_ERROR;
1080 }
1081 static ResultType
OP_NEG(VariantType * X,VariantType * Y)1082 OP_NEG (VariantType * X, VariantType * Y)
1083 {
1084
1085 assert (X != NULL);
1086 assert (Y == NULL);
1087 if (Y != NULL)
1088 {
1089 WARN_INTERNAL_ERROR;
1090 return RESULT_ERROR;
1091 }
1092 if (is_number_type (X))
1093 {
1094 /* X = (- X) */
1095 X->Number = -X->Number;
1096 X->VariantTypeCode = min_value_type (X);
1097 return RESULT_SUCCESS;
1098 }
1099 WARN_TYPE_MISMATCH;
1100 return RESULT_ERROR;
1101 }
1102 static ResultType
OP_POS(VariantType * X,VariantType * Y)1103 OP_POS (VariantType * X, VariantType * Y)
1104 {
1105
1106 assert (X != NULL);
1107 assert (Y == NULL);
1108 if (Y != NULL)
1109 {
1110 WARN_INTERNAL_ERROR;
1111 return RESULT_ERROR;
1112 }
1113 if (is_number_type (X))
1114 {
1115 /* X = (+ X) */
1116 /*
1117 X->Number = X->Number;
1118 X->VariantTypeCode = min_value_type( X );
1119 */
1120 return RESULT_SUCCESS;
1121 }
1122 WARN_TYPE_MISMATCH;
1123 return RESULT_ERROR;
1124 }
1125 static ResultType
OP_OR(VariantType * X,VariantType * Y)1126 OP_OR (VariantType * X, VariantType * Y)
1127 {
1128
1129 assert (X != NULL);
1130 assert (Y != NULL);
1131 assert(My != NULL);
1132 assert(My->CurrentVersion != NULL);
1133
1134 if (both_number_type (X, Y))
1135 {
1136 /* X = (X OR Y) */
1137 if (both_are_long (X, Y))
1138 {
1139 long x;
1140 long y;
1141
1142 x = (long) bwb_rint (X->Number);
1143 y = (long) bwb_rint (Y->Number);
1144
1145 if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* OR */ )
1146 {
1147 if (x)
1148 {
1149 x = -1;
1150 }
1151 if (y)
1152 {
1153 y = -1;
1154 }
1155 }
1156
1157 x = x | y;
1158
1159 if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* OR */ )
1160 {
1161 if (x)
1162 {
1163 x = 1;
1164 }
1165 }
1166
1167 X->Number = x;
1168 X->VariantTypeCode = min_value_type (X);
1169 return RESULT_SUCCESS;
1170 }
1171 WARN_OVERFLOW;
1172 return RESULT_ERROR;
1173 }
1174 WARN_TYPE_MISMATCH;
1175 return RESULT_ERROR;
1176 }
1177 static ResultType
OP_AND(VariantType * X,VariantType * Y)1178 OP_AND (VariantType * X, VariantType * Y)
1179 {
1180
1181 assert (X != NULL);
1182 assert (Y != NULL);
1183 assert(My != NULL);
1184 assert(My->CurrentVersion != NULL);
1185
1186 if (both_number_type (X, Y))
1187 {
1188 /* X = (X AND Y) */
1189 if (both_are_long (X, Y))
1190 {
1191 long x;
1192 long y;
1193
1194 x = (long) bwb_rint (X->Number);
1195 y = (long) bwb_rint (Y->Number);
1196
1197 if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* AND */ )
1198 {
1199 if (x)
1200 {
1201 x = -1;
1202 }
1203 if (y)
1204 {
1205 y = -1;
1206 }
1207 }
1208
1209 x = x & y;
1210
1211 if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* AND */ )
1212 {
1213 if (x)
1214 {
1215 x = 1;
1216 }
1217 }
1218
1219 X->Number = x;
1220 X->VariantTypeCode = min_value_type (X);
1221 return RESULT_SUCCESS;
1222 }
1223 WARN_OVERFLOW;
1224 return RESULT_ERROR;
1225 }
1226 WARN_TYPE_MISMATCH;
1227 return RESULT_ERROR;
1228 }
1229 static ResultType
OP_XOR(VariantType * X,VariantType * Y)1230 OP_XOR (VariantType * X, VariantType * Y)
1231 {
1232
1233 assert (X != NULL);
1234 assert (Y != NULL);
1235 assert(My != NULL);
1236 assert(My->CurrentVersion != NULL);
1237
1238 if (both_number_type (X, Y))
1239 {
1240 /* X = (X XOR Y) */
1241 if (both_are_long (X, Y))
1242 {
1243 long x;
1244 long y;
1245
1246 x = (long) bwb_rint (X->Number);
1247 y = (long) bwb_rint (Y->Number);
1248
1249 if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* XOR */ )
1250 {
1251 if (x)
1252 {
1253 x = -1;
1254 }
1255 if (y)
1256 {
1257 y = -1;
1258 }
1259 }
1260
1261 x = x ^ y;
1262
1263 if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* XOR */ )
1264 {
1265 if (x)
1266 {
1267 x = 1;
1268 }
1269 }
1270
1271 X->Number = x;
1272 X->VariantTypeCode = min_value_type (X);
1273 return RESULT_SUCCESS;
1274 }
1275 WARN_OVERFLOW;
1276 return RESULT_ERROR;
1277 }
1278 WARN_TYPE_MISMATCH;
1279 return RESULT_ERROR;
1280 }
1281 static ResultType
OP_EQV(VariantType * X,VariantType * Y)1282 OP_EQV (VariantType * X, VariantType * Y)
1283 {
1284
1285 assert (X != NULL);
1286 assert (Y != NULL);
1287 assert(My != NULL);
1288 assert(My->CurrentVersion != NULL);
1289
1290 if (both_number_type (X, Y))
1291 {
1292 /* X = (X EQV Y) = NOT ( X XOR Y ) */
1293 if (both_are_long (X, Y))
1294 {
1295 long x;
1296 long y;
1297
1298 x = (long) bwb_rint (X->Number);
1299 y = (long) bwb_rint (Y->Number);
1300
1301 if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* EQV */ )
1302 {
1303 if (x)
1304 {
1305 x = -1;
1306 }
1307 if (y)
1308 {
1309 y = -1;
1310 }
1311 }
1312
1313 x = ~(x ^ y);
1314
1315 if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* EQV */ )
1316 {
1317 if (x)
1318 {
1319 x = 1;
1320 }
1321 }
1322
1323 X->Number = x;
1324 X->VariantTypeCode = min_value_type (X);
1325 return RESULT_SUCCESS;
1326 }
1327 WARN_OVERFLOW;
1328 return RESULT_ERROR;
1329 }
1330 WARN_TYPE_MISMATCH;
1331 return RESULT_ERROR;
1332 }
1333 static ResultType
OP_IMP(VariantType * X,VariantType * Y)1334 OP_IMP (VariantType * X, VariantType * Y)
1335 {
1336
1337 assert (X != NULL);
1338 assert (Y != NULL);
1339 assert(My != NULL);
1340 assert(My->CurrentVersion != NULL);
1341
1342 if (both_number_type (X, Y))
1343 {
1344 /* X = (X IMP Y) = (X AND Y) OR (NOT X) */
1345 if (both_are_long (X, Y))
1346 {
1347 long x;
1348 long y;
1349
1350 x = (long) bwb_rint (X->Number);
1351 y = (long) bwb_rint (Y->Number);
1352
1353 if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* IMP */ )
1354 {
1355 if (x)
1356 {
1357 x = -1;
1358 }
1359 if (y)
1360 {
1361 y = -1;
1362 }
1363 }
1364
1365 x = (x & y) | (~x);
1366
1367 if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* IMP */ )
1368 {
1369 if (x)
1370 {
1371 x = 1;
1372 }
1373 }
1374
1375 X->Number = x;
1376 X->VariantTypeCode = min_value_type (X);
1377 return RESULT_SUCCESS;
1378 }
1379 WARN_OVERFLOW;
1380 return RESULT_ERROR;
1381 }
1382 WARN_TYPE_MISMATCH;
1383 return RESULT_ERROR;
1384 }
1385 static ResultType
OP_NOT(VariantType * X,VariantType * Y)1386 OP_NOT (VariantType * X, VariantType * Y)
1387 {
1388
1389 assert (X != NULL);
1390 assert (Y == NULL);
1391 assert(My != NULL);
1392 assert(My->CurrentVersion != NULL);
1393
1394 if (Y != NULL)
1395 {
1396 WARN_INTERNAL_ERROR;
1397 return RESULT_ERROR;
1398 }
1399 if (is_number_type (X))
1400 {
1401 /* X = (NOT X) */
1402 if (is_long_value (X))
1403 {
1404 long x;
1405
1406 x = (long) bwb_rint (X->Number);
1407
1408 if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* NOT */ )
1409 {
1410 if (x)
1411 {
1412 x = -1;
1413 }
1414 }
1415
1416 x = ~x;
1417
1418 if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_BOOLEAN) /* NOT */ )
1419 {
1420 if (x)
1421 {
1422 x = 1;
1423 }
1424 }
1425
1426 X->Number = x;
1427 X->VariantTypeCode = min_value_type (X);
1428 return RESULT_SUCCESS;
1429 }
1430 WARN_OVERFLOW;
1431 return RESULT_ERROR;
1432 }
1433 WARN_TYPE_MISMATCH;
1434 return RESULT_ERROR;
1435 }
1436 static ResultType
OP_MAX(VariantType * X,VariantType * Y)1437 OP_MAX (VariantType * X, VariantType * Y)
1438 {
1439
1440 assert (X != NULL);
1441 assert (Y != NULL);
1442 if (both_number_type (X, Y))
1443 {
1444 /* X = (X MAX Y) = IIF( X < Y, Y, X ) */
1445 if (X->Number < Y->Number)
1446 {
1447 X->Number = Y->Number;
1448 }
1449 if (both_integer_type (X, Y))
1450 {
1451 X->Number = bwb_rint (X->Number);
1452 }
1453 X->VariantTypeCode = math_type (X, Y);
1454 return RESULT_SUCCESS;
1455 }
1456 if (both_string_type (X, Y))
1457 {
1458 /* X$ = ( X$ MAX Y$ ) == IIF( X$ < Y$, Y$, X$ ) */
1459 if (bwb_stricmp (X->Buffer, Y->Buffer) < 0)
1460 {
1461 RELEASE_VARIANT (X);
1462 COPY_VARIANT (X, Y);
1463 }
1464 return RESULT_SUCCESS;
1465 }
1466 WARN_TYPE_MISMATCH;
1467 return RESULT_ERROR;
1468 }
1469 static ResultType
OP_MIN(VariantType * X,VariantType * Y)1470 OP_MIN (VariantType * X, VariantType * Y)
1471 {
1472
1473 assert (X != NULL);
1474 assert (Y != NULL);
1475 if (both_number_type (X, Y))
1476 {
1477 /* X = (X MIN Y) = IIF( X > Y, Y, X ) */
1478 if (X->Number > Y->Number)
1479 {
1480 X->Number = Y->Number;
1481 }
1482 if (both_integer_type (X, Y))
1483 {
1484 X->Number = bwb_rint (X->Number);
1485 }
1486 X->VariantTypeCode = math_type (X, Y);
1487 return RESULT_SUCCESS;
1488 }
1489 if (both_string_type (X, Y))
1490 {
1491 /* X$ = ( X$ MIN Y$ ) == IIF( X$ > Y$, Y$, X$ ) */
1492 if (bwb_stricmp (X->Buffer, Y->Buffer) > 0)
1493 {
1494 RELEASE_VARIANT (X);
1495 COPY_VARIANT (X, Y);
1496 }
1497 return RESULT_SUCCESS;
1498 }
1499 WARN_TYPE_MISMATCH;
1500 return RESULT_ERROR;
1501 }
1502
1503 /*
1504 COMPARISON OPERATORS - these all return a TRUE/FALSE result in X
1505 */
1506
1507
1508 /* ------------------- equality */
1509
1510 static ResultType
test_eq(VariantType * X,VariantType * Y,int TrueValue,int FalseValue)1511 test_eq (VariantType * X, VariantType * Y, int TrueValue, int FalseValue)
1512 {
1513
1514 assert (X != NULL);
1515 assert (Y != NULL);
1516 assert(My != NULL);
1517 assert(My->CurrentVersion != NULL);
1518
1519 if (both_number_type (X, Y))
1520 {
1521 /* X = IIF( X = Y, TrueValue, FalseValue ) */
1522 if (both_are_long (X, Y))
1523 {
1524 long x;
1525 long y;
1526
1527 x = (long) bwb_rint (X->Number);
1528 y = (long) bwb_rint (Y->Number);
1529
1530 if (x == y)
1531 {
1532 X->Number = TrueValue;
1533 }
1534 else
1535 {
1536 X->Number = FalseValue;
1537 }
1538 }
1539 else
1540 {
1541 if (X->Number == Y->Number)
1542 {
1543 X->Number = TrueValue;
1544 }
1545 else
1546 {
1547 X->Number = FalseValue;
1548 }
1549
1550 }
1551 X->VariantTypeCode = IntegerTypeCode;
1552 return RESULT_SUCCESS;
1553 }
1554 if (both_string_type (X, Y))
1555 {
1556 /* X = IIF( X$ = Y$, TrueValue, FalseValue ) */
1557 /* NOTE: embedded NulChar terminate comparison */
1558 if (My->CurrentVersion->OptionFlags & OPTION_COMPARE_TEXT)
1559 {
1560 /* case insensitive */
1561 if (bwb_stricmp (X->Buffer, Y->Buffer) == 0)
1562 {
1563 X->Number = TrueValue;
1564 }
1565 else
1566 {
1567 X->Number = FalseValue;
1568 }
1569 }
1570 else
1571 {
1572 /* case sensitive */
1573 if (bwb_strcmp (X->Buffer, Y->Buffer) == 0)
1574 {
1575 X->Number = TrueValue;
1576 }
1577 else
1578 {
1579 X->Number = FalseValue;
1580 }
1581 }
1582 RELEASE_VARIANT (X);
1583 RELEASE_VARIANT (Y);
1584 X->VariantTypeCode = IntegerTypeCode;
1585 return RESULT_SUCCESS;
1586 }
1587 WARN_TYPE_MISMATCH;
1588 return RESULT_ERROR;
1589 }
1590 static ResultType
OP_EQ(VariantType * X,VariantType * Y)1591 OP_EQ (VariantType * X, VariantType * Y)
1592 {
1593
1594 assert (X != NULL);
1595 assert (Y != NULL);
1596 return test_eq (X, Y, TRUE, FALSE);
1597 }
1598 static ResultType
OP_NE(VariantType * X,VariantType * Y)1599 OP_NE (VariantType * X, VariantType * Y)
1600 {
1601
1602 assert (X != NULL);
1603 assert (Y != NULL);
1604 return test_eq (X, Y, FALSE, TRUE);
1605 }
1606
1607 /* ------------------- greater */
1608
1609 static ResultType
test_gt(VariantType * X,VariantType * Y,int TrueValue,int FalseValue)1610 test_gt (VariantType * X, VariantType * Y, int TrueValue, int FalseValue)
1611 {
1612
1613 assert (X != NULL);
1614 assert (Y != NULL);
1615 assert(My != NULL);
1616 assert(My->CurrentVersion != NULL);
1617
1618 if (both_number_type (X, Y))
1619 {
1620 /* X = IIF( X > Y, TrueValue, FalseValue ) */
1621 if (both_are_long (X, Y))
1622 {
1623 long x;
1624 long y;
1625
1626 x = (long) bwb_rint (X->Number);
1627 y = (long) bwb_rint (Y->Number);
1628
1629 if (x > y)
1630 {
1631 X->Number = TrueValue;
1632 }
1633 else
1634 {
1635 X->Number = FalseValue;
1636 }
1637 }
1638 else
1639 {
1640 if (X->Number > Y->Number)
1641 {
1642 X->Number = TrueValue;
1643 }
1644 else
1645 {
1646 X->Number = FalseValue;
1647 }
1648
1649 }
1650 X->VariantTypeCode = IntegerTypeCode;
1651 return RESULT_SUCCESS;
1652 }
1653 if (both_string_type (X, Y))
1654 {
1655 /* X = IIF( X$ > Y$, TrueValue, FalseValue ) */
1656 /* NOTE: embedded NUL characters terminate comparison */
1657 if (My->CurrentVersion->OptionFlags & OPTION_COMPARE_TEXT)
1658 {
1659 /* case insensitive */
1660 if (bwb_stricmp (X->Buffer, Y->Buffer) > 0)
1661 {
1662 X->Number = TrueValue;
1663 }
1664 else
1665 {
1666 X->Number = FalseValue;
1667 }
1668 }
1669 else
1670 {
1671 /* case sensitive */
1672 if (bwb_strcmp (X->Buffer, Y->Buffer) > 0)
1673 {
1674 X->Number = TrueValue;
1675 }
1676 else
1677 {
1678 X->Number = FalseValue;
1679 }
1680 }
1681 RELEASE_VARIANT (X);
1682 RELEASE_VARIANT (Y);
1683 X->VariantTypeCode = IntegerTypeCode;
1684 return RESULT_SUCCESS;
1685 }
1686 WARN_TYPE_MISMATCH;
1687 return RESULT_ERROR;
1688 }
1689 static ResultType
OP_GT(VariantType * X,VariantType * Y)1690 OP_GT (VariantType * X, VariantType * Y)
1691 {
1692
1693 assert (X != NULL);
1694 assert (Y != NULL);
1695 return test_gt (X, Y, TRUE, FALSE);
1696 }
1697 static ResultType
OP_LE(VariantType * X,VariantType * Y)1698 OP_LE (VariantType * X, VariantType * Y)
1699 {
1700
1701 assert (X != NULL);
1702 assert (Y != NULL);
1703 return test_gt (X, Y, FALSE, TRUE);
1704 }
1705
1706 /* ------------------- lesser */
1707
1708 static ResultType
test_lt(VariantType * X,VariantType * Y,int TrueValue,int FalseValue)1709 test_lt (VariantType * X, VariantType * Y, int TrueValue, int FalseValue)
1710 {
1711
1712 assert (X != NULL);
1713 assert (Y != NULL);
1714 assert(My != NULL);
1715 assert(My->CurrentVersion != NULL);
1716
1717 if (both_number_type (X, Y))
1718 {
1719 /* X = IIF( X < Y, TrueValue, FalseValue ) */
1720 if (both_are_long (X, Y))
1721 {
1722 long x;
1723 long y;
1724
1725 x = (long) bwb_rint (X->Number);
1726 y = (long) bwb_rint (Y->Number);
1727
1728 if (x < y)
1729 {
1730 X->Number = TrueValue;
1731 }
1732 else
1733 {
1734 X->Number = FalseValue;
1735 }
1736 }
1737 else
1738 {
1739 if (X->Number < Y->Number)
1740 {
1741 X->Number = TrueValue;
1742 }
1743 else
1744 {
1745 X->Number = FalseValue;
1746 }
1747
1748 }
1749 X->VariantTypeCode = IntegerTypeCode;
1750 return RESULT_SUCCESS;
1751 }
1752 if (both_string_type (X, Y))
1753 {
1754 /* X = IIF( X$ < Y$, TrueValue, FalseValue ) */
1755 /* NOTE: embedded NUL characters terminate comparison */
1756 if (My->CurrentVersion->OptionFlags & OPTION_COMPARE_TEXT)
1757 {
1758 /* case insensitive */
1759 if (bwb_stricmp (X->Buffer, Y->Buffer) < 0)
1760 {
1761 X->Number = TrueValue;
1762 }
1763 else
1764 {
1765 X->Number = FalseValue;
1766 }
1767 }
1768 else
1769 {
1770 /* case sensitive */
1771 if (bwb_strcmp (X->Buffer, Y->Buffer) < 0)
1772 {
1773 X->Number = TrueValue;
1774 }
1775 else
1776 {
1777 X->Number = FalseValue;
1778 }
1779 }
1780 RELEASE_VARIANT (X);
1781 RELEASE_VARIANT (Y);
1782 X->VariantTypeCode = IntegerTypeCode;
1783 return RESULT_SUCCESS;
1784 }
1785 WARN_TYPE_MISMATCH;
1786 return RESULT_ERROR;
1787 }
1788 static ResultType
OP_LT(VariantType * X,VariantType * Y)1789 OP_LT (VariantType * X, VariantType * Y)
1790 {
1791
1792 assert (X != NULL);
1793 assert (Y != NULL);
1794 return test_lt (X, Y, TRUE, FALSE);
1795 }
1796 static ResultType
OP_GE(VariantType * X,VariantType * Y)1797 OP_GE (VariantType * X, VariantType * Y)
1798 {
1799
1800 assert (X != NULL);
1801 assert (Y != NULL);
1802 return test_lt (X, Y, FALSE, TRUE);
1803 }
1804
1805 /* ------------------- like */
1806
1807 static ResultType
OP_LIKE(VariantType * X,VariantType * Y)1808 OP_LIKE (VariantType * X, VariantType * Y)
1809 {
1810
1811 assert (X != NULL);
1812 assert (Y != NULL);
1813 if (both_string_type (X, Y))
1814 {
1815 /* X = (X$ LIKE Y$) */
1816 int X_count;
1817 int Y_count;
1818
1819 X_count = 0;
1820 Y_count = 0;
1821
1822 if (IsLike (X->Buffer, &X_count, X->Length,
1823 Y->Buffer, &Y_count, Y->Length))
1824 {
1825 X->Number = TRUE;
1826 }
1827 else
1828 {
1829 X->Number = FALSE;
1830 }
1831 RELEASE_VARIANT (X);
1832 RELEASE_VARIANT (Y);
1833 X->VariantTypeCode = IntegerTypeCode;
1834 return RESULT_SUCCESS;
1835 }
1836 WARN_TYPE_MISMATCH;
1837 return RESULT_ERROR;
1838 }
1839
1840
1841 /*
1842 --------------------------------------------------------------------------------------------
1843 Line Parsing Utilities
1844 --------------------------------------------------------------------------------------------
1845 */
1846
1847 static OperatorType *
buff_read_operator(char * buffer,int * position,unsigned char LastPrec,unsigned char Arity)1848 buff_read_operator (char *buffer, int *position, unsigned char LastPrec,
1849 unsigned char Arity)
1850 {
1851 int p;
1852
1853 assert (buffer != NULL);
1854 assert (position != NULL);
1855 assert(My != NULL);
1856 assert(My->CurrentVersion != NULL);
1857
1858 p = *position;
1859 if (bwb_isalpha (buffer[p]))
1860 {
1861 /* only consider alphabetic operators */
1862 /* spaces between any character of the operator is not allowed */
1863 char name[NameLengthMax + 1];
1864
1865 if (buff_read_varname (buffer, &p, name))
1866 {
1867 int i;
1868 for (i = 0; i < NUM_OPERATORS; i++)
1869 {
1870 OperatorType *T;
1871
1872 T = &OperatorTable[i];
1873 if (T->OptionVersionBitmask & My->CurrentVersion->OptionVersionValue)
1874 {
1875 if (T->ThisPrec >= LastPrec && T->Arity == Arity
1876 && T->IsAlpha == IS_ALPHA)
1877 {
1878 /* possible */
1879 if (bwb_stricmp (T->Name, name) == 0)
1880 {
1881 /* FOUND */
1882 *position = p;
1883 return T;
1884 }
1885 }
1886 }
1887 }
1888 }
1889 }
1890 else
1891 {
1892 /* only consider non-alphabetic operators */
1893 /* spaces between any character of the operator is allowed */
1894 int i;
1895 for (i = 0; i < NUM_OPERATORS; i++)
1896 {
1897 OperatorType *T;
1898
1899 T = &OperatorTable[i];
1900 if (T->OptionVersionBitmask & My->CurrentVersion->OptionVersionValue)
1901 {
1902 if (T->ThisPrec >= LastPrec && T->Arity == Arity
1903 && T->IsAlpha == NO_ALPHA)
1904 {
1905 /* possible */
1906 int m; /* number of characters actually matched */
1907 int n; /* number of characters to match */
1908 int q; /* position after skipping the characters */
1909
1910 n = bwb_strlen (T->Name); /* number of characters to match */
1911 q = p;
1912
1913 for (m = 0; m < n && buff_skip_char (buffer, &q, T->Name[m]); m++);
1914 if (m == n)
1915 {
1916 /* FOUND */
1917 *position = q;
1918 return T;
1919 }
1920 }
1921 }
1922 }
1923 }
1924 /* NOT FOUND */
1925 return NULL;
1926 }
1927
1928 #if FALSE /* keep line_... */
1929 static OperatorType *
line_read_operator(LineType * line,unsigned char LastPrec,unsigned char Arity)1930 line_read_operator (LineType * line, unsigned char LastPrec,
1931 unsigned char Arity)
1932 {
1933
1934 assert (line != NULL);
1935 return buff_read_operator (line->buffer, &(line->position), LastPrec,
1936 Arity);
1937 }
1938 #endif
1939 static ResultType
buff_read_string_constant(char * buffer,int * position,VariantType * X)1940 buff_read_string_constant (char *buffer, int *position, VariantType * X)
1941 {
1942 int p;
1943
1944 assert (buffer != NULL);
1945 assert (position != NULL);
1946 assert (X != NULL);
1947 assert(My != NULL);
1948 assert(My->CurrentVersion != NULL);
1949
1950 p = *position;
1951 if (buffer[p] == My->CurrentVersion->OptionQuoteChar)
1952 {
1953 int q; /* start of constant */
1954 X->VariantTypeCode = StringTypeCode;
1955 p++; /* skip leading quote */
1956 /* determine the length of the quoted string */
1957 X->Length = 0;
1958 q = p;
1959 while (buffer[p])
1960 {
1961 if (buffer[p] == My->CurrentVersion->OptionQuoteChar)
1962 {
1963 p++; /* quote */
1964 if (buffer[p] == My->CurrentVersion->OptionQuoteChar)
1965 {
1966 /* embedded string "...""..." */
1967 }
1968 else
1969 {
1970 /* properly terminated string "...xx..." */
1971 break;
1972 }
1973 }
1974 X->Length++;
1975 p++;
1976 }
1977 if ((X->Buffer =
1978 (char *) calloc (X->Length + 1 /* NulChar */ ,
1979 sizeof (char))) == NULL)
1980 {
1981 WARN_OUT_OF_MEMORY;
1982 return RESULT_ERROR;
1983 }
1984 /* copy the quoted string */
1985 X->Length = 0;
1986 p = q;
1987 while (buffer[p])
1988 {
1989 if (buffer[p] == My->CurrentVersion->OptionQuoteChar)
1990 {
1991 p++; /* skip quote */
1992 if (buffer[p] == My->CurrentVersion->OptionQuoteChar)
1993 {
1994 /* embedded string "...""..." */
1995 }
1996 else
1997 {
1998 /* properly terminated string "...xx..." */
1999 break;
2000 }
2001 }
2002 X->Buffer[X->Length] = buffer[p];
2003 X->Length++;
2004 p++;
2005 }
2006 X->Buffer[X->Length] = NulChar;
2007 *position = p;
2008 return RESULT_SUCCESS;
2009 }
2010 /* NOT FOUND */
2011 return RESULT_UNPARSED;
2012 }
2013
2014 #if FALSE /* keep line_... */
2015 static ResultType
line_read_string_constant(LineType * line,VariantType * X)2016 line_read_string_constant (LineType * line, VariantType * X)
2017 {
2018
2019 assert (line != NULL);
2020 assert (X != NULL);
2021 return buff_read_string_constant (line->buffer, &(line->position), X);
2022 }
2023 #endif
2024 extern ResultType
buff_read_hexadecimal_constant(char * buffer,int * position,VariantType * X,int IsConsoleInput)2025 buff_read_hexadecimal_constant (char *buffer, int *position, VariantType * X,
2026 int IsConsoleInput)
2027 {
2028 /* &h... */
2029 int p;
2030
2031 assert (buffer != NULL);
2032 assert (position != NULL);
2033 assert (X != NULL);
2034 assert(My != NULL);
2035 assert(My->CurrentVersion != NULL);
2036
2037
2038 p = *position;
2039 if (My->CurrentVersion->OptionFlags & OPTION_BUGS_ON ) /* allows hexadecimal constants */
2040 {
2041 if (buffer[p] == '&')
2042 {
2043 p++; /* skip '&' */
2044 if (bwb_tolower (buffer[p]) == 'h')
2045 {
2046 /* &h... */
2047 p++; /* skip 'h' */
2048 if (bwb_isxdigit (buffer[p]))
2049 {
2050 /* &hABCD */
2051 int n; /* number of characters read */
2052 unsigned long x; /* value read */
2053
2054 n = 0;
2055 x = 0;
2056
2057 /* if( sscanf( &buffer[ p ], "%lx%n", &x, &n ) == 1 ) */
2058 if (sscanf (&buffer[p], HexScanFormat, &x, &n) == 1)
2059 {
2060 /* FOUND */
2061 p += n;
2062
2063 X->Number = x;
2064 X->VariantTypeCode = min_value_type (X);
2065 if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_ON)) /* TypeSuffix allowed on constants */
2066 {
2067 char TypeCode;
2068 TypeCode = Char_to_TypeCode (buffer[p]);
2069 switch (TypeCode)
2070 {
2071 case ByteTypeCode:
2072 case IntegerTypeCode:
2073 case LongTypeCode:
2074 case CurrencyTypeCode:
2075 case SingleTypeCode:
2076 case DoubleTypeCode:
2077 p++; /* skip TypeCode */
2078 /* verify the value actually fits in the declared type */
2079 X->VariantTypeCode = TypeCode;
2080 TypeCode = Largest_TypeCode (TypeCode, X);
2081 if (X->VariantTypeCode != TypeCode)
2082 {
2083 /* declared type is too small */
2084 if (IsConsoleInput)
2085 {
2086 /*
2087 **
2088 ** The user will re-enter the data
2089 **
2090 */
2091 return RESULT_UNPARSED;
2092 }
2093 if (WARN_OVERFLOW)
2094 {
2095 /* ERROR */
2096 return RESULT_ERROR;
2097 }
2098 /* CONTINUE */
2099 X->VariantTypeCode = TypeCode;
2100 }
2101 break;
2102 case StringTypeCode:
2103 /* oops */
2104 if (IsConsoleInput)
2105 {
2106 /*
2107 **
2108 ** The user will re-enter the data
2109 **
2110 */
2111 return RESULT_UNPARSED;
2112 }
2113 WARN_SYNTAX_ERROR;
2114 return RESULT_ERROR;
2115 /* break; */
2116 default:
2117 X->VariantTypeCode = min_value_type (X);
2118 }
2119 }
2120 *position = p;
2121 return RESULT_SUCCESS;
2122 }
2123 }
2124 /* not HEXADECIMAL */
2125 }
2126 }
2127 }
2128 /* NOT FOUND */
2129 return RESULT_UNPARSED;
2130 }
2131
2132 #if FALSE /* keep line_... */
2133 static ResultType
line_read_hexadecimal_constant(LineType * line,VariantType * X)2134 line_read_hexadecimal_constant (LineType * line, VariantType * X)
2135 {
2136
2137 assert (line != NULL);
2138 assert (X != NULL);
2139 return buff_read_hexadecimal_constant (line->buffer, &(line->position), X,
2140 FALSE);
2141 }
2142 #endif
2143 extern ResultType
buff_read_octal_constant(char * buffer,int * position,VariantType * X,int IsConsoleInput)2144 buff_read_octal_constant (char *buffer, int *position, VariantType * X,
2145 int IsConsoleInput)
2146 {
2147 /* &o... */
2148 int p;
2149
2150 assert (buffer != NULL);
2151 assert (position != NULL);
2152 assert (X != NULL);
2153 assert(My != NULL);
2154 assert(My->CurrentVersion != NULL);
2155
2156
2157 p = *position;
2158
2159 if (My->CurrentVersion->OptionFlags & OPTION_BUGS_ON ) /* allows octal constants */
2160 {
2161 if (buffer[p] == '&')
2162 {
2163 p++; /* skip '&' */
2164 if (bwb_tolower (buffer[p]) == 'o')
2165 {
2166 /* &o777 */
2167 p++; /* skip 'o' */
2168 /* fall-thru */
2169 }
2170 if (bwb_isodigit (buffer[p]))
2171 {
2172 /* &o777 */
2173 /* &777 */
2174 int n; /* number of characters read */
2175 unsigned long x; /* value read */
2176
2177 n = 0;
2178 x = 0;
2179
2180 /* if( sscanf( &buffer[ p ], "%64lo%n", &x, &n ) == 1 ) */
2181 if (sscanf (&buffer[p], OctScanFormat, &x, &n) == 1)
2182 {
2183 /* FOUND */
2184 p += n;
2185
2186 X->Number = x;
2187 X->VariantTypeCode = min_value_type (X);
2188 if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_ON)) /* TypeSuffix allowed on constants */
2189 {
2190 char TypeCode;
2191
2192 TypeCode = Char_to_TypeCode (buffer[p]);
2193 switch (TypeCode)
2194 {
2195 case ByteTypeCode:
2196 case IntegerTypeCode:
2197 case LongTypeCode:
2198 case CurrencyTypeCode:
2199 case SingleTypeCode:
2200 case DoubleTypeCode:
2201 p++; /* skip TypeCode */
2202 /* verify the value actually fits in the declared type */
2203 X->VariantTypeCode = TypeCode;
2204 TypeCode = Largest_TypeCode (TypeCode, X);
2205 if (X->VariantTypeCode != TypeCode)
2206 {
2207 /* declared type is too small */
2208 if (IsConsoleInput)
2209 {
2210 /*
2211 **
2212 ** The user will re-enter the data
2213 **
2214 */
2215 return RESULT_UNPARSED;
2216 }
2217 if (WARN_OVERFLOW)
2218 {
2219 /* ERROR */
2220 return RESULT_ERROR;
2221 }
2222 /* CONTINUE */
2223 X->VariantTypeCode = TypeCode;
2224 }
2225 break;
2226 case StringTypeCode:
2227 /* oops */
2228 if (IsConsoleInput)
2229 {
2230 /*
2231 **
2232 ** The user will re-enter the data
2233 **
2234 */
2235 return RESULT_UNPARSED;
2236 }
2237 WARN_SYNTAX_ERROR;
2238 return RESULT_ERROR;
2239 /* break; */
2240 default:
2241 X->VariantTypeCode = min_value_type (X);
2242 }
2243 }
2244 *position = p;
2245 return RESULT_SUCCESS;
2246 }
2247 }
2248 }
2249 }
2250 /* NOT FOUND */
2251 return RESULT_UNPARSED;
2252 }
2253
2254 #if FALSE /* keep line_... */
2255 static ResultType
line_read_octal_constant(LineType * line,VariantType * X)2256 line_read_octal_constant (LineType * line, VariantType * X)
2257 {
2258
2259 assert (line != NULL);
2260 assert (X != NULL);
2261 return buff_read_octal_constant (line->buffer, &(line->position), X, FALSE);
2262 }
2263 #endif
2264 static ResultType
buff_read_internal_constant(char * buffer,int * position,VariantType * X)2265 buff_read_internal_constant (char *buffer, int *position, VariantType * X)
2266 {
2267 /* &... */
2268 int p;
2269
2270 assert (buffer != NULL);
2271 assert (position != NULL);
2272 assert (X != NULL);
2273 assert(My != NULL);
2274 assert(My->CurrentVersion != NULL);
2275
2276
2277 p = *position;
2278
2279 if (My->CurrentVersion->OptionVersionValue & (S70 | I70 | I73))
2280 {
2281 /* IBM System/360 and System/370 BASIC dialects */
2282 if (buffer[p] == '&')
2283 {
2284 p++; /* skip '&' */
2285 if (bwb_isalpha (buffer[p]))
2286 {
2287 char *S;
2288 S = &(buffer[p]);
2289 if (bwb_strnicmp (S, "PI", 2) == 0)
2290 {
2291 /* &PI */
2292 p += 2;
2293 X->Number = 3.14159265358979;
2294 X->VariantTypeCode = DoubleTypeCode;
2295 *position = p;
2296 return RESULT_SUCCESS;
2297 }
2298 if (bwb_strnicmp (S, "E", 1) == 0)
2299 {
2300 /* &E */
2301 p += 1;
2302 X->Number = 2.71828182845905;
2303 X->VariantTypeCode = DoubleTypeCode;
2304 *position = p;
2305 return RESULT_SUCCESS;
2306 }
2307 if (bwb_strnicmp (S, "SQR2", 4) == 0)
2308 {
2309 /* &SQR2 */
2310 p += 4;
2311 X->Number = 1.41421356237309;
2312 X->VariantTypeCode = DoubleTypeCode;
2313 *position = p;
2314 return RESULT_SUCCESS;
2315 }
2316 /* NOT a magic word */
2317 }
2318 }
2319 }
2320 /* NOT FOUND */
2321 return RESULT_UNPARSED;
2322 }
2323
2324 #if FALSE /* keep line_... */
2325 static ResultType
line_read_internal_constant(LineType * line,VariantType * X)2326 line_read_internal_constant (LineType * line, VariantType * X)
2327 {
2328
2329 assert (line != NULL);
2330 assert (X != NULL);
2331 return buff_read_internal_constant (line->buffer, &(line->position), X);
2332 }
2333 #endif
2334 extern ResultType
buff_read_decimal_constant(char * buffer,int * position,VariantType * X,int IsConsoleInput)2335 buff_read_decimal_constant (char *buffer, int *position, VariantType * X,
2336 int IsConsoleInput)
2337 {
2338 int p;
2339
2340 assert (buffer != NULL);
2341 assert (position != NULL);
2342 assert (X != NULL);
2343 assert(My != NULL);
2344 assert(My->CurrentVersion != NULL);
2345
2346
2347 p = *position;
2348 if (bwb_isdigit (buffer[p]) || buffer[p] == '.')
2349 {
2350 /* .12345 */
2351 /* 123.45 */
2352 /* 123456 */
2353 /* 123E45 */
2354 /* TODO: 'D' instead of 'E' */
2355 int n; /* number of characters read */
2356 DoubleType x; /* value read */
2357
2358
2359 n = 0;
2360 x = 0;
2361
2362 /* if( sscanf( &buffer[ p ], "%lg%n", &X->Number, &n ) == 1 ) */
2363 if (sscanf (&buffer[p], DecScanFormat, &x, &n) == 1)
2364 {
2365 /* FOUND */
2366 p += n;
2367
2368 /* VerifyNumeric */
2369 if (isnan (x))
2370 {
2371 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
2372 WARN_INTERNAL_ERROR;
2373 return RESULT_ERROR;
2374 }
2375 if (isinf (x))
2376 {
2377 /* - Evaluation of an expression results in an overflow
2378 * (nonfatal, the recommended recovery procedure is to supply
2379 * machine in- finity with the algebraically correct sign and
2380 * continue). */
2381 if (x < 0)
2382 {
2383 x = MINDBL;
2384 }
2385 else
2386 {
2387 x = MAXDBL;
2388 }
2389 if (IsConsoleInput)
2390 {
2391 /*
2392 **
2393 ** The user will re-enter the data
2394 **
2395 */
2396 return RESULT_UNPARSED;
2397 }
2398 if (WARN_OVERFLOW)
2399 {
2400 /* ERROR */
2401 return RESULT_ERROR;
2402 }
2403 /* CONTINUE */
2404 }
2405 /* OK */
2406 X->Number = x;
2407 X->VariantTypeCode = DoubleTypeCode; /* min_value_type( X ); */
2408 if (My->CurrentVersion->OptionFlags & OPTION_BUGS_ON ) /* TypeSuffix allowed on constants */
2409 {
2410 char TypeCode;
2411 TypeCode = Char_to_TypeCode (buffer[p]);
2412 switch (TypeCode)
2413 {
2414 case ByteTypeCode:
2415 case IntegerTypeCode:
2416 case LongTypeCode:
2417 case CurrencyTypeCode:
2418 case SingleTypeCode:
2419 case DoubleTypeCode:
2420 p++; /* skip TypeCode */
2421 /* verify the value actually fits in the declared type */
2422 X->VariantTypeCode = TypeCode;
2423 TypeCode = Largest_TypeCode (TypeCode, X);
2424 if (X->VariantTypeCode != TypeCode)
2425 {
2426 /* declared type is too small */
2427 if (IsConsoleInput)
2428 {
2429 /*
2430 **
2431 ** The user will re-enter the data
2432 **
2433 */
2434 return RESULT_UNPARSED;
2435 }
2436 if (WARN_OVERFLOW)
2437 {
2438 /* ERROR */
2439 return RESULT_ERROR;
2440 }
2441 /* CONTINUE */
2442 X->VariantTypeCode = TypeCode;
2443 }
2444 break;
2445 case StringTypeCode:
2446 /* oops */
2447 if (IsConsoleInput)
2448 {
2449 /*
2450 **
2451 ** The user will re-enter the data
2452 **
2453 */
2454 return RESULT_UNPARSED;
2455 }
2456 WARN_SYNTAX_ERROR;
2457 return RESULT_ERROR;
2458 /* break; */
2459 default:
2460 X->VariantTypeCode = DoubleTypeCode; /* min_value_type( X ); */
2461 }
2462 }
2463 *position = p;
2464 return RESULT_SUCCESS;
2465 }
2466 }
2467 /* NOT FOUND */
2468 return RESULT_UNPARSED;
2469 }
2470
2471 #if FALSE /* keep line_... */
2472 static int
line_read_decimal_constant(LineType * line,VariantType * X)2473 line_read_decimal_constant (LineType * line, VariantType * X)
2474 {
2475
2476 assert (line != NULL);
2477 assert (X != NULL);
2478 return buff_read_decimal_constant (line->buffer, &(line->position), X,
2479 FALSE);
2480 }
2481 #endif
2482
2483 static ResultType
buff_read_function(char * buffer,int * position,VariantType * X)2484 buff_read_function (char *buffer, int *position, VariantType * X)
2485 {
2486 int p;
2487 char name[NameLengthMax + 1];
2488
2489 assert (buffer != NULL);
2490 assert (position != NULL);
2491 assert (X != NULL);
2492 assert(My != NULL);
2493 assert(My->CurrentVersion != NULL);
2494
2495
2496 p = *position;
2497 if (buff_read_varname (buffer, &p, name))
2498 {
2499 if (UserFunction_name (name) || IntrinsicFunction_name (name))
2500 {
2501 /* ---------------------------------------------------------------------------- */
2502 /* if( TRUE ) */
2503 {
2504 /* here we handle some pseudo-functions that return information about arrays */
2505 char Xbound;
2506
2507 Xbound = NulChar;
2508 if (buff_peek_LparenChar (buffer, &p))
2509 {
2510 if (bwb_stricmp (name, "DET") == 0)
2511 {
2512 /* N = DET( varname ) */
2513 /* N = DET is handled by F_DET_N */
2514 Xbound = 'd';
2515 }
2516 else if (bwb_stricmp (name, "DIM") == 0)
2517 {
2518 /* N = DIM( varname ) */
2519 /* return total number of dimensions */
2520 Xbound = 'D';
2521 }
2522 else if (bwb_stricmp (name, "SIZE") == 0)
2523 {
2524 if (My->CurrentVersion->OptionVersionValue & (C77))
2525 {
2526 /* N = SIZE( filename ) is handled by F_SIZE_A_N */
2527 }
2528 else
2529 {
2530 /* N = SIZE( varname ) */
2531 /* return total number of elements */
2532 Xbound = 'S';
2533 }
2534 }
2535 else if (bwb_stricmp (name, "LBOUND") == 0)
2536 {
2537 /* N = LBOUND( varname [ , dimension ] ) */
2538 /* return LOWER bound */
2539 Xbound = 'L';
2540 }
2541 else if (bwb_stricmp (name, "UBOUND") == 0)
2542 {
2543 /* N = UBOUND( varname [ , dimension ] ) */
2544 /* return UPPER bound */
2545 Xbound = 'U';
2546 }
2547 }
2548 if (Xbound)
2549 {
2550 VariableType *v;
2551 int dimension;
2552 char varname[NameLengthMax + 1];
2553
2554 v = NULL;
2555 dimension = 0; /* default */
2556
2557
2558 if (buff_skip_LparenChar (buffer, &p) == FALSE)
2559 {
2560 WARN_SYNTAX_ERROR;
2561 return RESULT_ERROR;
2562 }
2563 if (buff_read_varname (buffer, &p, varname) == FALSE)
2564 {
2565 WARN_SYNTAX_ERROR;
2566 return RESULT_ERROR;
2567 }
2568 /* search for array */
2569 v = mat_find (varname);
2570 if (v == NULL)
2571 {
2572 WARN_TYPE_MISMATCH;
2573 return RESULT_ERROR;
2574 }
2575 if (v->dimensions == 0)
2576 {
2577 /* calling DET(), DIM(), SIZE(), LBOUND() or UBOUND() on a scalar is an ERROR */
2578 WARN_TYPE_MISMATCH;
2579 return RESULT_ERROR;
2580 }
2581 switch (Xbound)
2582 {
2583 case 'd': /* DET() */
2584 case 'D': /* DIM() */
2585 case 'S': /* SIZE() */
2586 break;
2587 case 'L': /* LBOUND() */
2588 case 'U': /* UBOUND() */
2589 if (buff_skip_seperator (buffer, &p))
2590 {
2591 ResultType ResultCode;
2592 VariantType t;
2593 VariantType *T;
2594
2595 T = &t;
2596 ResultCode = buff_read_expr (buffer, &p, T, 1);
2597 if (ResultCode != RESULT_SUCCESS)
2598 {
2599 /* ERROR */
2600 RELEASE_VARIANT (T);
2601 return ResultCode;
2602 }
2603 if (is_string_type (T))
2604 {
2605 RELEASE_VARIANT (T);
2606 WARN_TYPE_MISMATCH;
2607 return RESULT_ERROR;
2608 }
2609 T->Number = bwb_rint (T->Number);
2610 if (T->Number < 1 || T->Number > v->dimensions)
2611 {
2612 WARN_TYPE_MISMATCH;
2613 return RESULT_ERROR;
2614 }
2615 dimension = (int) bwb_rint (T->Number);
2616 dimension--; /* BASIC to C */
2617 }
2618 else
2619 {
2620 dimension = 0; /* default */
2621 }
2622 break;
2623 default:
2624 WARN_INTERNAL_ERROR;
2625 return RESULT_ERROR;
2626 /* break; */
2627 }
2628 if (buff_skip_RparenChar (buffer, &p) == FALSE)
2629 {
2630 WARN_SYNTAX_ERROR;
2631 return RESULT_ERROR;
2632 }
2633 /* OK */
2634 switch (Xbound)
2635 {
2636 case 'd': /* DET() */
2637 Determinant (v);
2638 X->Number = My->LastDeterminant;
2639 break;
2640 case 'D': /* DIM() */
2641 X->Number = v->dimensions;
2642 break;
2643 case 'S': /* SIZE() */
2644 X->Number = v->array_units;
2645 break;
2646 case 'L': /* LBOUND() */
2647 X->Number = v->LBOUND[dimension];
2648 break;
2649 case 'U': /* UBOUND() */
2650 X->Number = v->UBOUND[dimension];
2651 break;
2652 default:
2653 WARN_INTERNAL_ERROR;
2654 return RESULT_ERROR;
2655 /* break; */
2656 }
2657 X->VariantTypeCode = LongTypeCode;
2658 *position = p;
2659 return RESULT_SUCCESS;
2660 }
2661 }
2662 /* ---------------------------------------------------------------------------- */
2663 /* if( TRUE ) */
2664 {
2665 /* it is a function */
2666 UserFunctionType *L;
2667 unsigned char ParameterCount;
2668 ParamBitsType ParameterTypes;
2669 VariableType *argv;
2670 VariableType *argn;
2671
2672 ParameterCount = 0;
2673 ParameterTypes = 0;
2674 argv = var_chain (NULL); /* RETURN variable */
2675 argn = NULL;
2676
2677 if (buff_skip_LparenChar (buffer, &p))
2678 {
2679 if (buff_skip_RparenChar (buffer, &p))
2680 {
2681 /* RND() */
2682 }
2683 else
2684 {
2685 /* RND( 1, 2, 3 ) */
2686 do
2687 {
2688 ResultType ResultCode;
2689 VariantType T;
2690
2691 ResultCode = buff_read_expr (buffer, &p, &T, 1);
2692 if (ResultCode != RESULT_SUCCESS)
2693 {
2694 /* ERROR */
2695 var_free (argv); /* free ARGV chain */
2696 return ResultCode;
2697 }
2698 /* add value to ARGV chain */
2699 argn = var_chain (argv);
2700 /* 'argn' is the variable to use */
2701 if (is_string_type (&T))
2702 {
2703 /* STRING */
2704 var_make (argn, StringTypeCode);
2705 if ((argn->Value.String =
2706 (StringType *) calloc (1, sizeof (StringType))) == NULL)
2707 {
2708 WARN_OUT_OF_MEMORY;
2709 return RESULT_ERROR;
2710 }
2711 PARAM_LENGTH = T.Length;
2712 /* PARAM_BUFFER = T.Buffer; */
2713 if ((PARAM_BUFFER =
2714 (char *) calloc (T.Length + 1 /* NulChar */ ,
2715 sizeof (char))) == NULL)
2716 {
2717 WARN_OUT_OF_MEMORY;
2718 return RESULT_ERROR;
2719 }
2720 bwb_memcpy (PARAM_BUFFER, T.Buffer, T.Length);
2721 PARAM_BUFFER[PARAM_LENGTH] = NulChar;
2722 /* add type to ParameterTypes */
2723 if (ParameterCount < MAX_FARGS)
2724 {
2725 ParameterTypes |= (1 << ParameterCount);
2726 }
2727 }
2728 else
2729 {
2730 /* NUMBER */
2731 var_make (argn, DoubleTypeCode);
2732 PARAM_NUMBER = T.Number;
2733 }
2734 /* increment ParameterCount */
2735 if (ParameterCount < 255 /* (...) */ )
2736 {
2737 ParameterCount++;
2738 }
2739 /* RELEASE_VARIANT( &T ); */
2740 }
2741 while (buff_skip_seperator (buffer, &p));
2742
2743
2744 if (buff_skip_RparenChar (buffer, &p) == FALSE)
2745 {
2746 /* ERROR */
2747 var_free (argv); /* free ARGV chain */
2748 WARN_SYNTAX_ERROR;
2749 return RESULT_ERROR;
2750 }
2751 }
2752 }
2753 else
2754 {
2755 /* RND */
2756 }
2757
2758 /* search for exact match to the function parameter signature */
2759 if (ParameterCount > MAX_FARGS)
2760 {
2761 /* FORCE (...) */
2762 ParameterCount = 255; /* (...) */
2763 ParameterTypes = 0;
2764 }
2765 /* did we find the correct function above? */
2766 L = UserFunction_find_exact (name, ParameterCount, ParameterTypes);
2767 if (L == NULL)
2768 {
2769 L = UserFunction_find_exact (name, 255 /* (...) */ , 0);
2770 }
2771 if (L != NULL)
2772 {
2773 /* USER function */
2774 if (L->line == NULL)
2775 {
2776 var_free (argv); /* free ARGV chain */
2777 WARN_INTERNAL_ERROR;
2778 return RESULT_ERROR;
2779 }
2780 /* defaullt the return value */
2781 var_make (argv, L->ReturnTypeCode);
2782 bwb_strcpy (argv->name, name);
2783 if (VAR_IS_STRING (argv))
2784 {
2785 RESULT_BUFFER = My->MaxLenBuffer;
2786 RESULT_LENGTH = 0;
2787 RESULT_BUFFER[RESULT_LENGTH] = NulChar;
2788 }
2789 else
2790 {
2791 RESULT_NUMBER = 0;
2792 }
2793 /* execute function */
2794 /* for all USER DEFINED FUNCTIONS: f->UniqueID == line number of DEF FN... */
2795 switch (L->line->cmdnum)
2796 {
2797 case C_DEF: /* execute a user function declared using DEF FN ...(...) = ... */
2798 case C_FUNCTION: /* execute a user function declared using FUNCTION ...(...) */
2799 case C_SUB: /* execute a user subroutine declared using SUB ...(...) */
2800 IntrinsicFunction_deffn (ParameterCount, argv, L);
2801 break;
2802 case C_DEF8LBL: /* IF ERL > label1 AND ERL < label2 THEN ... */
2803 if (ParameterCount > 0)
2804 {
2805 var_free (argv); /* free ARGV chain */
2806 WARN_ILLEGAL_FUNCTION_CALL;
2807 return RESULT_ERROR;
2808 }
2809 /* return the line number associated with the label */
2810 RESULT_NUMBER = L->line->number;
2811 break;
2812 default:
2813 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
2814 var_free (argv); /* free ARGV chain */
2815 WARN_INTERNAL_ERROR;
2816 return RESULT_ERROR;
2817 /* break; */
2818 }
2819 }
2820 else
2821 {
2822 /* INTRINSIC */
2823 IntrinsicFunctionType *f;
2824
2825 f =
2826 IntrinsicFunction_find_exact (name, ParameterCount,
2827 ParameterTypes);
2828 if (f == NULL)
2829 {
2830 /* NOT FOUND */
2831 f = IntrinsicFunction_find_exact (name, 255 /* (...) */ , 0);
2832 }
2833 if (f == NULL)
2834 {
2835 /* NOT FOUND */
2836 var_free (argv); /* free ARGV chain */
2837 WARN_ILLEGAL_FUNCTION_CALL;
2838 return RESULT_ERROR;
2839 }
2840 /* FOUND */
2841 /* defaullt the return value */
2842 var_make (argv, f->ReturnTypeCode);
2843 bwb_strcpy (argv->name, name);
2844 if (VAR_IS_STRING (argv))
2845 {
2846 RESULT_BUFFER = My->MaxLenBuffer;
2847 RESULT_LENGTH = 0;
2848 RESULT_BUFFER[RESULT_LENGTH] = NulChar;
2849 }
2850 else
2851 {
2852 RESULT_NUMBER = 0;
2853 }
2854 /* execute function */
2855 /* for all INTRINSIC FUNCTIONS: f->UniqueID == #define F_... */
2856 IntrinsicFunction_execute (ParameterCount, argv, f);
2857 }
2858 /* return results */
2859 X->VariantTypeCode = argv->VariableTypeCode;
2860 if (VAR_IS_STRING (argv))
2861 {
2862 if (RESULT_LENGTH > MAXLEN)
2863 {
2864 WARN_STRING_TOO_LONG; /* buff_read_function */
2865 RESULT_LENGTH = MAXLEN;
2866 }
2867 X->Length = RESULT_LENGTH;
2868 if ((X->Buffer =
2869 (char *) calloc (X->Length + 1 /* NulChar */ ,
2870 sizeof (char))) == NULL)
2871 {
2872 WARN_OUT_OF_MEMORY;
2873 return RESULT_ERROR;
2874 }
2875 bwb_memcpy (X->Buffer, RESULT_BUFFER, X->Length);
2876 X->Buffer[X->Length] = NulChar;
2877 RESULT_BUFFER = NULL;
2878 }
2879 else
2880 {
2881 X->Number = RESULT_NUMBER;
2882 }
2883 /* free ARGV chain */
2884 var_free (argv);
2885 /* OK */
2886 *position = p;
2887 return RESULT_SUCCESS;
2888 }
2889 /* ---------------------------------------------------------------------------- */
2890 }
2891 }
2892 /* NOT FOUND */
2893 return RESULT_UNPARSED;
2894 }
2895
2896 #if FALSE /* keep line_... */
2897 static int
line_read_function(LineType * line,VariantType * X)2898 line_read_function (LineType * line, VariantType * X)
2899 {
2900
2901 assert (line != NULL);
2902 assert (X != NULL);
2903 return buff_read_function (line->buffer, &(line->position), X);
2904 }
2905 #endif
2906
2907
2908 static ResultType
buff_read_variable(char * buffer,int * position,VariantType * X)2909 buff_read_variable (char *buffer, int *position, VariantType * X)
2910 {
2911 int p;
2912 char name[NameLengthMax + 1];
2913
2914 assert (buffer != NULL);
2915 assert (position != NULL);
2916 assert (X != NULL);
2917
2918
2919 p = *position;
2920 if (buff_read_varname (buffer, &p, name))
2921 {
2922 VariableType *v;
2923 int n_params;
2924 int pp[MAX_DIMS];
2925
2926 if (buff_peek_LparenChar (buffer, &p))
2927 {
2928 /* array */
2929 if (buff_peek_array_dimensions (buffer, &p, &n_params) == FALSE)
2930 {
2931 WARN_SYNTAX_ERROR;
2932 return RESULT_ERROR;
2933 }
2934 v = var_find (name, n_params, TRUE);
2935 }
2936 else
2937 {
2938 /* scalar */
2939 v = var_find (name, 0, TRUE);
2940 }
2941 if (v == NULL)
2942 {
2943 WARN_VARIABLE_NOT_DECLARED;
2944 return RESULT_ERROR;
2945 }
2946 if (v->dimensions > 0)
2947 {
2948 /* array */
2949 int n;
2950
2951 if (buff_read_array_dimensions (buffer, &p, &n_params, pp) == FALSE)
2952 {
2953 WARN_SUBSCRIPT_OUT_OF_RANGE;
2954 return RESULT_ERROR;
2955 }
2956 for (n = 0; n < v->dimensions; n++)
2957 {
2958 if (pp[n] < v->LBOUND[n] || pp[n] > v->UBOUND[n])
2959 {
2960 WARN_SUBSCRIPT_OUT_OF_RANGE;
2961 return RESULT_ERROR;
2962 }
2963 v->VINDEX[n] = pp[n];
2964 }
2965 }
2966 if (var_get (v, X) == FALSE)
2967 {
2968 WARN_TYPE_MISMATCH;
2969 return RESULT_ERROR;
2970 }
2971 *position = p;
2972 return RESULT_SUCCESS;
2973 }
2974 /* NOT FOUND */
2975 return RESULT_UNPARSED;
2976 }
2977
2978 #if FALSE /* keep line_... */
2979 static int
line_read_variable(LineType * line,VariantType * X)2980 line_read_variable (LineType * line, VariantType * X)
2981 {
2982
2983 assert (line != NULL);
2984 assert (X != NULL);
2985 return buff_read_variable (line->buffer, &(line->position), X);
2986 }
2987 #endif
2988 /*
2989 --------------------------------------------------------------------------------------------
2990 Precedence Climbing Expression Parser
2991 --------------------------------------------------------------------------------------------
2992 */
2993
2994 /*
2995 // Read an infix expression containing top-level operators that bind at least
2996 // as tightly as the given precedence.
2997 // Don't consume the first non-digit character after the last number.
2998 // Complain if you can't even find the first number,
2999 // or if there is an operator with no following number.
3000 */
3001 static ResultType
buff_read_expr(char * buffer,int * position,VariantType * X,unsigned char LastPrec)3002 buff_read_expr (char *buffer, int *position, VariantType * X,
3003 unsigned char LastPrec)
3004 {
3005 ResultType ResultCode;
3006 OperatorType *C;
3007 int p;
3008
3009 assert (buffer != NULL);
3010 assert (position != NULL);
3011 assert (X != NULL);
3012
3013
3014 p = *position;
3015 bwb_memset (X, 0, sizeof (VariantType)); /* NOTE */
3016
3017 ResultCode = buff_read_primary (buffer, &p, X);
3018 if (ResultCode != RESULT_SUCCESS)
3019 {
3020 return ResultCode;
3021 }
3022 if (X->VariantTypeCode == NulChar)
3023 {
3024 /* we do not know the primary's type */
3025 WARN_INTERNAL_ERROR;
3026 return RESULT_ERROR;
3027 }
3028 buff_skip_spaces (buffer, &p); /* keep this */
3029 while ((C = buff_read_operator (buffer, &p, LastPrec, BINARY)) != NULL)
3030 {
3031 VariantType Y;
3032
3033 ResultCode = buff_read_expr (buffer, &p, &Y, C->NextPrec);
3034 if (ResultCode != RESULT_SUCCESS)
3035 {
3036 /* ERROR */
3037 if (Y.Buffer != NULL)
3038 {
3039 free (Y.Buffer);
3040 Y.Buffer = NULL;
3041 }
3042 return ResultCode;
3043 }
3044 ResultCode = C->Eval (X, &Y);
3045 if (Y.Buffer != NULL)
3046 {
3047 free (Y.Buffer);
3048 Y.Buffer = NULL;
3049 }
3050 if (ResultCode != RESULT_SUCCESS)
3051 {
3052 /* ERROR */
3053 return ResultCode;
3054 }
3055 /* OK */
3056 }
3057 /*
3058 Normal termination, such as end-of-line, ',', or "THEN".
3059 */
3060 *position = p;
3061 return RESULT_SUCCESS;
3062 }
3063
3064 #if FALSE /* keep line_... */
3065 static ResultType
line_read_expr(LineType * line,VariantType * X,unsigned char LastPrec)3066 line_read_expr (LineType * line, VariantType * X, unsigned char LastPrec)
3067 {
3068
3069 assert (line != NULL);
3070 assert (X != NULL);
3071 return buff_read_expr (line->buffer, &(line->position), X, LastPrec);
3072 }
3073 #endif
3074 static ResultType
buff_read_primary(char * buffer,int * position,VariantType * X)3075 buff_read_primary (char *buffer, int *position, VariantType * X)
3076 {
3077 ResultType ResultCode;
3078 OperatorType *C;
3079 int p;
3080
3081 assert (buffer != NULL);
3082 assert (position != NULL);
3083 assert (X != NULL);
3084
3085
3086 p = *position;
3087 buff_skip_spaces (buffer, &p); /* keep this */
3088 if (buff_is_eol (buffer, &p))
3089 {
3090 /* we expected to find something, but there is nothing here */
3091 WARN_SYNTAX_ERROR;
3092 return RESULT_ERROR;
3093 }
3094 /* there is something to parse */
3095 if (buff_skip_LparenChar (buffer, &p))
3096 {
3097 /* nested expression */
3098 ResultCode = buff_read_expr (buffer, &p, X, 1);
3099 if (ResultCode != RESULT_SUCCESS)
3100 {
3101 return ResultCode;
3102 }
3103 if (buff_skip_RparenChar (buffer, &p) == FALSE)
3104 {
3105 WARN_SYNTAX_ERROR;
3106 return RESULT_ERROR;
3107 }
3108 *position = p;
3109 return RESULT_SUCCESS;
3110 }
3111 /* not a nested expression */
3112 C = buff_read_operator (buffer, &p, 1, UNARY);
3113 if (C != NULL)
3114 {
3115 ResultCode = buff_read_expr (buffer, &p, X, C->NextPrec);
3116 if (ResultCode != RESULT_SUCCESS)
3117 {
3118 return ResultCode;
3119 }
3120 ResultCode = C->Eval (X, NULL);
3121 if (ResultCode != RESULT_SUCCESS)
3122 {
3123 return ResultCode;
3124 }
3125 *position = p;
3126 return RESULT_SUCCESS;
3127 }
3128 /* not an operator */
3129 ResultCode = buff_read_string_constant (buffer, &p, X);
3130 if (ResultCode != RESULT_UNPARSED)
3131 {
3132 /* either OK or ERROR */
3133 if (ResultCode == RESULT_SUCCESS)
3134 {
3135 *position = p;
3136 }
3137 return ResultCode;
3138 }
3139 ResultCode = buff_read_hexadecimal_constant (buffer, &p, X, FALSE);
3140 if (ResultCode != RESULT_UNPARSED)
3141 {
3142 /* either OK or ERROR */
3143 if (ResultCode == RESULT_SUCCESS)
3144 {
3145 *position = p;
3146 }
3147 return ResultCode;
3148 }
3149 ResultCode = buff_read_octal_constant (buffer, &p, X, FALSE);
3150 if (ResultCode != RESULT_UNPARSED)
3151 {
3152 /* either OK or ERROR */
3153 if (ResultCode == RESULT_SUCCESS)
3154 {
3155 *position = p;
3156 }
3157 return ResultCode;
3158 }
3159 ResultCode = buff_read_internal_constant (buffer, &p, X);
3160 if (ResultCode != RESULT_UNPARSED)
3161 {
3162 /* either OK or ERROR */
3163 if (ResultCode == RESULT_SUCCESS)
3164 {
3165 *position = p;
3166 }
3167 return ResultCode;
3168 }
3169 ResultCode = buff_read_decimal_constant (buffer, &p, X, FALSE);
3170 if (ResultCode != RESULT_UNPARSED)
3171 {
3172 /* either OK or ERROR */
3173 if (ResultCode == RESULT_SUCCESS)
3174 {
3175 *position = p;
3176 }
3177 return ResultCode;
3178 }
3179 /* not a constant */
3180 ResultCode = buff_read_function (buffer, &p, X);
3181 if (ResultCode != RESULT_UNPARSED)
3182 {
3183 /* either OK or ERROR */
3184 if (ResultCode == RESULT_SUCCESS)
3185 {
3186 *position = p;
3187 }
3188 return ResultCode;
3189 }
3190 /* not a function */
3191 ResultCode = buff_read_variable (buffer, &p, X);
3192 /*
3193 the variable will be implicitly created unless:
3194 OPTION EXPLICIT ON, or
3195 the varname matches an existing command/function/operator.
3196 */
3197 if (ResultCode != RESULT_UNPARSED)
3198 {
3199 /* either OK or ERROR */
3200 if (ResultCode == RESULT_SUCCESS)
3201 {
3202 *position = p;
3203 }
3204 return ResultCode;
3205 }
3206 /* not a variable */
3207 WARN_SYNTAX_ERROR;
3208 return RESULT_ERROR;
3209 }
3210
3211 #if FALSE /* keep line_... */
3212 static ResultType
line_read_primary(LineType * line,VariantType * X)3213 line_read_primary (LineType * line, VariantType * X)
3214 {
3215
3216 assert (line != NULL);
3217 assert (X != NULL);
3218 return buff_read_primary (line->buffer, &(line->position), X);
3219 }
3220 #endif
3221
3222
3223 int
buff_read_expression(char * buffer,int * position,VariantType * X)3224 buff_read_expression (char *buffer, int *position, VariantType * X)
3225 {
3226 int p;
3227
3228 assert (buffer != NULL);
3229 assert (position != NULL);
3230 assert (X != NULL);
3231
3232 p = *position;
3233 if (buff_read_expr (buffer, &p, X, 1) == RESULT_SUCCESS)
3234 {
3235 switch (X->VariantTypeCode)
3236 {
3237 case ByteTypeCode:
3238 case IntegerTypeCode:
3239 case LongTypeCode:
3240 case CurrencyTypeCode:
3241 case SingleTypeCode:
3242 case DoubleTypeCode:
3243 case StringTypeCode:
3244 /* OK */
3245 break;
3246 default:
3247 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
3248 RELEASE_VARIANT (X);
3249 WARN_INTERNAL_ERROR;
3250 return FALSE;
3251 /* break; */
3252 }
3253 *position = p;
3254 return TRUE;
3255 }
3256 RELEASE_VARIANT (X); /* NEW */
3257 return FALSE;
3258 }
3259
3260
3261 int
line_read_expression(LineType * line,VariantType * X)3262 line_read_expression (LineType * line, VariantType * X)
3263 {
3264
3265 assert (line != NULL);
3266 assert (X != NULL);
3267 return buff_read_expression (line->buffer, &(line->position), X);
3268 }
3269
3270 /*
3271 --------------------------------------------------------------------------------------------
3272 BASIC commands
3273 --------------------------------------------------------------------------------------------
3274 */
3275
3276 #if FALSE /* keep line_... */
3277 LineType *
bwb_EVAL(LineType * line)3278 bwb_EVAL (LineType * line)
3279 {
3280 /*
3281 EVAL 1 + 2 + 3
3282 EVAL "ABC" & "DEF"
3283 */
3284 ResultType ResultCode;
3285 VariantType x;
3286 VariantType *X;
3287
3288 assert (line != NULL);
3289
3290
3291 VX = &x;
3292 ResultCode = line_read_expression (line, X);
3293 if (ResultCode != RESULT_SUCCESS)
3294 {
3295 return (line);
3296 }
3297
3298 switch (X->VariantTypeCode)
3299 {
3300 case ByteTypeCode:
3301 case IntegerTypeCode:
3302 case LongTypeCode:
3303 case CurrencyTypeCode:
3304 case SingleTypeCode:
3305 case DoubleTypeCode:
3306 printf (" NUMBER: %g, %c\n", X->Number, X->VariantTypeCode);
3307 ResetConsoleColumn ();
3308 break;
3309 case StringTypeCode:
3310 printf (" STRING: %s, %c\n", X->Buffer, X->VariantTypeCode);
3311 ResetConsoleColumn ();
3312 break;
3313 default:
3314 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
3315 WARN_INTERNAL_ERROR;
3316 break;
3317 }
3318 RELEASE_VARIANT (X);
3319 return (line);
3320 }
3321 #endif
3322
3323 LineType *
bwb_OPTION_DISABLE_OPERATOR(LineType * l)3324 bwb_OPTION_DISABLE_OPERATOR (LineType * l)
3325 {
3326 /* OPTION DISABLE OPERATOR name$ */
3327 int IsFound;
3328
3329 assert (l != NULL);
3330 assert(My != NULL);
3331 assert(My->CurrentVersion != NULL);
3332 assert(My->SYSOUT != NULL);
3333 assert(My->SYSOUT->cfp != NULL);
3334
3335 IsFound = FALSE;
3336 /* Get OPERATOR */
3337 {
3338 char *Value;
3339
3340 Value = NULL;
3341 if (line_read_string_expression (l, &Value) == FALSE)
3342 {
3343 WARN_SYNTAX_ERROR;
3344 return (l);
3345 }
3346 if (Value == NULL)
3347 {
3348 WARN_SYNTAX_ERROR;
3349 return (l);
3350 }
3351 {
3352 /* Name */
3353 int i;
3354 for (i = 0; i < NUM_OPERATORS; i++)
3355 {
3356 if (bwb_stricmp (Value, OperatorTable[i].Name) == 0)
3357 {
3358 /* FOUND */
3359 /* DISABLE OPERATOR */
3360 OperatorTable[i].OptionVersionBitmask &=
3361 ~My->CurrentVersion->OptionVersionValue;
3362 IsFound = TRUE;
3363 }
3364 }
3365 }
3366 free (Value);
3367 Value = NULL;
3368 }
3369 if (IsFound == FALSE)
3370 {
3371 /* display warning message */
3372 fprintf (My->SYSOUT->cfp, "IGNORED: %s\n", l->buffer);
3373 ResetConsoleColumn ();
3374 }
3375 return (l);
3376 }
3377
3378 LineType *
bwb_OPTION_ENABLE_OPERATOR(LineType * l)3379 bwb_OPTION_ENABLE_OPERATOR (LineType * l)
3380 {
3381 /* OPTION ENABLE OPERATOR name$ */
3382 int IsFound;
3383
3384 assert (l != NULL);
3385 assert(My != NULL);
3386 assert(My->CurrentVersion != NULL);
3387 assert(My->SYSOUT != NULL);
3388 assert(My->SYSOUT->cfp != NULL);
3389
3390
3391 IsFound = FALSE;
3392 /* Get OPERATOR */
3393 {
3394 char *Value;
3395
3396 Value = NULL;
3397 if (line_read_string_expression (l, &Value) == FALSE)
3398 {
3399 WARN_SYNTAX_ERROR;
3400 return (l);
3401 }
3402 if (Value == NULL)
3403 {
3404 WARN_SYNTAX_ERROR;
3405 return (l);
3406 }
3407 {
3408 /* Name */
3409 int i;
3410 for (i = 0; i < NUM_OPERATORS; i++)
3411 {
3412 if (bwb_stricmp (Value, OperatorTable[i].Name) == 0)
3413 {
3414 /* FOUND */
3415 /* ENABLE OPERATOR */
3416 OperatorTable[i].OptionVersionBitmask |=
3417 My->CurrentVersion->OptionVersionValue;
3418 IsFound = TRUE;
3419 }
3420 }
3421 }
3422 free (Value);
3423 Value = NULL;
3424 }
3425 if (IsFound == FALSE)
3426 {
3427 /* display warning message */
3428 fprintf (My->SYSOUT->cfp, "IGNORED: %s\n", l->buffer);
3429 ResetConsoleColumn ();
3430 }
3431 return (l);
3432 }
3433
3434 void
DumpOneOperatorSyntax(FILE * file,int IsXref,int n)3435 DumpOneOperatorSyntax (FILE * file, int IsXref, int n)
3436 {
3437
3438 assert (file != NULL);
3439
3440 if (n < 0 || n >= NUM_OPERATORS)
3441 {
3442 return;
3443 }
3444 /* NAME */
3445 {
3446 FixDescription (file, " SYNTAX: ", OperatorTable[n].Syntax);
3447 }
3448 /* DESCRIPTION */
3449 {
3450
3451 FixDescription (file, "DESCRIPTION: ", OperatorTable[n].Description);
3452 }
3453 /* PRECEDENCE */
3454 {
3455 fprintf (file, " PRECEDENCE: %d\n", OperatorTable[n].ThisPrec);
3456 }
3457 /* COMPATIBILITY */
3458 if (IsXref)
3459 {
3460 int i;
3461 fprintf (file, " VERSIONS:\n");
3462 for (i = 0; i < NUM_VERSIONS; i++)
3463 {
3464 char X;
3465 if (OperatorTable[n].OptionVersionBitmask & bwb_vertable[i].
3466 OptionVersionValue)
3467 {
3468 /* SUPPORTED */
3469 X = 'X';
3470 }
3471 else
3472 {
3473 /* NOT SUPPORTED */
3474 X = '_';
3475 }
3476 fprintf (file, " [%c] %s\n", X, bwb_vertable[i].Name);
3477 }
3478 }
3479
3480 fflush (file);
3481 }
3482
3483 void
DumpAllOperatorSyntax(FILE * file,int IsXref,OptionVersionType OptionVersionValue)3484 DumpAllOperatorSyntax (FILE * file, int IsXref,
3485 OptionVersionType OptionVersionValue)
3486 {
3487 /* for the C maintainer */
3488 int n;
3489
3490 assert (file != NULL);
3491
3492 fprintf (file,
3493 "============================================================\n");
3494 fprintf (file,
3495 " OPERATORS \n");
3496 fprintf (file,
3497 "============================================================\n");
3498 fprintf (file, "\n");
3499 fprintf (file, "\n");
3500 SortAllOperatorsForManual ();
3501 for (n = 0; n < NUM_OPERATORS; n++)
3502 {
3503 if (OperatorTable[n].OptionVersionBitmask & OptionVersionValue)
3504 {
3505 fprintf (file,
3506 "------------------------------------------------------------\n");
3507 DumpOneOperatorSyntax (file, IsXref, n);
3508 }
3509 }
3510 SortAllOperators ();
3511 fprintf (file,
3512 "------------------------------------------------------------\n");
3513
3514 fprintf (file, "\n");
3515 fprintf (file, "\n");
3516 fflush (file);
3517 }
3518
3519 /* EOF */
3520