diff options
Diffstat (limited to 'bwb_cnd.c')
-rw-r--r-- | bwb_cnd.c | 1937 |
1 files changed, 1937 insertions, 0 deletions
diff --git a/bwb_cnd.c b/bwb_cnd.c new file mode 100644 index 0000000..f4b8c9c --- /dev/null +++ b/bwb_cnd.c @@ -0,0 +1,1937 @@ +/*************************************************************** + + bwb_cnd.c Conditional Expressions and Commands + for Bywater BASIC Interpreter + + Copyright (c) 1993, Ted A. Campbell + Bywater Software + + email: tcamp@delphi.com + + Copyright and Permissions Information: + + All U.S. and international rights are claimed by the author, + Ted A. Campbell. + + This software is released under the terms of the GNU General + Public License (GPL), which is distributed with this software + in the file "COPYING". The GPL specifies the terms under + which users may copy and use the software in this distribution. + + A separate license is available for commercial distribution, + for information on which you should contact the author. + +***************************************************************/ + +/*---------------------------------------------------------------*/ +/* NOTE: Modifications marked "JBV" were made by Jon B. Volkoff, */ +/* 11/1995 (eidetics@cerf.net). */ +/* */ +/* Those additionally marked with "DD" were at the suggestion of */ +/* Dale DePriest (daled@cadence.com). */ +/* */ +/* Version 3.00 by Howard Wulf, AF5NE */ +/* */ +/* Version 3.10 by Howard Wulf, AF5NE */ +/* */ +/* Version 3.20 by Howard Wulf, AF5NE */ +/* */ +/*---------------------------------------------------------------*/ + + + +#include "bwbasic.h" + +static LineType *bwb_then_else (LineType * l, int Value); +static LineType *bwb_if_file (LineType * l, int ThenValue); +static int FindTopLineOnStack (LineType * l); +static int for_limit_check (DoubleType Value, DoubleType Target, + DoubleType Step); +static int IsTypeMismatch (char LeftTypeCode, char RightTypeCode); + + +/* +-------------------------------------------------------------------------------------------- + EXIT +-------------------------------------------------------------------------------------------- +*/ + +LineType * +bwb_EXIT (LineType * l) +{ + + assert (l != NULL); + WARN_SYNTAX_ERROR; + return (l); +} + +/* +-------------------------------------------------------------------------------------------- + SELECT +-------------------------------------------------------------------------------------------- +*/ +LineType * +bwb_SELECT (LineType * l) +{ + + assert (l != NULL); + WARN_SYNTAX_ERROR; + return (l); +} + + +/* +-------------------------------------------------------------------------------------------- + FUNCTION - END FUNCTION +-------------------------------------------------------------------------------------------- +*/ + +/*************************************************************** + + FUNCTION: bwb_FUNCTION() + + DESCRIPTION: This function implements the BASIC + FUNCTION command, introducing a named + function. + + SYNTAX: FUNCTION subroutine-name + ... + [ EXIT FUNCTION ] + ... + END FUNCTION + +***************************************************************/ + +LineType * +bwb_FUNCTION (LineType * l) +{ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + /* check current exec level */ + assert(My != NULL); + assert(My->StackHead != NULL); + if (My->StackHead->next == NULL) + { + /* skip over the entire function definition */ + l = l->OtherLine; /* line of END SUB */ + l = l->next; /* line after END SUB */ + l->position = 0; + return l; + } + + /* we are being executed via IntrinsicFunction_deffn() */ + + /* if this is the first time at this SUB statement, note it */ + if (My->StackHead->LoopTopLine != l) + { + if (bwb_incexec ()) + { + /* OK */ + My->StackHead->LoopTopLine = l; + } + else + { + /* ERROR */ + WARN_OUT_OF_MEMORY; + return My->EndMarker; + } + } + line_skip_eol (l); + return (l); +} + + +LineType * +bwb_EXIT_FUNCTION (LineType * l) +{ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + /* check integrity of SUB commmand */ + if (FindTopLineOnStack (l->OtherLine)) + { + /* FOUND */ + LineType *r; + bwb_decexec (); + r = l->OtherLine; /* line of FUNCTION */ + r = r->OtherLine; /* line of END FUNCTION */ + r = r->next; /* line after END FUNCTION */ + r->position = 0; + return r; + } + /* NOT FOUND */ + WARN_EXIT_FUNCTION_WITHOUT_FUNCTION; + return (l); +} + +LineType * +bwb_END_FUNCTION (LineType * l) +{ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + /* check integrity of SUB commmand */ + if (FindTopLineOnStack (l->OtherLine) == FALSE) + { + /* NOT FOUND */ + WARN_END_FUNCTION_WITHOUT_FUNCTION; + return (l); + } + /* decrement the stack */ + bwb_decexec (); + + /* and return next from old line */ + assert(My != NULL); + assert(My->StackHead != NULL); + My->StackHead->line->next->position = 0; + return My->StackHead->line->next; +} + +LineType * +bwb_FNEND (LineType * l) +{ + + assert (l != NULL); + return bwb_END_FUNCTION (l); +} + +LineType * +bwb_FEND (LineType * l) +{ + + assert (l != NULL); + return bwb_END_FUNCTION (l); +} + + +/* +-------------------------------------------------------------------------------------------- + SUB - END SUB +-------------------------------------------------------------------------------------------- +*/ + +/*************************************************************** + + FUNCTION: bwb_sub() + + DESCRIPTION: This function implements the BASIC + SUB command, introducing a named + subroutine. + + SYNTAX: SUB subroutine-name + ... + [ EXIT SUB ] + ... + END SUB + +***************************************************************/ + +LineType * +bwb_SUB (LineType * l) +{ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + /* check current exec level */ + assert(My != NULL); + assert(My->StackHead != NULL); + if (My->StackHead->next == NULL) + { + /* skip over the entire function definition */ + l = l->OtherLine; /* line of END SUB */ + l = l->next; /* line after END SUB */ + l->position = 0; + return l; + } + /* we are being executed via IntrinsicFunction_deffn() */ + + /* if this is the first time at this SUB statement, note it */ + if (My->StackHead->LoopTopLine != l) + { + if (bwb_incexec ()) + { + /* OK */ + My->StackHead->LoopTopLine = l; + } + else + { + /* ERROR */ + WARN_OUT_OF_MEMORY; + return My->EndMarker; + } + } + line_skip_eol (l); + return (l); +} + +LineType * +bwb_EXIT_SUB (LineType * l) +{ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + /* check integrity of SUB commmand */ + if (FindTopLineOnStack (l->OtherLine)) + { + /* FOUND */ + LineType *r; + bwb_decexec (); + r = l->OtherLine; /* line of FUNCTION */ + r = r->OtherLine; /* line of END FUNCTION */ + r = r->next; /* line after END FUNCTION */ + r->position = 0; + return r; + } + /* NOT FOUND */ + WARN_EXIT_SUB_WITHOUT_SUB; + return (l); +} + +LineType * +bwb_SUBEXIT (LineType * l) +{ + + assert (l != NULL); + return bwb_EXIT_SUB (l); +} + +LineType * +bwb_SUB_EXIT (LineType * l) +{ + + assert (l != NULL); + return bwb_EXIT_SUB (l); +} + +LineType * +bwb_END_SUB (LineType * l) +{ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + /* check integrity of SUB commmand */ + if (FindTopLineOnStack (l->OtherLine) == FALSE) + { + /* NOT FOUND */ + WARN_END_SUB_WITHOUT_SUB; + return (l); + } + /* decrement the stack */ + bwb_decexec (); + + /* and return next from old line */ + assert(My != NULL); + assert(My->StackHead != NULL); + My->StackHead->line->next->position = 0; + return My->StackHead->line->next; +} + +LineType * +bwb_SUBEND (LineType * l) +{ + + assert (l != NULL); + return bwb_END_SUB (l); +} + +LineType * +bwb_SUB_END (LineType * l) +{ + + assert (l != NULL); + return bwb_END_SUB (l); +} + + +/* +-------------------------------------------------------------------------------------------- + IF - END IF +-------------------------------------------------------------------------------------------- +*/ + + +/*************************************************************** + + FUNCTION: bwb_IF() + + DESCRIPTION: This function handles the BASIC IF + statement, standard flavor. + standard + SYNTAX: IF expression THEN line [ELSE line] + IF END # file THEN line [ELSE line] + IF MORE # file THEN line [ELSE line] + +***************************************************************/ +LineType * +bwb_IF (LineType * l) +{ + /* classic IF */ + /* IF expression THEN 100 */ + /* IF expression THEN 100 ELSE 200 */ + int Value; + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + if (line_read_integer_expression (l, &Value) == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + return bwb_then_else (l, Value); +} + +LineType * +bwb_IF_END (LineType * l) +{ + /* IF END #1 THEN 100 */ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + assert(My != NULL); + assert(My->CurrentVersion != NULL); + if (My->CurrentVersion->OptionVersionValue & (C77)) + { + /* sets a linenumber to branch to on EOF */ + int FileNumber = 0; + int LineNumber = 0; + + + if (line_read_integer_expression (l, &FileNumber) == FALSE) + { + WARN_BAD_FILE_NUMBER; + return (l); + } + if (FileNumber <= 0) + { + WARN_BAD_FILE_NUMBER; + return (l); + } + if (line_skip_word (l, "THEN") == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + if (line_read_integer_expression (l, &LineNumber) == FALSE) + { + WARN_UNDEFINED_LINE; + return (l); + } + if (LineNumber < 0) + { + WARN_UNDEFINED_LINE; + return (l); + } + /* now, we are ready to create the file */ + My->CurrentFile = find_file_by_number (FileNumber); + if (My->CurrentFile == NULL) + { + My->CurrentFile = file_new (); + My->CurrentFile->FileNumber = FileNumber; + } + My->CurrentFile->EOF_LineNumber = LineNumber; + return (l); + } + /* branch to the line if we are currently at EOF */ + return bwb_if_file (l, TRUE); +} + +LineType * +bwb_IF_MORE (LineType * l) +{ + /* IF MORE #1 THEN 100 */ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + /* branch to the line if we are not currently at EOF */ + return bwb_if_file (l, FALSE); +} + + + + + +/*************************************************************** + + FUNCTION: bwb_IF8THEN() + + DESCRIPTION: This function handles the BASIC IF + statement, structured flavor. + + SYNTAX: IF expression THEN + ... + ELSEIF expression + ... + ELSE + ... + END IF + +***************************************************************/ +LineType * +bwb_IF8THEN (LineType * l) +{ + /* structured IF */ + LineType *else_line; + int Value; + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + /* evaluate the expression */ + if (line_read_integer_expression (l, &Value) == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + if (Value) + { + /* expression is TRUE */ + l->next->position = 0; + return l->next; + } + + /* + RESUME knows we iterate thru the various ELSEIF commands, and restarts at the IF THEN command. + RESUME NEXT knows we iterate thru the various ELSEIF commands, and restarts at the END IF command. + */ + + for (else_line = l->OtherLine; else_line->cmdnum == C_ELSEIF; + else_line = else_line->OtherLine) + { + else_line->position = else_line->Startpos; + + /* evaluate the expression */ + if (line_read_integer_expression (else_line, &Value) == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + if (Value) + { + /* expression is TRUE */ + else_line->next->position = 0; + return else_line->next; + } + } + /* ELSE or END IF */ + else_line->next->position = 0; + return else_line->next; +} + +LineType * +bwb_ELSEIF (LineType * l) +{ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + for (l = l->OtherLine; l->OtherLine != NULL; l = l->OtherLine); + l = l->next; /* line after END IF */ + l->position = 0; + return l; +} + +LineType * +bwb_ELSE (LineType * l) +{ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + for (l = l->OtherLine; l->OtherLine != NULL; l = l->OtherLine); + l = l->next; /* line after END IF */ + l->position = 0; + return l; +} + +LineType * +bwb_END_IF (LineType * l) +{ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + return (l); +} + +/* +-------------------------------------------------------------------------------------------- + SELECT CASE - END SELECT +-------------------------------------------------------------------------------------------- +*/ + + +/*************************************************************** + + FUNCTION: bwb_select() + + DESCRIPTION: This C function handles the BASIC SELECT + statement. + + SYNTAX: SELECT CASE expression ' examples: + CASE value ' CASE 5 + CASE min TO max ' CASE 1 TO 10 + CASE IF relationaloperator value ' CASE IF > 5 + CASE IS relationaloperator value ' CASE IS > 5 + CASE ELSE + END SELECT + +***************************************************************/ + + + +LineType * +bwb_SELECT_CASE (LineType * l) +{ + VariantType selectvalue; + VariantType *e; + LineType *else_line; + + assert (l != NULL); + + e = &selectvalue; + CLEAR_VARIANT (e); + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + /* evaluate the expression */ + if (line_read_expression (l, e) == FALSE) /* bwb_SELECT_CASE */ + { + WARN_SYNTAX_ERROR; + return (l); + } + /* + ** + ** RESUME knows we iterate thru the various CASE commands, and restarts at the SELECT CASE command. + ** RESUME NEXT knows we iterate thru the various CASE commands, and restarts at the END SELECT command. + ** + */ + for (else_line = l->OtherLine; else_line->cmdnum == C_CASE; + else_line = else_line->OtherLine) + { + else_line->position = else_line->Startpos; + do + { + /* evaluate the expression */ + if (line_skip_word (else_line, "IF") + || line_skip_word (else_line, "IS")) + { + /* CASE IS < 10 */ + /* CASE IF < "DEF" */ + /* CASE IS > 7 */ + /* CASE IS > "ABC" */ + char *tbuf; + int tlen; + size_t n; /* number of characters we want to put in tbuf */ + int position; + VariantType casevalue; + VariantType *r; + + assert(My != NULL); + assert(My->ConsoleOutput != NULL); + assert(MAX_LINE_LENGTH > 1); + tbuf = My->ConsoleOutput; + tlen = MAX_LINE_LENGTH; + n = 0; + r = &casevalue; + CLEAR_VARIANT (r); + + /* + ** + ** Available choices: + ** 1. Parse every possible operator combination, depending upon the BASIC flavor. + ** 2. Jump into the middle of the expression parser, by exposing the parser internals. + ** 3. Limit the length of the expression. This is the choice I made. + ** + */ + + if (e->VariantTypeCode == StringTypeCode) + { + /* STRING */ + n += bwb_strlen (e->Buffer); + if (n > tlen) + { + WARN_STRING_FORMULA_TOO_COMPLEX; /* bwb_SELECT_CASE */ + return (l); + } + /* OK , everything will fit */ + bwb_strcpy (tbuf, e->Buffer); + } + else + { + /* NUMBER */ + FormatBasicNumber (e->Number, tbuf); + n += bwb_strlen (tbuf); + if (n > tlen) + { + WARN_STRING_FORMULA_TOO_COMPLEX; /* bwb_SELECT_CASE */ + return (l); + } + /* OK , everything will fit */ + } + { + char *Space; + + Space = " "; + n += bwb_strlen (Space); + if (n > tlen) + { + WARN_STRING_FORMULA_TOO_COMPLEX; /* bwb_SELECT_CASE */ + return (l); + } + /* OK , everything will fit */ + bwb_strcat (tbuf, Space); + } + { + n += bwb_strlen (&(else_line->buffer[else_line->position])); + + if (n > tlen) + { + WARN_STRING_FORMULA_TOO_COMPLEX; /* bwb_SELECT_CASE */ + return (l); + } + /* OK , everything will fit */ + bwb_strcat (tbuf, &(else_line->buffer[else_line->position])); + } + position = 0; + if (buff_read_expression (tbuf, &position, r) == FALSE) /* bwb_SELECT_CASE */ + { + WARN_SYNTAX_ERROR; + return (l); + } + if (r->VariantTypeCode == StringTypeCode) + { + RELEASE_VARIANT (r); + WARN_TYPE_MISMATCH; + return (l); + } + if (r->Number) + { + /* expression is TRUE */ + else_line->next->position = 0; + return else_line->next; + } + /* condition is FALSE */ + /* proceed to next CASE line if there is one */ + } + else + { + /* CASE 7 */ + /* CASE 7 TO 10 */ + /* CASE "ABC" */ + /* CASE "ABC" TO "DEF" */ + VariantType minvalue; + VariantType *minval; + + minval = &minvalue; + CLEAR_VARIANT (minval); + /* evaluate the MIN expression */ + if (line_read_expression (else_line, minval) == FALSE) /* bwb_SELECT_CASE */ + { + WARN_SYNTAX_ERROR; + return (l); + } + if (IsTypeMismatch (e->VariantTypeCode, minval->VariantTypeCode)) + { + RELEASE_VARIANT (minval); + WARN_TYPE_MISMATCH; + return (l); + } + if (line_skip_word (else_line, "TO")) + { + /* CASE 7 TO 10 */ + /* CASE "ABC" TO "DEF" */ + VariantType maxvalue; + VariantType *maxval; + + maxval = &maxvalue; + CLEAR_VARIANT (maxval); + + /* evaluate the MAX expression */ + if (line_read_expression (else_line, maxval) == FALSE) /* bwb_SELECT_CASE */ + { + WARN_SYNTAX_ERROR; + return (l); + } + if (IsTypeMismatch (e->VariantTypeCode, maxval->VariantTypeCode)) + { + RELEASE_VARIANT (maxval); + WARN_TYPE_MISMATCH; + return (l); + } + if (e->VariantTypeCode == StringTypeCode) + { + /* STRING */ + if (bwb_strcmp (e->Buffer, minval->Buffer) >= 0 + && bwb_strcmp (e->Buffer, maxval->Buffer) <= 0) + { + /* expression is TRUE */ + RELEASE_VARIANT (maxval); + else_line->next->position = 0; + return else_line->next; + } + RELEASE_VARIANT (maxval); + } + else + { + /* NUMBER */ + if (e->Number >= minval->Number && e->Number <= maxval->Number) + { + /* expression is TRUE */ + else_line->next->position = 0; + return else_line->next; + } + } + } + else + { + /* CASE 7 */ + /* CASE "ABC" */ + if (e->VariantTypeCode == StringTypeCode) + { + /* STRING */ + if (bwb_strcmp (e->Buffer, minval->Buffer) == 0) + { + /* expression is TRUE */ + RELEASE_VARIANT (minval); + else_line->next->position = 0; + return else_line->next; + } + RELEASE_VARIANT (minval); + } + else + { + /* NUMBER */ + if (e->Number == minval->Number) + { + /* expression is TRUE */ + else_line->next->position = 0; + return else_line->next; + } + } + } + /* condition is FALSE */ + /* proceed to next CASE line if there is one */ + } + } + while (line_skip_seperator (else_line)); + } + /* CASE_ELSE or END_SELECT */ + RELEASE_VARIANT (e); + else_line->next->position = 0; + return else_line->next; +} + +LineType * +bwb_CASE (LineType * l) +{ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + for (l = l->OtherLine; l->OtherLine != NULL; l = l->OtherLine); + l = l->next; /* line after END SELECT */ + l->position = 0; + return l; +} + +LineType * +bwb_CASE_ELSE (LineType * l) +{ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + for (l = l->OtherLine; l->OtherLine != NULL; l = l->OtherLine); + l = l->next; /* line after END SELECT */ + l->position = 0; + return l; +} + + +LineType * +bwb_END_SELECT (LineType * l) +{ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + return (l); +} + +/* +-------------------------------------------------------------------------------------------- + DO - LOOP +-------------------------------------------------------------------------------------------- +*/ + +/*************************************************************** + + FUNCTION: bwb_DO() + + DESCRIPTION: This C function implements the ANSI BASIC + DO statement. + + SYNTAX: DO [UNTIL|WHILE condition] + ... + [EXIT DO] + ... + LOOP [UNTIL|WHILE condition] + +***************************************************************/ + +LineType * +bwb_DO (LineType * l) +{ + LineType *r; + int Value; + + assert (l != NULL); + + /* DO ' forever */ + /* DO UNTIL ' exits when != 0 */ + /* DO WHILE ' exits when == 0 */ + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + do + { + /* evaluate the expression */ + if (line_is_eol (l)) + { + break; /* exit 'do' */ + } + else if (line_skip_word (l, "UNTIL")) + { + /* DO UNTIL */ + if (line_read_integer_expression (l, &Value) == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + + if (Value != 0) + { + /* EXIT DO */ + r = l->OtherLine; /* line of LOOP */ + r = r->next; /* line after LOOP */ + r->position = 0; + return r; + } + } + else if (line_skip_word (l, "WHILE")) + { + /* DO WHILE */ + if (line_read_integer_expression (l, &Value) == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + + if (Value == 0) + { + /* EXIT DO */ + r = l->OtherLine; /* line of LOOP */ + r = r->next; /* line after LOOP */ + r->position = 0; + return r; + } + } + + } + while (line_skip_seperator (l)); + + return (l); +} + + +LineType * +bwb_EXIT_DO (LineType * l) +{ + LineType *r; + + assert (l != NULL); + + /* EXIT DO */ + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + r = l->OtherLine; /* line of DO */ + r = r->OtherLine; /* line of LOOP */ + r = r->next; /* line after LOOP */ + r->position = 0; + return r; +} + + +LineType * +bwb_LOOP (LineType * l) +{ + LineType *r; + int Value; + + assert (l != NULL); + + /* LOOP ' forever */ + /* LOOP UNTIL ' exits when != 0 */ + /* LOOP WHILE ' exits when == 0 */ + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + do + { + /* evaluate the expression */ + if (line_is_eol (l)) + { + break; /* exit 'do' */ + } + else if (line_skip_word (l, "UNTIL")) + { + /* LOOP UNTIL */ + if (line_read_integer_expression (l, &Value) == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + + if (Value != 0) + { + /* EXIT DO */ + return (l); + } + } + else if (line_skip_word (l, "WHILE")) + { + /* LOOP WHILE */ + if (line_read_integer_expression (l, &Value) == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + + if (Value == 0) + { + /* EXIT DO */ + return (l); + } + } + + } + while (line_skip_seperator (l)); + + /* loop around to DO again */ + r = l->OtherLine; /* line of DO */ + r->position = 0; + return r; +} + + + +/* +-------------------------------------------------------------------------------------------- + WHILE - WEND +-------------------------------------------------------------------------------------------- +*/ + + + + +/*************************************************************** + + FUNCTION: bwb_WHILE() + + DESCRIPTION: This function handles the BASIC + WHILE statement. + + SYNTAX: WHILE expression ' exits when == 0 + ... + [EXIT WHILE] + ... + WEND + + +***************************************************************/ +LineType * +bwb_WHILE (LineType * l) +{ + int Value; + + LineType *r; + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + if (line_read_integer_expression (l, &Value) == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + if (Value == 0) + { + /* EXIT WHILE */ + r = l->OtherLine; /* line of WEND */ + r = r->next; /* line after WEND */ + r->position = 0; + return r; + } + return (l); +} + + +LineType * +bwb_EXIT_WHILE (LineType * l) +{ + LineType *r; + + assert (l != NULL); + + /* EXIT WHILE */ + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + r = l->OtherLine; /* line of WHILE */ + r = r->OtherLine; /* line of WEND */ + r = r->next; /* line after WEND */ + r->position = 0; + return r; +} + +LineType * +bwb_WEND (LineType * l) +{ + LineType *r; + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + r = l->OtherLine; /* line of WHILE */ + r->position = 0; + return r; +} + + +/* +-------------------------------------------------------------------------------------------- + REPEAT - UNTIL +-------------------------------------------------------------------------------------------- +*/ + + + + + + + +/*************************************************************** + + FUNCTION: bwb_UNTIL() + + DESCRIPTION: This function handles the BASIC + UNTIL statement. + + SYNTAX: UNTIL expression ' exits when != 0 + ... + [EXIT UNTIL] + ... + UEND + + +***************************************************************/ +LineType * +bwb_REPEAT (LineType * l) +{ + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + return (l); +} + + +LineType * +bwb_EXIT_REPEAT (LineType * l) +{ + LineType *r; + + assert (l != NULL); + + /* EXIT REPEAT */ + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + r = l->OtherLine; /* line of REPEAT */ + r = r->OtherLine; /* line of UNTIL */ + r = r->next; /* line after UNTIL */ + r->position = 0; + return r; +} + + +LineType * +bwb_UNTIL (LineType * l) +{ + int Value; + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + if (line_read_integer_expression (l, &Value) == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + + if (Value == 0) + { + /* GOTO REPEAT */ + LineType *r; + + r = l->OtherLine; /* line of REPEAT */ + r->position = 0; + return r; + } + /* EXITS when Value != 0 */ + return (l); + +} + + +/* +-------------------------------------------------------------------------------------------- + FOR - NEXT +-------------------------------------------------------------------------------------------- +*/ + + + +/*************************************************************** + + FUNCTION: bwb_for() + + DESCRIPTION: This function handles the BASIC FOR + statement. + + SYNTAX: FOR counter = start TO finish [STEP increment] + ... + [EXIT FOR] + ... + NEXT [counter] + +NOTE: This is controlled by the OptionVersion bitmask. + + The order of expression evaluation and variable creation varies. + For example: + FUNCTION FNA( Y ) + PRINT "Y="; Y + FNA = Y + END FUNCTION + FOR X = FNA(3) TO FNA(1) STEP FNA(2) + NEXT X + ANSI/ECMA; + Y= 1 + Y= 2 + Y= 3 + X is created (if it does not exist) + X is assigned the value of 3 + MICROSOFT; + X is created (if it does not exist) + Y= 3 + X is assigned the value of 3 + Y= 1 + Y= 2 + + +ECMA-55: Section 13.4 + ... + The action of the for-statement and the next-statement is de- + fined in terms of other statements, as follows: + + FOR v = initial-value TO limit STEP increment + (block) + NEXT v + + is equivalent to: + + LET own1 = limit + LET own2 = increment + LET v = initial-value + line1 IF (v-own1) * SGN (own2) > 0 THEN line2 + (block) + LET v = v + own2 + GOTO line1 + line2 REM continued in sequence + ... + +***************************************************************/ + + +LineType * +bwb_FOR (LineType * l) +{ + LineType *r; + VariableType *v; + DoubleType Value; + DoubleType Target; + DoubleType Step; + VariantType variant; + CLEAR_VARIANT (&variant); + + assert (l != NULL); + assert(My != NULL); + assert(My->CurrentVersion != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + /* if this is the first time at this FOR statement, note it */ + if (FindTopLineOnStack (l) == FALSE) + { + if (bwb_incexec ()) + { + /* OK */ + } + else + { + /* ERROR */ + WARN_OUT_OF_MEMORY; + return My->EndMarker; + } + } + + /* INITIALIZE */ + + + if ((v = line_read_scalar (l)) == NULL) + { + WARN_VARIABLE_NOT_DECLARED; + return (l); + } + if (v->dimensions > 0) + { + WARN_TYPE_MISMATCH; + return (l); + } + if (v->VariableTypeCode == StringTypeCode) + { + WARN_TYPE_MISMATCH; + return (l); + } + if (line_skip_EqualChar (l) == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + if (line_read_numeric_expression (l, &Value) == FALSE) + { + WARN_ILLEGAL_FUNCTION_CALL; + return (l); + } + if (My->CurrentVersion->OptionFlags & OPTION_BUGS_ON /* FOR X = ... */ ) + { + /* Assign Variable */ + variant.VariantTypeCode = v->VariableTypeCode; + variant.Number = Value; + if (var_set (v, &variant) == FALSE) + { + WARN_VARIABLE_NOT_DECLARED; + return (l); + } + } + else + { + /* assigned below */ + } + if (line_skip_word (l, "TO") == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + if (line_read_numeric_expression (l, &Target) == FALSE) + { + WARN_ILLEGAL_FUNCTION_CALL; + return (l); + } + if (line_skip_word (l, "STEP")) + { + if (line_read_numeric_expression (l, &Step) == FALSE) + { + WARN_ILLEGAL_FUNCTION_CALL; + return (l); + } + } + else + { + Step = 1; + } + if (My->CurrentVersion->OptionFlags & OPTION_BUGS_ON /* FOR X = ... */ ) + { + /* assigned above */ + } + else + { + /* Assign Variable */ + variant.VariantTypeCode = v->VariableTypeCode; + variant.Number = Value; + if (var_set (v, &variant) == FALSE) + { + WARN_VARIABLE_NOT_DECLARED; + return (l); + } + } + + /* CHECK */ + if (for_limit_check (Value, Target, Step)) + { + /* EXIT FOR */ + bwb_decexec (); + + r = l->OtherLine; /* line of NEXT */ + r = r->next; /* line after NEXT */ + r->position = 0; + return r; + } + + /* we will loop at least once */ + assert(My->StackHead != NULL); + My->StackHead->line = l; + My->StackHead->ExecCode = EXEC_FOR; + My->StackHead->local_variable = v; + My->StackHead->for_step = Step; + My->StackHead->for_target = Target; + My->StackHead->LoopTopLine = l; + My->StackHead->OnErrorGoto = 0; + /* proceed with processing */ + return (l); +} + + +LineType * +bwb_EXIT_FOR (LineType * l) +{ + LineType *r; + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + if (FindTopLineOnStack (l->OtherLine) == FALSE) + { + WARN_EXIT_FOR_WITHOUT_FOR; + return (l); + } + assert(My != NULL); + assert(My->StackHead != NULL); + My->StackHead->ExecCode = EXEC_FOR; + bwb_decexec (); + + r = l->OtherLine; /* line of FOR */ + r = r->OtherLine; /* line of NEXT */ + r = r->next; /* line after NEXT */ + r->position = 0; + return r; +} + + +LineType * +bwb_NEXT (LineType * l) +{ + LineType *r; + VariableType *v; + DoubleType Value; + DoubleType Target; + DoubleType Step; + + assert (l != NULL); + + if (l->LineFlags & (LINE_USER)) + { + WARN_ILLEGAL_DIRECT; + return (l); + } + + if (FindTopLineOnStack (l->OtherLine) == FALSE) + { + WARN_NEXT_WITHOUT_FOR; + return (l); + } + assert(My != NULL); + assert(My->StackHead != NULL); + My->StackHead->ExecCode = EXEC_FOR; + + /* INCREMENT */ + v = My->StackHead->local_variable; + Target = My->StackHead->for_target; + Step = My->StackHead->for_step; + + /* if( TRUE ) */ + { + VariantType variant; + CLEAR_VARIANT (&variant); + if (var_get (v, &variant) == FALSE) + { + WARN_NEXT_WITHOUT_FOR; + return (l); + } + if (variant.VariantTypeCode == StringTypeCode) + { + WARN_NEXT_WITHOUT_FOR; + return (l); + } + variant.Number += Step; + Value = variant.Number; + if (var_set (v, &variant) == FALSE) + { + WARN_NEXT_WITHOUT_FOR; + return (l); + } + } + + /* CHECK */ + if (for_limit_check (Value, Target, Step)) + { + /* EXIT FOR */ + bwb_decexec (); + return (l); + } + /* proceed with processing */ + r = l->OtherLine; /* line of FOR */ +#if FALSE /* keep this ... */ + /* + This example causes a Syntax Error: + 100 FOR I = 1 TO 1000:NEXT + The error is actually caused by execline(). + Note that the example is a delay loop. + Only NEXT has this issue, because it jumps to TOP->next. + All other loop structures jump to either TOP or BOTTOM->next. + */ + r = r->next; /* line after FOR */ + r->position = 0; +#endif + line_skip_eol (r); + return r; +} + + +/* +-------------------------------------------------------------------------------------------- + STATIC UTILITY ROUTINES +-------------------------------------------------------------------------------------------- +*/ + + +static int +FindTopLineOnStack (LineType * l) +{ + /* since we are at the top of a loop, we MIGHT be on the stack */ + StackType *StackItem; + + assert (l != NULL); + assert(My != NULL); + + for (StackItem = My->StackHead; StackItem != NULL; + StackItem = StackItem->next) + { + LineType *current; + + current = StackItem->LoopTopLine; + if (current != NULL) + { + if (current == l) + { + /* FOUND */ + while (My->StackHead != StackItem) + { + bwb_decexec (); + } + /* we are now the top item on the stack */ + return TRUE; + } + /* do NOT cross a function/sub boundary */ + switch (current->cmdnum) + { + case C_FUNCTION: + case C_SUB: + case C_GOSUB: + /* NOT FOUND */ + return FALSE; + /* break; */ + } + } + } + /* NOT FOUND */ + return FALSE; +} + +static LineType * +bwb_if_file (LineType * l, int ThenValue) +{ + /* IF END # filenumber THEN linenumber */ + /* IF MORE # filenumber THEN linenumber */ + int Value; + int FileNumber; + + assert (l != NULL); + + + if (line_skip_FilenumChar (l)) + { + /* IF END # */ + FileType *F; + + if (line_read_integer_expression (l, &FileNumber) == FALSE) + { + WARN_BAD_FILE_NUMBER; + return (l); + } + if (FileNumber < 0) + { + /* Printer is NOT EOF */ + Value = FALSE; + } + else if (FileNumber == 0) + { + /* Console is NOT EOF */ + Value = FALSE; + } + else + { + /* normal file */ + F = find_file_by_number (FileNumber); + if (F == NULL) + { + WARN_BAD_FILE_NUMBER; + return (l); + } + /* if( TRUE ) */ + { + /* actual file -- are we at the end? */ + FILE *fp; + long current; + long total; + fp = F->cfp; + assert( fp != NULL ); + current = ftell (fp); + fseek (fp, 0, SEEK_END); + total = ftell (fp); + if (total == current) + { + /* EOF */ + Value = TRUE; + } + else + { + /* NOT EOF */ + Value = FALSE; + fseek (fp, current, SEEK_SET); + } + } + } + } + else + { + WARN_SYNTAX_ERROR; + return (l); + } + + if (Value == ThenValue) + { + /* expression is TRUE, take THEN path */ + return bwb_then_else (l, TRUE); + } + /* expression is FALSE, take ELSE path */ + return bwb_then_else (l, FALSE); +} + +static LineType * +bwb_then_else (LineType * l, int Value) +{ + /* + ... THEN 100 + ... THEN 100 ELSE 200 + + The deciding expression has already been parsed and evaluated. + If Value != 0, then we want to take the THEN path. + If Value == 0, then we want to take the ELSE path. + */ + int LineNumber; + LineType *x; + + assert (l != NULL); + + if (line_skip_seperator (l)) + { + /* OK */ + } + else + { + /* OPTIONAL */ + } + + if (line_skip_word (l, "THEN")) + { + /* OK */ + } + else if (line_skip_word (l, "GOTO")) + { + /* OK */ + } + else + { + /* REQUIRED */ + WARN_SYNTAX_ERROR; + return (l); + } + + /* read THEN's LineNumber */ + if (line_read_integer_expression (l, &LineNumber) == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + + if (Value == 0) + { + /* expression is FALSE, take ELSE path */ + if (line_is_eol (l)) + { + /* OPTIONAL */ + return (l); + } + + if (line_skip_seperator (l)) + { + /* OK */ + } + else + { + /* OPTIONAL */ + } + + if (line_skip_word (l, "ELSE")) + { + /* OK */ + } + else + { + /* REQUIRED */ + WARN_SYNTAX_ERROR; + return (l); + } + + if (line_read_integer_expression (l, &LineNumber) == FALSE) + { + WARN_SYNTAX_ERROR; + return (l); + } + } + + x = NULL; +#if THE_PRICE_IS_RIGHT + if (l->OtherLine != NULL) + { + /* look in the cache */ + if (l->OtherLine->number == LineNumber) + { + x = l->OtherLine; /* found in cache */ + } + } +#endif /* THE_PRICE_IS_RIGHT */ + if (x == NULL) + { + x = find_line_number (LineNumber); /* bwb_then_else */ + } + if (x != NULL) + { + line_skip_eol (l); + x->position = 0; +#if THE_PRICE_IS_RIGHT + l->OtherLine = x; /* save in cache */ +#endif /* THE_PRICE_IS_RIGHT */ + return x; + } + WARN_SYNTAX_ERROR; + return (l); + +} + +static int +IsTypeMismatch (char LeftTypeCode, char RightTypeCode) +{ + + if (LeftTypeCode == StringTypeCode && RightTypeCode == StringTypeCode) + { + /* both STRING */ + return FALSE; + } + if (LeftTypeCode != StringTypeCode && RightTypeCode != StringTypeCode) + { + /* both NUMBER */ + return FALSE; + } + /* TYPE MISMATCH */ + return TRUE; +} + +static int +for_limit_check (DoubleType Value, DoubleType Target, DoubleType Step) +{ + + if (Step > 0) + { + /* POSITIVE */ + if (Value > Target) + { + /* FOR I = 3 TO 2 STEP 1 */ + return TRUE; + } + } + else + { + /* NEGATIVE */ + if (Value < Target) + { + /* FOR I = -3 TO -2 STEP -1 */ + return TRUE; + } + } + return FALSE; +} + +/* EOF */ |