ChipMaster's bwBASIC This also includes history going back to v2.10. *WARN* some binary files might have been corrupted by CRLF.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

3506 lines
87 KiB

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