/*************************************************************** bwb_cmd.c Miscellaneous 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 void bwb_copy_file (char *Source, char *Target); static LineType *bwb_delete (LineType * l); static void bwb_display_file (char *Source); static LineType *bwb_load (LineType * Line, char *Prompt, int IsNew); static void bwb_new (void); static LineType *bwb_run_filename_or_linenumber (LineType * L); static LineType *bwb_save (LineType * Line, char *Prompt); static LineType *bwb_system (LineType * l); static LineType *bwb_xlist (LineType * l, FILE * file); static LineType *bwx_run (LineType * Line, char *ProgramName); static void CommandOptionVersion (int n, char *OutputLine); static void CommandUniqueID (int i, char *UniqueID); static void CommandVector (int i, char *Vector); static VariableType *find_variable_by_type (char *name, int dimensions, char VariableTypeCode); static void FixUp (char *Name); static LineType *H14_RENAME (LineType * l); static int line_read_matrix_redim (LineType * l, VariableType * v); static void ProcessEscapeChars (const char *Input, char *Output); static int xl_line (FILE * file, LineType * l); /* fprintf( file, "------------------------------------------------------------\n"); 123456789012345678901234567890123456789012345678901234567890 fprintf( file, " SYNTAX: %s\n", IntrinsicCommandTable[n].Syntax); sprintf( tbuf, "DESCRIPTION: %s\n", IntrinsicCommandTable[n].Description); fprintf( file, " " ); fprintf( file, " [%c] %s\n", X, bwb_vertable[i].Name); 1234567890123 */ #define LEFT_LENGTH 13 #define RIGHT_LENGTH 47 #define TOTAL_LENGTH ( LEFT_LENGTH + RIGHT_LENGTH ) /* -------------------------------------------------------------------------------------------- EDIT, RENUM, RENUMBER -------------------------------------------------------------------------------------------- */ static LineType * bwx_run (LineType * Line, char *ProgramName) { size_t n; char *tbuf; assert (Line != NULL); assert( My != NULL ); if (is_empty_string (ProgramName)) { WARN_BAD_FILE_NAME; return (Line); } if (is_empty_string (My->ProgramFilename)) { WARN_BAD_FILE_NAME; return (Line); } n = bwb_strlen (ProgramName) + 1 + bwb_strlen (My->ProgramFilename); if ((tbuf = (char *) calloc (n + 1 /* NulChar */ , sizeof (char))) == NULL) { WARN_OUT_OF_MEMORY; return (Line); } bwb_strcpy (tbuf, ProgramName); bwb_strcat (tbuf, " "); bwb_strcat (tbuf, My->ProgramFilename); system (tbuf); free (tbuf); tbuf = NULL; /* open edited file for read */ bwb_NEW (Line); /* Relocated by JBV (bug found by DD) */ if (bwb_fload (NULL) == FALSE) { WARN_BAD_FILE_NAME; return (Line); } return (Line); } /*************************************************************** FUNCTION: bwb_edit() DESCRIPTION: This function implements the BASIC EDIT program by shelling out to a default editor specified by the variable BWB.EDITOR$. SYNTAX: EDIT ***************************************************************/ LineType * bwb_EDIT (LineType * Line) { /* SYNTAX: EDIT */ assert (Line != NULL); assert( My != NULL ); return bwx_run (Line, My->OptionEditString); } /*************************************************************** FUNCTION: bwb_renum() DESCRIPTION: This function implements the BASIC RENUM command by shelling out to a default renumbering program called "renum". Added by JBV 10/95 SYNTAX: RENUM ***************************************************************/ LineType * bwb_RENUM (LineType * Line) { /* SYNTAX: RENUM */ assert (Line != NULL); assert( My != NULL ); return bwx_run (Line, My->OptionRenumString); } LineType * bwb_RENUMBER (LineType * Line) { /* SYNTAX: RENUMBER */ assert (Line != NULL); assert( My != NULL ); return bwx_run (Line, My->OptionRenumString); } /* -------------------------------------------------------------------------------------------- REM -------------------------------------------------------------------------------------------- */ LineType * bwb_REM (LineType * L) { /* SYNTAX: REM comment */ /* This line holds BASIC comments. */ assert (L != NULL); line_skip_eol (L); return L; } /* -------------------------------------------------------------------------------------------- IMAGE -------------------------------------------------------------------------------------------- */ LineType * bwb_IMAGE (LineType * L) { /* SYNTAX: IMAGE print-using-format */ assert (L != NULL); line_skip_eol (L); return L; } /* -------------------------------------------------------------------------------------------- LET -------------------------------------------------------------------------------------------- */ LineType * bwb_LET (LineType * L) { /* SYNTAX: LET variable [,...] = expression */ VariableType *v; VariantType x; VariantType *X; assert (L != NULL); X = &x; CLEAR_VARIANT (X); /* read the list of variables */ do { if ((v = line_read_scalar (L)) == NULL) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } } while (line_skip_seperator (L)); /* skip the equal sign */ if (line_skip_EqualChar (L)) { /* OK */ } else if (line_skip_word (L, "EQ")) { /* OK */ } else if (line_skip_word (L, ".EQ.")) { /* OK */ } else { WARN_SYNTAX_ERROR; goto EXIT; } /* evaluate the expression */ if (line_read_expression (L, X)) /* bwb_LET */ { /* save the value */ if (line_is_eol (L) == FALSE) { WARN_SYNTAX_ERROR; goto EXIT; } L->position = L->Startpos; /* for each variable, assign the value */ do { /* read a variable */ if ((v = line_read_scalar (L)) == NULL) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } assert (v != NULL); assert (X != NULL); if (var_set (v, X) == FALSE) { WARN_TYPE_MISMATCH; goto EXIT; } } while (line_skip_seperator (L)); /* we are now at the equals sign */ line_skip_eol (L); } else { WARN_SYNTAX_ERROR; } EXIT: RELEASE_VARIANT (X); return L; } LineType * bwb_CONST (LineType * L) { /* SYNTAX: CONST variable [,...] = expression */ VariableType *v; VariantType x; VariantType *X; assert (L != NULL); X = &x; CLEAR_VARIANT (X); /* read the list of variables */ do { if ((v = line_read_scalar (L)) == NULL) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } } while (line_skip_seperator (L)); /* we are now at the equals sign */ /* skip the equal sign */ if (line_skip_EqualChar (L)) { /* OK */ } else if (line_skip_word (L, "EQ")) { /* OK */ } else if (line_skip_word (L, ".EQ.")) { /* OK */ } else { WARN_SYNTAX_ERROR; goto EXIT; } /* evaluate the expression */ if (line_read_expression (L, X)) /* bwb_LET */ { /* save the value */ if (line_is_eol (L) == FALSE) { WARN_SYNTAX_ERROR; goto EXIT; } /* for each variable, assign the value */ L->position = L->Startpos; do { /* read a variable */ if ((v = line_read_scalar (L)) == NULL) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } assert (v != NULL); assert (X != NULL); if (var_set (v, X) == FALSE) { WARN_TYPE_MISMATCH; goto EXIT; } } while (line_skip_seperator (L)); /* we are now at the equals sign */ /* for each variable, mark as constant */ L->position = L->Startpos; do { /* read a variable */ if ((v = line_read_scalar (L)) == NULL) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } assert (v != NULL); v->VariableFlags |= VARIABLE_CONSTANT; } while (line_skip_seperator (L)); /* we are now at the equals sign */ line_skip_eol (L); } else { WARN_SYNTAX_ERROR; } EXIT: RELEASE_VARIANT (X); return L; } LineType * bwb_DEC (LineType * L) { /* SYNTAX: DEC variable [,...] */ VariableType *v; VariantType x; VariantType *X; assert (L != NULL); X = &x; CLEAR_VARIANT (X); /* read the list of variables */ do { if ((v = line_read_scalar (L)) == NULL) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } if (v->VariableTypeCode == StringTypeCode) { WARN_TYPE_MISMATCH; goto EXIT; } } while (line_skip_seperator (L)); /* we are now at the end of the line */ if (line_is_eol (L) == FALSE) { WARN_SYNTAX_ERROR; goto EXIT; } L->position = L->Startpos; /* for each variable, assign the value */ do { /* read a variable */ if ((v = line_read_scalar (L)) == NULL) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } assert (v != NULL); assert (X != NULL); if (var_get (v, X) == FALSE) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } X->Number--; if (var_set (v, X) == FALSE) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } } while (line_skip_seperator (L)); /* we are now at the end of the line */ EXIT: RELEASE_VARIANT (X); return L; } LineType * bwb_INC (LineType * L) { /* SYNTAX: INC variable [,...] */ VariableType *v; VariantType x; VariantType *X; assert (L != NULL); X = &x; CLEAR_VARIANT (X); /* read the list of variables */ do { if ((v = line_read_scalar (L)) == NULL) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } if (v->VariableTypeCode == StringTypeCode) { WARN_TYPE_MISMATCH; goto EXIT; } } while (line_skip_seperator (L)); /* we are now at the end of the line */ if (line_is_eol (L) == FALSE) { WARN_SYNTAX_ERROR; goto EXIT; } L->position = L->Startpos; /* for each variable, assign the value */ do { /* read a variable */ if ((v = line_read_scalar (L)) == NULL) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } assert (v != NULL); assert (X != NULL); if (var_get (v, X) == FALSE) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } X->Number++; if (var_set (v, X) == FALSE) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } } while (line_skip_seperator (L)); /* we are now at the end of the line */ EXIT: RELEASE_VARIANT (X); return L; } /* -------------------------------------------------------------------------------------------- GO -------------------------------------------------------------------------------------------- */ LineType * bwb_GO (LineType * L) { assert (L != NULL); WARN_SYNTAX_ERROR; return L; } LineType * bwb_THEN (LineType * L) { assert (L != NULL); WARN_SYNTAX_ERROR; return L; } LineType * bwb_TO (LineType * L) { assert (L != NULL); WARN_SYNTAX_ERROR; return L; } LineType * bwb_STEP (LineType * L) { assert (L != NULL); WARN_SYNTAX_ERROR; return L; } LineType * bwb_OF (LineType * L) { assert (L != NULL); WARN_SYNTAX_ERROR; return L; } LineType * bwb_AS (LineType * L) { assert (L != NULL); WARN_SYNTAX_ERROR; return L; } /* -------------------------------------------------------------------------------------------- AUTO -------------------------------------------------------------------------------------------- */ LineType * bwb_BUILD (LineType * L) { /* SYNTAX: BUILD SYNTAX: BUILD start SYNTAX: BUILD start, increment */ assert (L != NULL); return bwb_AUTO (L); } LineType * bwb_AUTO (LineType * L) { /* SYNTAX: AUTO SYNTAX: AUTO start SYNTAX: AUTO start , increment */ assert (L != NULL); assert( My != NULL ); My->AutomaticLineNumber = 0; My->AutomaticLineIncrement = 0; if (line_is_eol (L)) { /* AUTO */ My->AutomaticLineNumber = 10; My->AutomaticLineIncrement = 10; return L; } if (line_read_line_number (L, &My->AutomaticLineNumber)) { /* AUTO ### ... */ if (My->AutomaticLineNumber < MINLIN || My->AutomaticLineNumber > MAXLIN) { WARN_UNDEFINED_LINE; return L; } if (line_is_eol (L)) { /* AUTO start */ My->AutomaticLineIncrement = 10; return L; } else if (line_skip_seperator (L)) { /* AUTO ### , ... */ if (line_read_line_number (L, &My->AutomaticLineIncrement)) { /* AUTO start , increment */ if (My->AutomaticLineIncrement < MINLIN || My->AutomaticLineIncrement > MAXLIN) { WARN_UNDEFINED_LINE; return L; } return L; } } } My->AutomaticLineNumber = 0; My->AutomaticLineIncrement = 0; WARN_SYNTAX_ERROR; return L; } /* -------------------------------------------------------------------------------------------- BREAK -------------------------------------------------------------------------------------------- */ LineType * bwb_BREAK (LineType * l) { /* SYNTAX: BREAK SYNTAX: BREAK line [,...] SYNTAX: BREAK line - line */ assert (l != NULL); assert( My != NULL ); assert( My->StartMarker != NULL ); assert( My->EndMarker != NULL ); if (line_is_eol (l)) { /* BREAK */ /* remove all line breaks */ LineType *x; for (x = My->StartMarker->next; x != My->EndMarker; x = x->next) { x->LineFlags &= ~LINE_BREAK; } return (l); } else { do { int head; int tail; if (line_read_line_sequence (l, &head, &tail)) { /* BREAK 's' - 'e' */ LineType *x; if (head < MINLIN || head > MAXLIN) { WARN_UNDEFINED_LINE; return (l); } if (tail < MINLIN || tail > MAXLIN) { WARN_UNDEFINED_LINE; return (l); } if (head > tail) { WARN_SYNTAX_ERROR; return (l); } /* valid range */ /* now go through and list appropriate lines */ for (x = My->StartMarker->next; x != My->EndMarker; x = x->next) { if (head <= x->number && x->number <= tail) { if (x->LineFlags & LINE_NUMBERED) { x->LineFlags |= LINE_BREAK; } } } } else { WARN_SYNTAX_ERROR; return (l); } } while (line_skip_seperator (l)); } return (l); } /* -------------------------------------------------------------------------------------------- DSP -------------------------------------------------------------------------------------------- */ LineType * bwb_DSP (LineType * l) { /* SYNTAX: DSP SYNTAX: DSP variablename [,...] */ VariableType *v; assert (l != NULL); assert( My != NULL ); if (line_is_eol (l)) { /* DSP */ /* remove all variable displays */ for (v = My->VariableHead; v != NULL; v = v->next) { v->VariableFlags &= ~VARIABLE_DISPLAY; /* bwb_DSP() */ } return (l); } /* DSP variablename [,...] */ do { char varname[NameLengthMax + 1]; if (line_read_varname (l, varname)) { /* mark the variable */ for (v = My->VariableHead; v != NULL; v = v->next) { if (bwb_stricmp (v->name, varname) == 0) { v->VariableFlags |= VARIABLE_DISPLAY; /* bwb_DSP() */ } } } } while (line_skip_seperator (l)); return (l); } /* -------------------------------------------------------------------------------------------- GOTO -------------------------------------------------------------------------------------------- */ LineType * bwb_GO_TO (LineType * l) { assert (l != NULL); return bwb_GOTO (l); } LineType * bwb_GOTO (LineType * l) { /* SYNTAX: GOTO line ' standard GOTO SYNTAX: GOTO expression ' calculated GOTO SYNTAX: GOTO expression OF line,... ' indexed GOTO, same as ON expression GOTO line,... SYNTAX: GOTO line [,...] ON expression ' indexed GOTO, same as ON expression GOTO line,... */ int Value; int LineNumber; LineType *x; assert (l != NULL); assert( My != NULL ); assert( My->CurrentVersion != NULL ); Value = 0; LineNumber = 0; if (l->LineFlags & (LINE_USER)) { WARN_ILLEGAL_DIRECT; return (l); } if (line_is_eol (l)) { WARN_SYNTAX_ERROR; return (l); } if (line_read_integer_expression (l, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (line_is_eol (l)) { /* GOTO linenumber */ /* 'Value' is the line number */ LineNumber = Value; } else if (line_skip_word (l, "OF")) { /* GOTO expression OF line, ... */ /* 'Value' is an index into a list of line numbers */ if (line_read_index_item (l, Value, &LineNumber)) { /* found 'LineNumber' */ } else if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_ON) ) /* GOTO X OF ... */ { /* silently fall-thru to the following line */ line_skip_eol (l); return (l); } else { /* ERROR */ WARN_UNDEFINED_LINE; return (l); } } else if (My->CurrentVersion->OptionVersionValue & (S70 | I70 | I73)) { /* GOTO line [,...] ON expression */ while (line_skip_seperator (l)) { if (line_read_integer_expression (l, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (l); } } if (line_skip_word (l, "ON") == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (line_read_integer_expression (l, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (l); } /* 'Value' is an index into a list of line numbers */ l->position = l->Startpos; if (line_read_index_item (l, Value, &LineNumber)) { /* found 'LineNumber' */ } else { /* silently fall-thru to the following line */ line_skip_eol (l); return (l); } line_skip_eol (l); } else { WARN_SYNTAX_ERROR; return (l); } if (LineNumber < MINLIN || LineNumber > MAXLIN) { WARN_UNDEFINED_LINE; return (l); } /* valid range */ 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); /* not found in the cache */ } if (x != NULL) { /* FOUND */ 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; } /* NOT FOUND */ WARN_UNDEFINED_LINE; return (l); } /* -------------------------------------------------------------------------------------------- GOSUB -------------------------------------------------------------------------------------------- */ LineType * bwb_GO_SUB (LineType * l) { assert (l != NULL); return bwb_GOSUB (l); } LineType * bwb_GOSUB (LineType * l) { /* SYNTAX: GOSUB line ' standard GOSUB SYNTAX: GOSUB expression ' calculated GOSUB SYNTAX: GOSUB expression OF line,... ' indexed GOSUB, same as ON expression GOSUB line,... SYNTAX: GOSUB line [,...] ON expression ' indexed GOSUB, same as ON expression GOSUB line,... */ int Value; int LineNumber; LineType *x; assert (l != NULL); assert( My != NULL ); assert( My->CurrentVersion != NULL ); Value = 0; LineNumber = 0; x = NULL; if (l->LineFlags & (LINE_USER)) { WARN_ILLEGAL_DIRECT; return (l); } if (line_is_eol (l)) { WARN_SYNTAX_ERROR; return (l); } if (line_read_integer_expression (l, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (line_is_eol (l)) { /* GOSUB linenumber */ /* 'Value' is the line number */ LineNumber = Value; } else if (line_skip_word (l, "OF")) { /* GOSUB linenumber [,...] OF expression */ /* 'Value' is an index into a list of line numbers */ if (line_read_index_item (l, Value, &LineNumber)) { /* found 'LineNumber' */ } else if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_ON) ) /* GOSUB X OF ... */ { /* silently fall-thru to the following line */ line_skip_eol (l); return (l); } else { /* ERROR */ WARN_UNDEFINED_LINE; return (l); } } else if (My->CurrentVersion->OptionVersionValue & (S70 | I70 | I73)) { /* GOSUB line [,...] ON expression */ while (line_skip_seperator (l)) { if (line_read_integer_expression (l, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (l); } } if (line_skip_word (l, "ON") == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (line_read_integer_expression (l, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (l); } /* 'Value' is an index into a list of line numbers */ l->position = l->Startpos; if (line_read_index_item (l, Value, &LineNumber)) { /* found 'LineNumber' */ } else { /* silently fall-thru to the following line */ line_skip_eol (l); return (l); } line_skip_eol (l); } else { WARN_SYNTAX_ERROR; return (l); } if (LineNumber < MINLIN || LineNumber > MAXLIN) { WARN_UNDEFINED_LINE; return (l); } /* valid range */ 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); /* not found in the cache */ } if (x != NULL) { /* FOUND */ line_skip_eol (l); /* save current stack level */ My->StackHead->line = l; /* increment exec stack */ if (bwb_incexec ()) { /* set the new position to x and return x */ x->position = 0; My->StackHead->line = x; My->StackHead->ExecCode = EXEC_GOSUB; #if THE_PRICE_IS_RIGHT l->OtherLine = x; /* save in cache */ #endif /* THE_PRICE_IS_RIGHT */ return x; } else { /* ERROR */ WARN_OUT_OF_MEMORY; return My->EndMarker; } } /* NOT FOUND */ WARN_UNDEFINED_LINE; return (l); } /* -------------------------------------------------------------------------------------------- RETURN -------------------------------------------------------------------------------------------- */ LineType * bwb_RETURN (LineType * l) { /* SYNTAX: RETURN */ assert (l != NULL); assert (My != NULL); assert (My->CurrentVersion != NULL); assert (My->StackHead != NULL); if (My->CurrentVersion->OptionVersionValue & (S70 | I70 | I73)) { /* RETURN [comment] */ line_skip_eol (l); } if (My->CurrentVersion->OptionVersionValue & (C77)) { /* CBASIC-II: RETURN exits the first FUNCTION or GOSUB */ while (My->StackHead->ExecCode != EXEC_GOSUB && My->StackHead->ExecCode != EXEC_FUNCTION) { bwb_decexec (); if (My->StackHead == NULL) { WARN_RETURN_WITHOUT_GOSUB; return (l); } if (My->StackHead->ExecCode == EXEC_NORM) /* End of the line? */ { WARN_RETURN_WITHOUT_GOSUB; return (l); } } } else { /* RETURN exits the first GOSUB */ while (My->StackHead->ExecCode != EXEC_GOSUB) { bwb_decexec (); if (My->StackHead == NULL) { WARN_RETURN_WITHOUT_GOSUB; return (l); } if (My->StackHead->ExecCode == EXEC_NORM) /* End of the line? */ { WARN_RETURN_WITHOUT_GOSUB; return (l); } } } /* decrement the EXEC stack counter */ bwb_decexec (); assert (My->StackHead != NULL); return My->StackHead->line; } /* -------------------------------------------------------------------------------------------- POP -------------------------------------------------------------------------------------------- */ LineType * bwb_POP (LineType * l) { /* SYNTAX: POP */ StackType *StackItem; assert (l != NULL); assert (My != NULL); assert (My->CurrentVersion != NULL); assert (My->StackHead != NULL); StackItem = My->StackHead; while (StackItem->ExecCode != EXEC_GOSUB) { StackItem = StackItem->next; if (StackItem == NULL) { WARN_RETURN_WITHOUT_GOSUB; return (l); } if (StackItem->ExecCode == EXEC_NORM) { /* End of the line */ WARN_RETURN_WITHOUT_GOSUB; return (l); } } /* hide the GOSUB */ StackItem->ExecCode = EXEC_POPPED; return (l); } /* -------------------------------------------------------------------------------------------- ON -------------------------------------------------------------------------------------------- */ LineType * bwb_ON (LineType * l) { /* SYNTAX: ON expression GOTO line,... ' expression evaluates to an index SYNTAX: ON expression GOSUB line,... ' expression evaluates to an index */ int Value; int command; int LineNumber; LineType *x; assert (l != NULL); assert (My != NULL); assert (My->CurrentVersion != NULL); Value = 0; command = 0; LineNumber = 0; x = NULL; if (l->LineFlags & (LINE_USER)) { WARN_ILLEGAL_DIRECT; return (l); } if (line_is_eol (l)) { WARN_SYNTAX_ERROR; return (l); } if (line_read_integer_expression (l, &Value) == FALSE) { WARN_UNDEFINED_LINE; return (l); } if (line_skip_word (l, "GO")) { if (line_skip_word (l, "TO")) { command = C_GOTO; } else if (line_skip_word (l, "SUB")) { command = C_GOSUB; } else { WARN_SYNTAX_ERROR; return (l); } } else if (line_skip_word (l, "GOTO")) { command = C_GOTO; } else if (line_skip_word (l, "GOSUB")) { command = C_GOSUB; } else { WARN_SYNTAX_ERROR; return (l); } /* 'Value' is an index into a list of line numbers */ if (line_read_index_item (l, Value, &LineNumber)) { /* found 'LineNumber' */ } else if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_ON) ) /* ON X GOTO|GOSUB ... */ { /* silently fall-thru to the following line */ line_skip_eol (l); return (l); } else { /* ERROR */ WARN_UNDEFINED_LINE; return (l); } if (LineNumber < MINLIN || LineNumber > MAXLIN) { WARN_UNDEFINED_LINE; return (l); } /* valid range */ 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); /* not found in the cache */ } if (x != NULL) { /* FOUND */ if (command == C_GOTO) { /* ON ... GOTO ... */ 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; } else if (command == C_GOSUB) { /* ON ... GOSUB ... */ line_skip_eol (l); /* save current stack level */ My->StackHead->line = l; /* increment exec stack */ if (bwb_incexec ()) { /* set the new position to x and return x */ x->position = 0; My->StackHead->line = x; My->StackHead->ExecCode = EXEC_GOSUB; #if THE_PRICE_IS_RIGHT l->OtherLine = x; /* save in cache */ #endif /* THE_PRICE_IS_RIGHT */ return x; } else { /* ERROR */ WARN_OUT_OF_MEMORY; return My->EndMarker; } } else { /* ERROR */ WARN_SYNTAX_ERROR; return (l); } } /* NOT FOUND */ WARN_UNDEFINED_LINE; return (l); } /* -------------------------------------------------------------------------------------------- PAUSE -------------------------------------------------------------------------------------------- */ LineType * bwb_PAUSE (LineType * l) { /* SYNTAX: PAUSE */ char *pstring; char *tbuf; int tlen; assert (l != NULL); assert (My != NULL); assert (My->CurrentVersion != NULL); assert (My->ConsoleOutput != NULL); assert (My->ConsoleInput != NULL); pstring = My->ConsoleOutput; tbuf = My->ConsoleInput; tlen = MAX_LINE_LENGTH; if (My->CurrentVersion->OptionVersionValue & (S70 | I70 | I73)) { /* PAUSE [comment] */ line_skip_eol (l); } sprintf (pstring, "PAUSE AT %d\n", l->number); bwx_input (pstring, FALSE, tbuf, tlen); return (l); } /* -------------------------------------------------------------------------------------------- STOP -------------------------------------------------------------------------------------------- */ LineType * bwb_STOP (LineType * l) { /* SYNTAX: STOP */ assert (l != NULL); assert (My != NULL); assert (My->CurrentVersion != NULL); if (My->CurrentVersion->OptionVersionValue & (S70 | I70 | I73)) { /* STOP [comment] */ line_skip_eol (l); } My->ContinueLine = l->next; bwx_STOP (TRUE); return bwb_END (l); } /* -------------------------------------------------------------------------------------------- END -------------------------------------------------------------------------------------------- */ LineType * bwb_END (LineType * l) { /* SYNTAX: END */ assert (l != NULL); assert (My != NULL); assert (My->CurrentVersion != NULL); if (My->CurrentVersion->OptionVersionValue & (S70 | I70 | I73)) { /* END [comment] */ line_skip_eol (l); } My->ContinueLine = l->next; bwx_STOP (FALSE); return My->EndMarker; } /* -------------------------------------------------------------------------------------------- RUN -------------------------------------------------------------------------------------------- */ static LineType * bwb_run_filename_or_linenumber (LineType * L) { LineType *current = NULL; VariantType x; VariantType *X; assert (L != NULL); assert (My != NULL); assert (My->StartMarker != NULL); X = &x; CLEAR_VARIANT (X); if (line_read_expression (L, X) == FALSE) /* bwb_run_filename_or_linenumber */ { WARN_SYNTAX_ERROR; return L; } if (X->VariantTypeCode == StringTypeCode) { /* RUN "filename" */ /* RUN A$ */ if (is_empty_string (X->Buffer)) { WARN_BAD_FILE_NAME; return L; } /* open the file and execute it */ bwb_new (); /* clear memory */ if (My->ProgramFilename != NULL) { free (My->ProgramFilename); My->ProgramFilename = NULL; } My->ProgramFilename = bwb_strdup (X->Buffer); if (bwb_fload (NULL) == FALSE) { WARN_BAD_FILE_NAME; return L; } /* ** ** FORCE SCAN ** */ if (bwb_scan () == FALSE) { WARN_CANT_CONTINUE; return L; } current = My->StartMarker->next; } else { /* RUN 100 */ /* RUN N */ /* execute the line */ int LineNumber; LineNumber = (int) bwb_rint (X->Number); /* ** ** FORCE SCAN ** */ if (bwb_scan () == FALSE) { WARN_CANT_CONTINUE; goto EXIT; } current = find_line_number (LineNumber); /* RUN 100 */ if (current == NULL) { WARN_CANT_CONTINUE; return L; } } EXIT: RELEASE_VARIANT (X); return current; } LineType * bwb_RUNNH (LineType * L) { assert (L != NULL); return bwb_RUN (L); } LineType * bwb_RUN (LineType * L) { /* SYNTAX: RUN SYNTAX: RUN filename$ SYNTAX: RUN linenumber */ LineType *current; assert (L != NULL); assert (My != NULL); assert (My->EndMarker != NULL); assert (My->DefaultVariableType != NULL); /* clear the STACK */ bwb_clrexec (); if (bwb_incexec ()) { /* OK */ } else { /* ERROR */ WARN_OUT_OF_MEMORY; return My->EndMarker; } if (line_is_eol (L)) { /* RUN */ var_CLEAR (); /* if( TRUE ) */ { int n; for (n = 0; n < 26; n++) { My->DefaultVariableType[n] = DoubleTypeCode; } } /* ** ** FORCE SCAN ** */ if (bwb_scan () == FALSE) { WARN_CANT_CONTINUE; return My->EndMarker; } current = My->StartMarker->next; } else { /* RUN 100 : RUN filename$ */ current = bwb_run_filename_or_linenumber (L); if (current == NULL) { WARN_UNDEFINED_LINE; return My->EndMarker; } } current->position = 0; assert (My->StackHead != NULL); My->StackHead->line = current; My->StackHead->ExecCode = EXEC_NORM; /* RUN */ WARN_CLEAR; /* bwb_RUN */ My->ContinueLine = NULL; SetOnError (0); /* if( TRUE ) */ { time_t t; struct tm *lt; time (&t); lt = localtime (&t); My->StartTimeInteger = lt->tm_hour; My->StartTimeInteger *= 60; My->StartTimeInteger += lt->tm_min; My->StartTimeInteger *= 60; My->StartTimeInteger += lt->tm_sec; /* number of seconds since midnight */ } return current; } /* -------------------------------------------------------------------------------------------- CONT -------------------------------------------------------------------------------------------- */ LineType * bwb_CONTINUE (LineType * l) { /* SYNTAX: CONTINUE */ assert (l != NULL); return bwb_CONT (l); } LineType * bwb_CONT (LineType * l) { /* SYNTAX: CONT */ LineType *current; assert (l != NULL); assert (My != NULL); assert (My->EndMarker != NULL); assert (My->StartMarker != NULL); current = NULL; /* see if there is an element */ if (line_is_eol (l)) { /* CONT */ current = My->ContinueLine; } else { /* CONT 100 */ int LineNumber; LineNumber = 0; if (line_read_line_number (l, &LineNumber)) { current = find_line_number (LineNumber); /* CONT 100 */ } } if (current == NULL || current == My->EndMarker) { /* same as RUN */ current = My->StartMarker->next; } /* ** ** FORCE SCAN ** */ if (bwb_scan () == FALSE) { WARN_CANT_CONTINUE; return (l); } current->position = 0; bwb_clrexec (); if (bwb_incexec ()) { /* OK */ My->StackHead->line = current; My->StackHead->ExecCode = EXEC_NORM; } else { /* ERROR */ WARN_OUT_OF_MEMORY; return My->EndMarker; } /* CONT */ My->ContinueLine = NULL; return current; } /* -------------------------------------------------------------------------------------------- NEW -------------------------------------------------------------------------------------------- */ void bwb_xnew (LineType * l) { LineType *current; LineType *previous; int wait; assert (l != NULL); assert (My != NULL); assert (My->EndMarker != NULL); previous = NULL; /* JBV */ wait = TRUE; for (current = l->next; current != My->EndMarker; current = current->next) { assert (current != NULL); if (wait == FALSE) { free (previous); previous = NULL; } wait = FALSE; previous = current; } l->next = My->EndMarker; } static void bwb_new () { assert (My != NULL); assert (My->StartMarker != NULL); assert (My->DefaultVariableType != NULL); /* clear program in memory */ bwb_xnew (My->StartMarker); /* clear all variables */ var_CLEAR (); /* if( TRUE ) */ { int n; for (n = 0; n < 26; n++) { My->DefaultVariableType[n] = DoubleTypeCode; } } /* NEW */ WARN_CLEAR; /* bwb_new */ My->ContinueLine = NULL; SetOnError (0); } LineType * bwb_NEW (LineType * l) { /* SYNTAX: NEW */ assert (l != NULL); assert (My != NULL); assert (My->CurrentVersion != NULL); bwb_new (); if (My->CurrentVersion->OptionVersionValue & (D64 | G65 | G67 | G74)) { if (line_is_eol (l)) { /* NEW */ char *tbuf; int tlen; tbuf = My->ConsoleInput; tlen = MAX_LINE_LENGTH; /* prompt for the program name */ bwx_input ("NEW PROBLEM NAME:", FALSE, tbuf, tlen); if (is_empty_string (tbuf)) { WARN_BAD_FILE_NAME; return l; } if (My->ProgramFilename != NULL) { free (My->ProgramFilename); My->ProgramFilename = NULL; } My->ProgramFilename = bwb_strdup (tbuf); } else { /* NEW filename$ */ /* the parameter is the program name */ char *Value; Value = NULL; if (line_read_string_expression (l, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (is_empty_string (Value)) { WARN_BAD_FILE_NAME; return l; } if (My->ProgramFilename != NULL) { free (My->ProgramFilename); My->ProgramFilename = NULL; } My->ProgramFilename = Value; } } else { /* ignore any parameters */ line_skip_eol (l); } return (l); } /* -------------------------------------------------------------------------------------------- SCRATCH -------------------------------------------------------------------------------------------- */ LineType * bwb_SCRATCH (LineType * l) { /* SYNTAX: SCRATCH -- same as NEW SYNTAX: SCRATCH # filenumber -- close file and re-open for output */ assert (l != NULL); if (line_is_eol (l)) { /* SCRATCH */ bwb_new (); return (l); } if (line_skip_FilenumChar (l)) { /* SCRATCH # X */ int FileNumber; if (line_read_integer_expression (l, &FileNumber) == FALSE) { WARN_BAD_FILE_NUMBER; return (l); } if (FileNumber < 0) { /* SCRATCH # -1 is silently ignored */ return (l); } if (FileNumber == 0) { /* SCRATCH # 0 is silently ignored */ return (l); } My->CurrentFile = find_file_by_number (FileNumber); if (My->CurrentFile == NULL) { WARN_BAD_FILE_NUMBER; return (l); } if (My->CurrentFile->DevMode != DEVMODE_CLOSED) { My->CurrentFile->DevMode = DEVMODE_CLOSED; } if (My->CurrentFile->cfp != NULL) { bwb_fclose (My->CurrentFile->cfp); My->CurrentFile->cfp = NULL; } if (My->CurrentFile->buffer != NULL) { free (My->CurrentFile->buffer); My->CurrentFile->buffer = NULL; } My->CurrentFile->width = 0; My->CurrentFile->col = 1; My->CurrentFile->row = 1; My->CurrentFile->delimit = ','; if (is_empty_string (My->CurrentFile->FileName)) { WARN_BAD_FILE_NAME; return (l); } if (bwb_strcmp (My->CurrentFile->FileName, "*") != 0) { if ((My->CurrentFile->cfp = fopen (My->CurrentFile->FileName, "w")) == NULL) { WARN_BAD_FILE_NAME; return (l); } My->CurrentFile->DevMode = DEVMODE_OUTPUT; } /* OK */ return (l); } WARN_SYNTAX_ERROR; return (l); } /* ============================================================================================ SYSTEM and so on ============================================================================================ */ static LineType * bwb_system (LineType * l) { /* SYNTAX: SYSTEM */ assert (l != NULL); assert (My != NULL); assert (My->SYSOUT != NULL); assert (My->SYSOUT->cfp != NULL); fprintf (My->SYSOUT->cfp, "\n"); fflush (My->SYSOUT->cfp); bwx_terminate (); return (l); /* never reached */ } /* -------------------------------------------------------------------------------------------- BYE -------------------------------------------------------------------------------------------- */ LineType * bwb_BYE (LineType * l) { /* SYNTAX: BYE */ assert (l != NULL); return bwb_system (l); } /* -------------------------------------------------------------------------------------------- DOS -------------------------------------------------------------------------------------------- */ LineType * bwb_DOS (LineType * l) { /* SYNTAX: DOS */ assert (l != NULL); return bwb_system (l); } /* -------------------------------------------------------------------------------------------- FLEX -------------------------------------------------------------------------------------------- */ LineType * bwb_FLEX (LineType * l) { /* SYNTAX: FLEX */ assert (l != NULL); return bwb_system (l); } /* -------------------------------------------------------------------------------------------- GOODBYE -------------------------------------------------------------------------------------------- */ LineType * bwb_GOODBYE (LineType * l) { /* SYNTAX: GOODBYE */ assert (l != NULL); return bwb_system (l); } /* -------------------------------------------------------------------------------------------- MON -------------------------------------------------------------------------------------------- */ LineType * bwb_MON (LineType * l) { /* SYNTAX: MON */ assert (l != NULL); return bwb_system (l); } /* -------------------------------------------------------------------------------------------- QUIT -------------------------------------------------------------------------------------------- */ LineType * bwb_QUIT (LineType * l) { /* SYNTAX: QUIT */ assert (l != NULL); return bwb_system (l); } /* -------------------------------------------------------------------------------------------- SYSTEM -------------------------------------------------------------------------------------------- */ LineType * bwb_SYSTEM (LineType * l) { /* SYNTAX: SYSTEM */ assert (l != NULL); return bwb_system (l); } /* ============================================================================================ LOAD and so on ============================================================================================ */ static LineType * bwb_load (LineType * Line, char *Prompt, int IsNew) { /* ** ** load a BASIC program from a file ** */ /* SYNTAX: ... [filename$] */ assert (Line != NULL); assert (Prompt != NULL); assert (My != NULL); assert (My->CurrentVersion != NULL); if (IsNew) { /* TRUE == LOAD */ bwb_new (); } else { /* FALSE == MERGE */ if (My->ProgramFilename != NULL) { free (My->ProgramFilename); My->ProgramFilename = NULL; } } if (line_is_eol (Line)) { /* default is the last filename used by LOAD or SAVE */ /* if( My->CurrentVersion->OptionVersionValue & (D64 | G65 | G67 | G74) ) */ if (is_empty_string (My->ProgramFilename)) { /* prompt for the program name */ char *tbuf; int tlen; tbuf = My->ConsoleInput; tlen = MAX_LINE_LENGTH; bwx_input (Prompt, FALSE, tbuf, tlen); if (is_empty_string (tbuf)) { WARN_BAD_FILE_NAME; return (Line); } if (My->ProgramFilename != NULL) { free (My->ProgramFilename); My->ProgramFilename = NULL; } My->ProgramFilename = bwb_strdup (tbuf); } fprintf (My->SYSOUT->cfp, "Loading %s\n", My->ProgramFilename); ResetConsoleColumn (); } else { /* Get an argument for filename */ char *Value; Value = NULL; if (line_read_string_expression (Line, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (Line); } if (is_empty_string (Value)) { WARN_BAD_FILE_NAME; return (Line); } if (My->ProgramFilename != NULL) { free (My->ProgramFilename); My->ProgramFilename = NULL; } My->ProgramFilename = Value; } if (bwb_fload (NULL) == FALSE) { WARN_BAD_FILE_NAME; return (Line); } if (IsNew) { /* TRUE == LOAD */ } else { /* FALSE == MERGE */ if (My->ProgramFilename != NULL) { free (My->ProgramFilename); My->ProgramFilename = NULL; } } /* ** ** FORCE SCAN ** */ if (bwb_scan () == FALSE) { WARN_CANT_CONTINUE; } return (Line); } /* -------------------------------------------------------------------------------------------- CLOAD -------------------------------------------------------------------------------------------- */ LineType * bwb_CLOAD (LineType * Line) { /* SYNTAX: CLOAD [filename$] */ assert (Line != NULL); return bwb_load (Line, "CLOAD FILE NAME:", TRUE); } /* -------------------------------------------------------------------------------------------- LOAD -------------------------------------------------------------------------------------------- */ LineType * bwb_LOAD (LineType * Line) { /* SYNTAX: LOAD [filename$] */ assert (Line != NULL); return bwb_load (Line, "LOAD FILE NAME:", TRUE); } /* -------------------------------------------------------------------------------------------- MERGE -------------------------------------------------------------------------------------------- */ LineType * bwb_MERGE (LineType * l) { /* SYNTAX: MERGE [filename$] */ assert (l != NULL); return bwb_load (l, "MERGE FILE NAME:", FALSE); } /* -------------------------------------------------------------------------------------------- OLD -------------------------------------------------------------------------------------------- */ LineType * bwb_OLD (LineType * Line) { /* SYNTAX: OLD [filename$] */ assert (Line != NULL); return bwb_load (Line, "OLD PROBLEM NAME:", TRUE); } /* -------------------------------------------------------------------------------------------- TLOAD -------------------------------------------------------------------------------------------- */ LineType * bwb_TLOAD (LineType * Line) { /* SYNTAX: TLOAD [filename$] */ assert (Line != NULL); return bwb_load (Line, "TLOAD FILE NAME:", TRUE); } /* -------------------------------------------------------------------------------------------- RENAME -------------------------------------------------------------------------------------------- */ static LineType * H14_RENAME (LineType * l) { /* SYNTAX: RENAME from$ TO to$ */ char *From; char *To; assert (l != NULL); From = NULL; To = NULL; if (line_read_string_expression (l, &From) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (is_empty_string (From)) { WARN_BAD_FILE_NAME; return (l); } if (line_skip_word (l, "TO") == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (line_read_string_expression (l, &To) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (is_empty_string (To)) { WARN_BAD_FILE_NAME; return (l); } if (rename (From, To)) { WARN_BAD_FILE_NAME; return (l); } return (l); } LineType * bwb_RENAME (LineType * l) { /* SYNTAX: RENAME filename$ */ assert (l != NULL); assert( My != NULL ); assert( My->CurrentVersion != NULL ); assert( My->ConsoleInput != NULL ); if (My->CurrentVersion->OptionVersionValue & (H14)) { /* RENAME == change an exisiting file's name */ return H14_RENAME (l); } /* RENAME == change the BASIC program's name for a later SAVE */ if (line_is_eol (l)) { /* RENAME */ if (My->CurrentVersion->OptionVersionValue & (D64 | G65 | G67 | G74)) { /* prompt for the program name */ char *tbuf; int tlen; tbuf = My->ConsoleInput; tlen = MAX_LINE_LENGTH; bwx_input ("RENAME PROBLEM NAME:", FALSE, tbuf, tlen); if (is_empty_string (tbuf)) { WARN_BAD_FILE_NAME; return (l); } if (My->ProgramFilename != NULL) { free (My->ProgramFilename); My->ProgramFilename = NULL; } My->ProgramFilename = bwb_strdup (tbuf); } else { WARN_SYNTAX_ERROR; return (l); } } else { /* RENAME value$ */ char *Value; Value = NULL; if (line_read_string_expression (l, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (is_empty_string (Value)) { WARN_BAD_FILE_NAME; return (l); } if (My->ProgramFilename != NULL) { free (My->ProgramFilename); My->ProgramFilename = NULL; } My->ProgramFilename = Value; } return (l); } /* -------------------------------------------------------------------------------------------- MAT -------------------------------------------------------------------------------------------- */ extern void Determinant (VariableType * v) { /* http://easy-learn-c-language.blogspot.com/search/label/Numerical%20Methods */ /* Numerical Methods: Determinant of nxn matrix using C */ DoubleType **matrix; DoubleType ratio; int i; int j; int k; int n; assert (v != NULL); assert( My != NULL ); My->LastDeterminant = 0; /* default */ n = v->UBOUND[0] - v->LBOUND[0] + 1; if ((matrix = (DoubleType **) calloc (n, sizeof (DoubleType *))) == NULL) { goto EXIT; } assert( matrix != NULL ); for (i = 0; i < n; i++) { if ((matrix[i] = (DoubleType *) calloc (n, sizeof (DoubleType))) == NULL) { goto EXIT; } assert( matrix[i] != NULL ); } for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { VariantType variant; CLEAR_VARIANT (&variant); v->VINDEX[0] = v->LBOUND[0] + i; v->VINDEX[1] = v->LBOUND[1] + j; if (var_get (v, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } if (variant.VariantTypeCode == StringTypeCode) { WARN_TYPE_MISMATCH; goto EXIT; } matrix[i][j] = variant.Number; } } /* Conversion of matrix to upper triangular */ for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { if (j > i) { if (matrix[i][i] == 0) { /* - Evaluation of an expression results in division * by zero (nonfatal, the recommended recovery * procedure is to supply machine infinity with the * sign of the numerator and continue) */ if (WARN_DIVISION_BY_ZERO) { /* ERROR */ goto EXIT; } /* CONTINUE */ if (matrix[j][i] < 0) { ratio = MINDBL; } else { ratio = MAXDBL; } } else { ratio = matrix[j][i] / matrix[i][i]; } for (k = 0; k < n; k++) { matrix[j][k] -= ratio * matrix[i][k]; } } } } My->LastDeterminant = 1; /* storage for determinant */ for (i = 0; i < n; i++) { DoubleType Value; Value = matrix[i][i]; My->LastDeterminant *= Value; } EXIT: if( matrix != NULL ) { for (i = 0; i < n; i++) { if( matrix[i] != NULL ) { free (matrix[i]); /* matrix[i] = NULL; */ } } free (matrix); /* matrix = NULL; */ } } int InvertMatrix (VariableType * vOut, VariableType * vIn) { /* http://easy-learn-c-language.blogspot.com/search/label/Numerical%20Methods */ /* Numerical Methods: Inverse of nxn matrix using C */ int Result; DoubleType **matrix; DoubleType ratio; int i; int j; int k; int n; assert (vOut != NULL); assert (vIn != NULL); Result = FALSE; n = vIn->UBOUND[0] - vIn->LBOUND[0] + 1; if ((matrix = (DoubleType **) calloc (n, sizeof (DoubleType *))) == NULL) { goto EXIT; } assert( matrix != NULL ); for (i = 0; i < n; i++) { if ((matrix[i] = (DoubleType *) calloc (n + n, sizeof (DoubleType))) == NULL) { goto EXIT; } assert( matrix[i] != NULL ); } for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { VariantType variant; CLEAR_VARIANT (&variant); vIn->VINDEX[0] = vIn->LBOUND[0] + i; vIn->VINDEX[1] = vIn->LBOUND[1] + j; if (var_get (vIn, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } if (variant.VariantTypeCode == StringTypeCode) { WARN_TYPE_MISMATCH; goto EXIT; } matrix[i][j] = variant.Number; } } for (i = 0; i < n; i++) { for (j = n; j < 2 * n; j++) { if (i == (j - n)) { matrix[i][j] = 1.0; } else { matrix[i][j] = 0.0; } } } for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { if (i != j) { if (matrix[i][i] == 0) { /* - Evaluation of an expression results in division * by zero (nonfatal, the recommended recovery * procedure is to supply machine infinity with the * sign of the numerator and continue) */ if (WARN_DIVISION_BY_ZERO) { /* ERROR */ goto EXIT; } /* CONTINUE */ if (matrix[j][i] < 0) { ratio = MINDBL; } else { ratio = MAXDBL; } } else { ratio = matrix[j][i] / matrix[i][i]; } for (k = 0; k < 2 * n; k++) { matrix[j][k] -= ratio * matrix[i][k]; } } } } for (i = 0; i < n; i++) { DoubleType a; a = matrix[i][i]; if (a == 0) { /* - Evaluation of an expression results in division * by zero (nonfatal, the recommended recovery * procedure is to supply machine infinity with the * sign of the numerator and continue) */ if (WARN_DIVISION_BY_ZERO) { /* ERROR */ goto EXIT; } /* CONTINUE */ for (j = 0; j < 2 * n; j++) { if (matrix[i][j] < 0) { matrix[i][j] = MINDBL; } else { matrix[i][j] = MAXDBL; } } } else { for (j = 0; j < 2 * n; j++) { matrix[i][j] /= a; } } } for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { VariantType variant; CLEAR_VARIANT (&variant); vOut->VINDEX[0] = vOut->LBOUND[0] + i; vOut->VINDEX[1] = vOut->LBOUND[0] + j; variant.VariantTypeCode = vOut->VariableTypeCode; variant.Number = matrix[i][j + n]; if (var_set (vOut, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; goto EXIT; } } } /* ** ** Everything is OK ** */ Result = TRUE; EXIT: if (matrix != NULL) { for (i = 0; i < n; i++) { if (matrix[i] != NULL) { free (matrix[i]); /* matrix[i] = NULL; */ } } free (matrix); /* matrix = NULL; */ } return Result; } static int line_read_matrix_redim (LineType * l, VariableType * v) { /* get OPTIONAL parameters if the variable is dimensioned */ assert (l != NULL); assert (v != NULL); if (line_peek_LparenChar (l)) { /* get requested size, which is <= original array size */ size_t array_units; int n; int dimensions; int LBOUND[MAX_DIMS]; int UBOUND[MAX_DIMS]; if (line_read_array_redim (l, &dimensions, LBOUND, UBOUND) == FALSE) { WARN_SYNTAX_ERROR; return FALSE; } /* update array dimensions */ array_units = 1; for (n = 0; n < dimensions; n++) { if (UBOUND[n] < LBOUND[n]) { WARN_SUBSCRIPT_OUT_OF_RANGE; return FALSE; } array_units *= UBOUND[n] - LBOUND[n] + 1; } if (array_units > v->array_units) { WARN_SUBSCRIPT_OUT_OF_RANGE; return FALSE; } v->dimensions = dimensions; for (n = 0; n < dimensions; n++) { v->LBOUND[n] = LBOUND[n]; v->UBOUND[n] = UBOUND[n]; } } return TRUE; } LineType * bwb_MAT (LineType * l) { /* SYNTAX: MAT A = CON SYNTAX: MAT A = IDN SYNTAX: MAT A = ZER SYNTAX: MAT A = INV B SYNTAX: MAT A = TRN B SYNTAX: MAT A = (k) * B SYNTAX: MAT A = B SYNTAX: MAT A = B + C SYNTAX: MAT A = B - C SYNTAX: MAT A = B * C */ VariableType *v_A; char varname_A[NameLengthMax + 1]; assert (l != NULL); /* just a placeholder for now. this will grow. */ if (line_read_varname (l, varname_A) == FALSE) { WARN_SYNTAX_ERROR; return (l); } v_A = mat_find (varname_A); if (v_A == NULL) { WARN_VARIABLE_NOT_DECLARED; return (l); } /* variable MUST be numeric */ if (VAR_IS_STRING (v_A)) { WARN_SYNTAX_ERROR; return (l); } if (line_read_matrix_redim (l, v_A) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (line_skip_EqualChar (l) == FALSE) { WARN_SYNTAX_ERROR; return (l); } /* MAT A = ... */ if (line_skip_word (l, "CON")) { /* MAT A = CON */ /* MAT A = CON(I) */ /* MAT A = CON(I,J) */ /* MAT A = CON(I,J,K) */ /* OK */ int i; int j; int k; if (line_read_matrix_redim (l, v_A) == FALSE) { WARN_SYNTAX_ERROR; return (l); } /* both arrays are of the same size */ switch (v_A->dimensions) { case 1: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { VariantType variant; CLEAR_VARIANT (&variant); variant.VariantTypeCode = v_A->VariableTypeCode; variant.Number = 1; v_A->VINDEX[0] = i; if (var_set (v_A, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } break; case 2: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { VariantType variant; CLEAR_VARIANT (&variant); variant.VariantTypeCode = v_A->VariableTypeCode; variant.Number = 1; v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; if (var_set (v_A, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } break; case 3: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { for (k = v_A->LBOUND[2]; k <= v_A->UBOUND[2]; k++) { VariantType variant; CLEAR_VARIANT (&variant); variant.VariantTypeCode = v_A->VariableTypeCode; variant.Number = 1; v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; v_A->VINDEX[2] = k; if (var_set (v_A, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } } break; default: WARN_SYNTAX_ERROR; return (l); } } else if (line_skip_word (l, "IDN")) { /* MAT A = IDN */ /* MAT A = IDN(I,J) */ /* OK */ int i; int j; if (line_read_matrix_redim (l, v_A) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (v_A->dimensions != 2) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } if (v_A->LBOUND[0] != v_A->LBOUND[1]) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } if (v_A->UBOUND[0] != v_A->UBOUND[1]) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } /* square matrix */ for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { VariantType variant; CLEAR_VARIANT (&variant); variant.VariantTypeCode = v_A->VariableTypeCode; if (i == j) { variant.Number = 1; } else { variant.Number = 0; } v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; if (var_set (v_A, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } } else if (line_skip_word (l, "ZER")) { /* MAT A = ZER */ /* MAT A = ZER(I) */ /* MAT A = ZER(I,J) */ /* MAT A = ZER(I,J,K) */ /* OK */ int i; int j; int k; if (line_read_matrix_redim (l, v_A) == FALSE) { WARN_SYNTAX_ERROR; return (l); } /* both arrays are of the same size */ switch (v_A->dimensions) { case 1: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { VariantType variant; CLEAR_VARIANT (&variant); variant.VariantTypeCode = v_A->VariableTypeCode; variant.Number = 0; v_A->VINDEX[0] = i; if (var_set (v_A, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } break; case 2: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { VariantType variant; CLEAR_VARIANT (&variant); variant.VariantTypeCode = v_A->VariableTypeCode; variant.Number = 0; v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; if (var_set (v_A, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } break; case 3: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { for (k = v_A->LBOUND[2]; k <= v_A->UBOUND[2]; k++) { VariantType variant; CLEAR_VARIANT (&variant); variant.VariantTypeCode = v_A->VariableTypeCode; variant.Number = 0; v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; v_A->VINDEX[2] = k; if (var_set (v_A, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } } break; default: WARN_SYNTAX_ERROR; return (l); } } else if (line_skip_word (l, "INV")) { /* MAT A = INV B */ /* MAT A = INV( B ) */ /* OK */ VariableType *v_B; char varname_B[NameLengthMax + 1]; if (v_A->dimensions != 2) { WARN_SYNTAX_ERROR; return (l); } if (v_A->LBOUND[0] != v_A->LBOUND[1] || v_A->UBOUND[0] != v_A->UBOUND[1]) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } if (line_skip_LparenChar (l)) { /* optional */ } if (line_read_varname (l, varname_B) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if ((v_B = mat_find (varname_B)) == NULL) { WARN_VARIABLE_NOT_DECLARED; return (l); } /* variable MUST be numeric */ if (VAR_IS_STRING (v_B)) { WARN_SYNTAX_ERROR; return (l); } if (line_read_matrix_redim (l, v_B) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (line_skip_RparenChar (l)) { /* optional */ } if (v_B->dimensions != 2) { WARN_SYNTAX_ERROR; return (l); } if (v_B->LBOUND[0] != v_B->LBOUND[1] || v_B->UBOUND[0] != v_B->UBOUND[1]) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } if (v_A->LBOUND[0] != v_B->LBOUND[0] || v_A->UBOUND[0] != v_B->UBOUND[0]) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } /* square matrix */ Determinant (v_B); if (My->LastDeterminant == 0) { WARN_ILLEGAL_FUNCTION_CALL; return (l); } if (InvertMatrix (v_A, v_B) == FALSE) { WARN_ILLEGAL_FUNCTION_CALL; return (l); } } else if (line_skip_word (l, "TRN")) { /* MAT A = TRN B */ /* MAT A = TRN( B ) */ /* OK */ int i; int j; VariableType *v_B; char varname_B[NameLengthMax + 1]; if (v_A->dimensions != 2) { WARN_SYNTAX_ERROR; return (l); } if (line_skip_LparenChar (l)) { /* optional */ } if (line_read_varname (l, varname_B) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if ((v_B = mat_find (varname_B)) == NULL) { WARN_VARIABLE_NOT_DECLARED; return (l); } /* variable MUST be numeric */ if (VAR_IS_STRING (v_B)) { WARN_SYNTAX_ERROR; return (l); } if (line_read_matrix_redim (l, v_B) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (line_skip_RparenChar (l)) { /* optional */ } if (v_B->dimensions != 2) { WARN_SYNTAX_ERROR; return (l); } /* MxN */ if (v_A->LBOUND[0] != v_B->LBOUND[1] || v_A->UBOUND[0] != v_B->UBOUND[1]) { WARN_SYNTAX_ERROR; return (l); } if (v_A->LBOUND[1] != v_B->LBOUND[0] || v_A->UBOUND[1] != v_B->UBOUND[0]) { WARN_SYNTAX_ERROR; return (l); } /* transpose matrix */ for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { VariantType variant; CLEAR_VARIANT (&variant); v_B->VINDEX[1] = i; v_B->VINDEX[0] = j; if (var_get (v_B, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; if (var_set (v_A, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } } else if (line_peek_LparenChar (l)) { /* MAT A = (k) * B */ DoubleType Multiplier; VariableType *v_B; int i; int j; int k; char *E; int p; char varname_B[NameLengthMax + 1]; char *tbuf; tbuf = My->ConsoleInput; bwb_strcpy (tbuf, &(l->buffer[l->position])); E = bwb_strrchr (tbuf, '*'); if (E == NULL) { WARN_SYNTAX_ERROR; return (l); } *E = NulChar; p = 0; if (buff_read_numeric_expression (tbuf, &p, &Multiplier) == FALSE) { WARN_SYNTAX_ERROR; return (l); } l->position += p; if (line_skip_StarChar (l) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (line_read_varname (l, varname_B) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if ((v_B = mat_find (varname_B)) == NULL) { WARN_VARIABLE_NOT_DECLARED; return (l); } /* variable MUST be numeric */ if (VAR_IS_STRING (v_B)) { WARN_SYNTAX_ERROR; return (l); } if (line_read_matrix_redim (l, v_B) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (v_A->dimensions != v_B->dimensions) { WARN_SYNTAX_ERROR; return (l); } /* both arrays are of the same size */ switch (v_A->dimensions) { case 1: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { VariantType variant; CLEAR_VARIANT (&variant); v_B->VINDEX[0] = i; if (var_get (v_B, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } variant.Number *= Multiplier; v_A->VINDEX[0] = i; if (var_set (v_A, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } break; case 2: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { VariantType variant; CLEAR_VARIANT (&variant); v_B->VINDEX[0] = i; v_B->VINDEX[1] = j; if (var_get (v_B, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } variant.Number *= Multiplier; v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; if (var_set (v_A, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } break; case 3: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { for (k = v_A->LBOUND[2]; k <= v_A->UBOUND[2]; k++) { VariantType variant; CLEAR_VARIANT (&variant); v_B->VINDEX[0] = i; v_B->VINDEX[1] = j; v_B->VINDEX[2] = k; if (var_get (v_B, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } variant.Number *= Multiplier; v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; v_A->VINDEX[2] = k; if (var_set (v_A, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } } break; default: WARN_SYNTAX_ERROR; return (l); } } else { /* MAT A = B */ /* MAT A = B + C */ /* MAT A = B - C */ /* MAT A = B * C */ VariableType *v_B; char varname_B[NameLengthMax + 1]; if (line_read_varname (l, varname_B) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if ((v_B = mat_find (varname_B)) == NULL) { WARN_VARIABLE_NOT_DECLARED; return (l); } /* variable MUST be numeric */ if (VAR_IS_STRING (v_B)) { WARN_SYNTAX_ERROR; return (l); } if (line_read_matrix_redim (l, v_B) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (line_is_eol (l)) { /* MAT A = B */ /* OK */ int i; int j; int k; if (v_A->dimensions != v_B->dimensions) { WARN_SYNTAX_ERROR; return (l); } /* both arrays are of the same size */ switch (v_A->dimensions) { case 1: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { VariantType variant; CLEAR_VARIANT (&variant); v_B->VINDEX[0] = i; if (var_get (v_B, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } v_A->VINDEX[0] = i; if (var_set (v_A, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } break; case 2: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { VariantType variant; CLEAR_VARIANT (&variant); v_B->VINDEX[0] = i; v_B->VINDEX[1] = j; if (var_get (v_B, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; if (var_set (v_A, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } break; case 3: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { for (k = v_A->LBOUND[2]; k <= v_A->UBOUND[2]; k++) { VariantType variant; CLEAR_VARIANT (&variant); v_B->VINDEX[0] = i; v_B->VINDEX[1] = j; v_B->VINDEX[2] = k; if (var_get (v_B, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; v_A->VINDEX[2] = k; if (var_set (v_A, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } } break; default: WARN_SYNTAX_ERROR; return (l); } } else if (line_skip_PlusChar (l)) { /* MAT A = B + C */ /* OK */ int i; int j; int k; VariableType *v_C; char varname_C[NameLengthMax + 1]; if (v_A->dimensions != v_B->dimensions) { WARN_SYNTAX_ERROR; return (l); } /* both arrays are of the same size */ if (line_read_varname (l, varname_C) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if ((v_C = mat_find (varname_C)) == NULL) { WARN_VARIABLE_NOT_DECLARED; return (l); } /* variable MUST be numeric */ if (VAR_IS_STRING (v_C)) { WARN_SYNTAX_ERROR; return (l); } if (line_read_matrix_redim (l, v_C) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (v_B->dimensions != v_C->dimensions) { WARN_SYNTAX_ERROR; return (l); } /* both arrays are of the same size */ switch (v_A->dimensions) { case 1: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { VariantType variant_L; VariantType variant_R; CLEAR_VARIANT (&variant_L); CLEAR_VARIANT (&variant_R); v_B->VINDEX[0] = i; if (var_get (v_B, &variant_L) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } v_C->VINDEX[0] = i; if (var_get (v_C, &variant_R) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } variant_L.Number += variant_R.Number; v_A->VINDEX[0] = i; if (var_set (v_A, &variant_L) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } break; case 2: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { VariantType variant_L; VariantType variant_R; CLEAR_VARIANT (&variant_L); CLEAR_VARIANT (&variant_R); v_B->VINDEX[0] = i; v_B->VINDEX[1] = j; if (var_get (v_B, &variant_L) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } v_C->VINDEX[0] = i; v_C->VINDEX[1] = j; if (var_get (v_C, &variant_R) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } variant_L.Number += variant_R.Number; v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; if (var_set (v_A, &variant_L) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } break; case 3: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { for (k = v_A->LBOUND[2]; k <= v_A->UBOUND[2]; k++) { VariantType variant_L; VariantType variant_R; CLEAR_VARIANT (&variant_L); CLEAR_VARIANT (&variant_R); v_B->VINDEX[0] = i; v_B->VINDEX[1] = j; v_B->VINDEX[2] = k; if (var_get (v_B, &variant_L) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } v_C->VINDEX[0] = i; v_C->VINDEX[1] = j; v_C->VINDEX[2] = k; if (var_get (v_C, &variant_R) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } variant_L.Number += variant_R.Number; v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; v_A->VINDEX[2] = k; if (var_set (v_A, &variant_L) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } } break; default: WARN_SYNTAX_ERROR; return (l); } } else if (line_skip_MinusChar (l)) { /* MAT A = B - C */ /* OK */ int i; int j; int k; VariableType *v_C; char varname_C[NameLengthMax + 1]; if (v_A->dimensions != v_B->dimensions) { WARN_SYNTAX_ERROR; return (l); } /* both arrays are of the same size */ if (line_read_varname (l, varname_C) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if ((v_C = mat_find (varname_C)) == NULL) { WARN_VARIABLE_NOT_DECLARED; return (l); } /* variable MUST be numeric */ if (VAR_IS_STRING (v_C)) { WARN_SYNTAX_ERROR; return (l); } if (line_read_matrix_redim (l, v_C) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (v_B->dimensions != v_C->dimensions) { WARN_SYNTAX_ERROR; return (l); } /* both arrays are of the same dimension */ switch (v_A->dimensions) { case 1: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { VariantType variant_L; VariantType variant_R; CLEAR_VARIANT (&variant_L); CLEAR_VARIANT (&variant_R); v_B->VINDEX[0] = i; if (var_get (v_B, &variant_L) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } v_C->VINDEX[0] = i; if (var_get (v_C, &variant_R) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } variant_L.Number -= variant_R.Number; v_A->VINDEX[0] = i; if (var_set (v_A, &variant_L) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } break; case 2: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { VariantType variant_L; VariantType variant_R; CLEAR_VARIANT (&variant_L); CLEAR_VARIANT (&variant_R); v_B->VINDEX[0] = i; v_B->VINDEX[1] = j; if (var_get (v_B, &variant_L) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } v_C->VINDEX[0] = i; v_C->VINDEX[1] = j; if (var_get (v_C, &variant_R) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } variant_L.Number -= variant_R.Number; v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; if (var_set (v_A, &variant_L) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } break; case 3: for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { for (k = v_A->LBOUND[2]; k <= v_A->UBOUND[2]; k++) { VariantType variant_L; VariantType variant_R; CLEAR_VARIANT (&variant_L); CLEAR_VARIANT (&variant_R); v_B->VINDEX[0] = i; v_B->VINDEX[1] = j; v_B->VINDEX[2] = k; if (var_get (v_B, &variant_L) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } v_C->VINDEX[0] = i; v_C->VINDEX[1] = j; v_C->VINDEX[2] = k; if (var_get (v_C, &variant_R) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } variant_L.Number -= variant_R.Number; v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; v_A->VINDEX[2] = k; if (var_set (v_A, &variant_L) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } } break; default: WARN_SYNTAX_ERROR; return (l); } } else if (line_skip_StarChar (l)) { /* MAT A = B * C */ int i; int j; int k; VariableType *v_C; char varname_C[NameLengthMax + 1]; if (v_A->dimensions != 2) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } if (v_B->dimensions != 2) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } if (line_read_varname (l, varname_C) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if ((v_C = mat_find (varname_C)) == NULL) { WARN_VARIABLE_NOT_DECLARED; return (l); } /* variable MUST be numeric */ if (VAR_IS_STRING (v_C)) { WARN_TYPE_MISMATCH; return (l); } if (line_read_matrix_redim (l, v_C) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (v_C->dimensions != 2) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } if (v_A->LBOUND[0] != v_B->LBOUND[0]) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } if (v_A->UBOUND[0] != v_B->UBOUND[0]) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } if (v_A->LBOUND[1] != v_C->LBOUND[1]) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } if (v_A->UBOUND[1] != v_C->UBOUND[1]) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } if (v_B->LBOUND[1] != v_C->LBOUND[0]) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } if (v_B->UBOUND[1] != v_C->UBOUND[0]) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } for (i = v_A->LBOUND[0]; i <= v_A->UBOUND[0]; i++) { for (j = v_A->LBOUND[1]; j <= v_A->UBOUND[1]; j++) { VariantType variant_A; CLEAR_VARIANT (&variant_A); variant_A.VariantTypeCode = v_A->VariableTypeCode; variant_A.Number = 0; v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; if (var_set (v_A, &variant_A) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } for (k = v_C->LBOUND[0]; k <= v_C->UBOUND[0]; k++) { VariantType variant_B; VariantType variant_C; CLEAR_VARIANT (&variant_B); CLEAR_VARIANT (&variant_C); v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; if (var_get (v_A, &variant_A) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } v_B->VINDEX[0] = i; v_B->VINDEX[1] = k; if (var_get (v_B, &variant_B) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } v_C->VINDEX[0] = k; v_C->VINDEX[1] = j; if (var_get (v_C, &variant_C) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } variant_A.Number += variant_B.Number * variant_C.Number; v_A->VINDEX[0] = i; v_A->VINDEX[1] = j; if (var_set (v_A, &variant_A) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } } } } } else { WARN_SYNTAX_ERROR; return (l); } } return (l); } /* -------------------------------------------------------------------------------------------- STORE -------------------------------------------------------------------------------------------- */ LineType * bwb_STORE (LineType * l) { /* SYNTAX: STORE NumericArrayName */ assert (l != NULL); return bwb_CSAVE8 (l); } /* -------------------------------------------------------------------------------------------- CSAVE* -------------------------------------------------------------------------------------------- */ #define CSAVE_VERSION_1 0x20150218L LineType * bwb_CSAVE8 (LineType * l) { /* SYNTAX: CSAVE* NumericArrayName */ VariableType *v = NULL; FILE *f; unsigned long n; size_t t; char varname[NameLengthMax + 1]; assert (l != NULL); if (line_read_varname (l, varname) == FALSE) { WARN_SYNTAX_ERROR; return (l); } v = mat_find (varname); if (v == NULL) { WARN_VARIABLE_NOT_DECLARED; return (l); } /* variable MUST be numeric */ if (VAR_IS_STRING (v)) { WARN_SYNTAX_ERROR; return (l); } /* variable MUST be an array */ if (v->dimensions == 0) { WARN_SYNTAX_ERROR; return (l); } if (line_read_matrix_redim (l, v) == FALSE) { WARN_SYNTAX_ERROR; return (l); } /* variable storage is a mess, we bypass that tradition here. */ t = v->array_units; if (t <= 1) { WARN_SYNTAX_ERROR; return (l); } /* open file */ f = fopen (v->name, "w"); if (f == NULL) { WARN_SYNTAX_ERROR; return (l); } /* write version number */ n = CSAVE_VERSION_1; fwrite (&n, sizeof (long), 1, f); /* write total number of elements */ fwrite (&t, sizeof (long), 1, f); /* write data */ fwrite (v->Value.Number, sizeof (DoubleType), t, f); /* OK */ bwb_fclose (f); return (l); } /* -------------------------------------------------------------------------------------------- RECALL -------------------------------------------------------------------------------------------- */ LineType * bwb_RECALL (LineType * l) { /* SYNTAX: RECALL NumericArrayName */ assert (l != NULL); return bwb_CLOAD8 (l); } /* -------------------------------------------------------------------------------------------- CLOAD* -------------------------------------------------------------------------------------------- */ LineType * bwb_CLOAD8 (LineType * l) { /* SYNTAX: CLOAD* NumericArrayName */ VariableType *v = NULL; FILE *f; unsigned long n; size_t t; char varname[NameLengthMax + 1]; assert (l != NULL); if (line_read_varname (l, varname) == FALSE) { WARN_SYNTAX_ERROR; return (l); } v = mat_find (varname); if (v == NULL) { WARN_VARIABLE_NOT_DECLARED; return (l); } /* variable MUST be numeric */ if (VAR_IS_STRING (v)) { WARN_SYNTAX_ERROR; return (l); } /* variable MUST be an array */ if (v->dimensions == 0) { WARN_SYNTAX_ERROR; return (l); } if (line_read_matrix_redim (l, v) == FALSE) { WARN_SYNTAX_ERROR; return (l); } /* variable storage is a mess, we bypass that tradition here. */ t = v->array_units; if (t <= 1) { WARN_SYNTAX_ERROR; return (l); } /* open file */ f = fopen (v->name, "r"); if (f == NULL) { WARN_BAD_FILE_NAME; return (l); } /* read version number */ n = 0; fread (&n, sizeof (long), 1, f); if (n != CSAVE_VERSION_1) { bwb_fclose (f); WARN_BAD_FILE_NAME; return (l); } /* read total number of elements */ n = 0; fread (&n, sizeof (long), 1, f); if (n != t) { bwb_fclose (f); WARN_BAD_FILE_NAME; return (l); } /* read data */ fread (v->Value.Number, sizeof (DoubleType), t, f); /* OK */ bwb_fclose (f); return (l); } /* ============================================================================================ SAVE and so on ============================================================================================ */ static LineType * bwb_save (LineType * Line, char *Prompt) { /* SYNTAX: SAVE [filename$] */ FILE *outfile; assert (Line != NULL); assert (Prompt != NULL); assert( My != NULL ); assert( My->ConsoleInput != NULL ); assert( My->SYSOUT != NULL ); assert( My->SYSOUT->cfp != NULL ); /* Get an argument for filename */ if (line_is_eol (Line)) { /* default is the last filename used by LOAD or SAVE */ if (is_empty_string (My->ProgramFilename) && Prompt != NULL) { /* prompt for the program name */ char *tbuf; int tlen; tbuf = My->ConsoleInput; tlen = MAX_LINE_LENGTH; bwx_input (Prompt, FALSE, tbuf, tlen); if (is_empty_string (tbuf)) { WARN_BAD_FILE_NAME; return (Line); } if (My->ProgramFilename != NULL) { free (My->ProgramFilename); My->ProgramFilename = NULL; } My->ProgramFilename = bwb_strdup (tbuf); } assert( My->ProgramFilename != NULL ); fprintf (My->SYSOUT->cfp, "Saving %s\n", My->ProgramFilename); ResetConsoleColumn (); } else { char *Value; Value = NULL; if (line_read_string_expression (Line, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (Line); } if (is_empty_string (Value)) { WARN_BAD_FILE_NAME; return (Line); } if (My->ProgramFilename != NULL) { free (My->ProgramFilename); } My->ProgramFilename = Value; } assert( My->ProgramFilename != NULL ); if ((outfile = fopen (My->ProgramFilename, "w")) == NULL) { WARN_BAD_FILE_NAME; return (Line); } bwb_xlist (Line, outfile); bwb_fclose (outfile); return (Line); } /* -------------------------------------------------------------------------------------------- CSAVE -------------------------------------------------------------------------------------------- */ LineType * bwb_CSAVE (LineType * Line) { /* SYNTAX: CSAVE [filename$] */ assert (Line != NULL); return bwb_save (Line, "CSAVE FILE NAME:"); } /* -------------------------------------------------------------------------------------------- REPLACE -------------------------------------------------------------------------------------------- */ LineType * bwb_REPLACE (LineType * Line) { /* SYNTAX: REPLACE [filename$] */ assert (Line != NULL); return bwb_save (Line, "REPLACE FILE NAME:"); } /* -------------------------------------------------------------------------------------------- SAVE -------------------------------------------------------------------------------------------- */ LineType * bwb_SAVE (LineType * l) { /* SYNTAX: SAVE [filename$] */ assert (l != NULL); return bwb_save (l, "SAVE FILE NAME:"); } /* -------------------------------------------------------------------------------------------- TSAVE -------------------------------------------------------------------------------------------- */ LineType * bwb_TSAVE (LineType * Line) { /* SYNTAX: TSAVE [filename$] */ assert (Line != NULL); return bwb_save (Line, "TSAVE FILE NAME:"); } /* ============================================================================================ LIST and so on ============================================================================================ */ static int xl_line (FILE * file, LineType * l) { char LineExecuted; char *C; /* start of comment text */ char *buffer; /* 0...99999 */ assert (file != NULL); assert (l != NULL); assert( My != NULL ); assert( My->NumLenBuffer != NULL ); assert( My->CurrentVersion != NULL ); assert( My->SYSOUT != NULL ); assert( My->SYSOUT->cfp != NULL ); assert( My->SYSPRN != NULL ); assert( My->SYSPRN->cfp != NULL ); /* ** The only difference between LIST, LLIST and SAVE is: ** LIST and LLIST display an '*' ** when a line has been executed ** and OPTION COVERAGE ON is enabled. */ buffer = My->NumLenBuffer; LineExecuted = ' '; if (My->CurrentVersion->OptionFlags & (OPTION_COVERAGE_ON)) { if (l->LineFlags & LINE_EXECUTED) { if (file == My->SYSOUT->cfp || file == My->SYSPRN->cfp) { /* LIST */ /* LLIST */ LineExecuted = '*'; } else { /* SAVE */ /* EDIT implies SAVE */ } } } C = l->buffer; if (l->LineFlags & LINE_NUMBERED) { /* explicitly numbered */ sprintf (buffer, "%*d", LineNumberDigits, l->number); /* ##### xxx */ } else { /* implicitly numbered */ if (My->LastLineNumber == l->number) { /* multi-statement line */ if (l->cmdnum == C_REM && IS_CHAR (l->buffer[0], My->CurrentVersion->OptionCommentChar)) { /* trailing comment */ sprintf (buffer, "%*s%c", LineNumberDigits - 1, "", My->CurrentVersion->OptionCommentChar); C++; /* skip comment char */ while (*C == ' ') { /* skip spaces */ C++; } /* ____' xxx */ } else if (My->CurrentVersion->OptionStatementChar) { /* all other commands, add a colon */ sprintf (buffer, "%*s%c", LineNumberDigits - 1, "", My->CurrentVersion->OptionStatementChar); /* ____: xxx */ } else { /* The user is trying to list a multi-line statement in a dialect that does NOT support multi-line statements. This could occur when LOADing in one dialect and then SAVEing as another dialect, such as: OPTION VERSION BASIC-80 LOAD "TEST1.BAS" 100 REM TEST 110 PRINT:PRINT:PRINT OPTION VERSION MARK-I EDIT 100 REM TEST 110 PRINT PRINT PRINT The only thing we can reasonably do is put spaces for the line number, since the user will have to edit the results manually anyways. */ sprintf (buffer, "%*s", LineNumberDigits, ""); /* _____ xxx */ } } else { /* single-statement line */ sprintf (buffer, "%*s", LineNumberDigits, ""); /* _____ xxx */ } } fprintf (file, "%s", buffer); fprintf (file, "%c", LineExecuted); /* if( TRUE ) */ { /* %INCLUDE */ int i; for (i = 0; i < l->IncludeLevel; i++) { fputc (' ', file); } } if (My->OptionIndentInteger > 0) { int i; for (i = 0; i < l->Indention; i++) { int j; for (j = 0; j < My->OptionIndentInteger; j++) { fputc (' ', file); } } } fprintf (file, "%s\n", C); My->LastLineNumber = l->number; return TRUE; } static LineType * bwb_xlist (LineType * l, FILE * file) { assert (l != NULL); assert (file != NULL); assert( My != NULL ); assert( My->StartMarker != NULL ); assert( My->EndMarker != NULL ); /* ** ** FORCE SCAN ** */ if (bwb_scan () == FALSE) { /* ** ** we are used by bwb_SAVE and bwb_EDIT ** WARN_CANT_CONTINUE; return (l); */ } if (line_is_eol (l)) { /* LIST */ LineType *x; /* now go through and list appropriate lines */ My->LastLineNumber = -1; for (x = My->StartMarker->next; x != My->EndMarker; x = x->next) { xl_line (file, x); } fprintf (file, "\n"); } else { do { int head; int tail; if (line_read_line_sequence (l, &head, &tail)) { /* LIST 's' - 'e' */ LineType *x; if (head < MINLIN || head > MAXLIN) { WARN_UNDEFINED_LINE; return (l); } if (tail < MINLIN || tail > MAXLIN) { WARN_UNDEFINED_LINE; return (l); } if (head > tail) { WARN_UNDEFINED_LINE; return (l); } /* valid range */ /* now go through and list appropriate lines */ My->LastLineNumber = -1; for (x = My->StartMarker->next; x != My->EndMarker; x = x->next) { if (head <= x->number && x->number <= tail) { xl_line (file, x); } } fprintf (file, "\n"); } else { WARN_SYNTAX_ERROR; return (l); } } while (line_skip_seperator (l)); } if (file == My->SYSOUT->cfp) { ResetConsoleColumn (); } return (l); } /* -------------------------------------------------------------------------------------------- LIST -------------------------------------------------------------------------------------------- */ LineType * bwb_LIST (LineType * l) { /* SYNTAX: LIST SYNTAX: LIST line [,...] SYNTAX: LIST line - line */ assert (l != NULL); return bwb_xlist (l, My->SYSOUT->cfp); } /* -------------------------------------------------------------------------------------------- LISTNH -------------------------------------------------------------------------------------------- */ LineType * bwb_LISTNH (LineType * l) { /* SYNTAX: LISTNH SYNTAX: LISTNH line [,...] SYNTAX: LISTNH line - line */ assert (l != NULL); return bwb_xlist (l, My->SYSOUT->cfp); } /* -------------------------------------------------------------------------------------------- LLIST -------------------------------------------------------------------------------------------- */ LineType * bwb_LLIST (LineType * l) { /* SYNTAX: LLIST SYNTAX: LLIST line [,...] SYNTAX: LLIST line - line */ assert (l != NULL); return bwb_xlist (l, My->SYSPRN->cfp); } /* ============================================================================================ DELETE and so on ============================================================================================ */ static LineType * bwb_delete (LineType * l) { assert (l != NULL); assert( My != NULL ); assert( My->CurrentVersion != NULL ); assert( My->StartMarker != NULL ); assert( My->EndMarker != NULL ); if (line_is_eol (l)) { /* DELETE */ WARN_SYNTAX_ERROR; return (l); } else if (My->CurrentVersion->OptionVersionValue & (C77)) { /* SYNTAX: DELETE filenum [,...] */ do { int FileNumber; FileNumber = 0; if (line_read_integer_expression (l, &FileNumber) == FALSE) { WARN_BAD_FILE_NUMBER; return (l); } if (FileNumber <= 0) { WARN_BAD_FILE_NUMBER; return (l); } My->CurrentFile = find_file_by_number (FileNumber); if (My->CurrentFile == NULL) { WARN_BAD_FILE_NUMBER; return (l); } if (My->CurrentFile->DevMode == DEVMODE_CLOSED) { WARN_BAD_FILE_NUMBER; return (l); } if (My->CurrentFile->cfp != NULL) { bwb_fclose (My->CurrentFile->cfp); My->CurrentFile->cfp = NULL; } if (My->CurrentFile->buffer != NULL) { free (My->CurrentFile->buffer); My->CurrentFile->buffer = NULL; } My->CurrentFile->width = 0; My->CurrentFile->col = 1; My->CurrentFile->row = 1; My->CurrentFile->delimit = ','; My->CurrentFile->DevMode = DEVMODE_CLOSED; if (My->CurrentFile->FileName == NULL) { WARN_BAD_FILE_NAME; return (l); } remove (My->CurrentFile->FileName); free (My->CurrentFile->FileName); My->CurrentFile->FileName = NULL; } while (line_skip_seperator (l)); /* OK */ return (l); } else { /* SYNTAX: DELETE line [,...] SYNTAX: DELETE line - line */ do { int head; int tail; if (line_read_line_sequence (l, &head, &tail)) { /* DELETE 's' - 'e' */ LineType *x; LineType *previous; if (head < MINLIN || head > MAXLIN) { WARN_UNDEFINED_LINE; return (l); } if (tail < MINLIN || tail > MAXLIN) { WARN_UNDEFINED_LINE; return (l); } if (head > tail) { WARN_UNDEFINED_LINE; return (l); } /* valid range */ /* avoid deleting ourself */ if (l->LineFlags & (LINE_USER)) { /* console line (immediate mode) */ } else if (head <= l->number && l->number <= tail) { /* 100 DELETE 100 */ WARN_CANT_CONTINUE; return (l); } /* now go through and list appropriate lines */ previous = My->StartMarker; for (x = My->StartMarker->next; x != My->EndMarker;) { LineType *next; next = x->next; if (x->number < head) { previous = x; } else if (head <= x->number && x->number <= tail) { if (x == l) { /* 100 DELETE 100 */ WARN_CANT_CONTINUE; return (l); } bwb_freeline (x); previous->next = next; } x = next; } } else { WARN_SYNTAX_ERROR; return (l); } } while (line_skip_seperator (l)); /* ** ** FORCE SCAN ** */ if (bwb_scan () == FALSE) { WARN_CANT_CONTINUE; return (l); } } return (l); } /* -------------------------------------------------------------------------------------------- DELETE -------------------------------------------------------------------------------------------- */ LineType * bwb_DELETE (LineType * l) { assert (l != NULL); return bwb_delete (l); } /* -------------------------------------------------------------------------------------------- PDEL -------------------------------------------------------------------------------------------- */ LineType * bwb_PDEL (LineType * l) { assert (l != NULL); return bwb_delete (l); } #if FALSE /* keep the source to DONUM and DOUNNUM */ /* -------------------------------------------------------------------------------------------- DONUM -------------------------------------------------------------------------------------------- */ LineType * bwb_donum (LineType * l) { /* SYNTAX: DONUM */ LineType *current; int lnumber; assert (l != NULL); assert( My != NULL ); assert( My->StartMarker != NULL ); assert( My->EndMarker != NULL ); lnumber = 10; for (current = My->StartMarker->next; current != My->EndMarker; current = current->next) { current->number = lnumber; lnumber += 10; if (lnumber > MAXLIN) { return (l); } } return (l); } /* -------------------------------------------------------------------------------------------- DOUNUM -------------------------------------------------------------------------------------------- */ LineType * bwb_dounnum (LineType * l) { /* SYNTAX: DOUNNUM */ LineType *current; assert (l != NULL); assert( My != NULL ); assert( My->StartMarker != NULL ); assert( My->EndMarker != NULL ); for (current = My->StartMarker->next; current != My->EndMarker; current = current->next) { current->number = 0; } return (l); } #endif /* FALSE */ /* -------------------------------------------------------------------------------------------- FILES -------------------------------------------------------------------------------------------- */ LineType * bwb_FILES (LineType * l) { /* SYNTAX: FILES A$ [, ...] */ /* open a list of files in READ mode */ assert (l != NULL); assert( My != NULL ); do { int FileNumber; FileNumber = My->LastFileNumber; FileNumber++; if (FileNumber < 0) { WARN_BAD_FILE_NUMBER; return (l); } if (FileNumber == 0) { WARN_BAD_FILE_NUMBER; return (l); } My->CurrentFile = find_file_by_number (FileNumber); if (My->CurrentFile == NULL) { My->CurrentFile = file_new (); My->CurrentFile->FileNumber = FileNumber; } { char *Value; Value = NULL; if (line_read_string_expression (l, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (Value == NULL) { WARN_SYNTAX_ERROR; return (l); } if (My->CurrentFile->FileName != NULL) { free (My->CurrentFile->FileName); My->CurrentFile->FileName = NULL; } My->CurrentFile->FileName = Value; Value = NULL; } if (My->CurrentFile->DevMode != DEVMODE_CLOSED) { My->CurrentFile->DevMode = DEVMODE_CLOSED; } if (My->CurrentFile->cfp != NULL) { bwb_fclose (My->CurrentFile->cfp); My->CurrentFile->cfp = NULL; } if (My->CurrentFile->buffer != NULL) { free (My->CurrentFile->buffer); My->CurrentFile->buffer = NULL; } My->CurrentFile->width = 0; My->CurrentFile->col = 1; My->CurrentFile->row = 1; My->CurrentFile->delimit = ','; if (is_empty_string (My->CurrentFile->FileName)) { WARN_BAD_FILE_NAME; return (l); } if (bwb_strcmp (My->CurrentFile->FileName, "*") != 0) { if ((My->CurrentFile->cfp = fopen (My->CurrentFile->FileName, "r")) == NULL) { WARN_BAD_FILE_NAME; return (l); } My->CurrentFile->DevMode = DEVMODE_INPUT; } My->LastFileNumber = FileNumber; /* OK */ } while (line_skip_seperator (l)); return (l); } /* -------------------------------------------------------------------------------------------- FILE -------------------------------------------------------------------------------------------- */ LineType * bwb_FILE (LineType * l) { assert (l != NULL); assert( My != NULL ); assert( My->CurrentVersion != NULL ); if (My->CurrentVersion->OptionVersionValue & (C77)) { /* CBASIC-II: FILE file_name$ ' filename$ must be a simple string scalar (no arrays) FILE file_name$ ( record_length% ) ' filename$ must be a simple string scalar (no arrays) -- if the file exists, then it is used, else it is created. -- Does not trigger IF END # */ do { int FileNumber; VariableType *v; char varname[NameLengthMax + 1]; if (line_read_varname (l, varname) == FALSE) { WARN_BAD_FILE_NAME; return (l); } if (is_empty_string (varname)) { WARN_BAD_FILE_NAME; return (l); } v = find_variable_by_type (varname, 0, StringTypeCode); if (v == NULL) { WARN_VARIABLE_NOT_DECLARED; return (l); } if (VAR_IS_STRING (v)) { /* OK */ } else { WARN_TYPE_MISMATCH; return (l); } FileNumber = My->LastFileNumber; FileNumber++; if (FileNumber < 0) { WARN_BAD_FILE_NUMBER; return (l); } if (FileNumber == 0) { WARN_BAD_FILE_NUMBER; return (l); } My->CurrentFile = find_file_by_number (FileNumber); if (My->CurrentFile == NULL) { My->CurrentFile = file_new (); My->CurrentFile->FileNumber = FileNumber; } if (My->CurrentFile->DevMode != DEVMODE_CLOSED) { My->CurrentFile->DevMode = DEVMODE_CLOSED; } if (My->CurrentFile->cfp != NULL) { bwb_fclose (My->CurrentFile->cfp); My->CurrentFile->cfp = NULL; } if (My->CurrentFile->buffer != NULL) { free (My->CurrentFile->buffer); My->CurrentFile->buffer = NULL; } My->CurrentFile->width = 0; My->CurrentFile->col = 1; My->CurrentFile->row = 1; My->CurrentFile->delimit = ','; /* OK */ if (line_skip_LparenChar (l)) { /* RANDOM file */ int RecLen; if (line_read_integer_expression (l, &RecLen) == FALSE) { WARN_FIELD_OVERFLOW; return (l); } if (RecLen <= 0) { WARN_FIELD_OVERFLOW; return (l); } if (line_skip_RparenChar (l) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if ((My->CurrentFile->buffer = (char *) calloc (RecLen + 1 /* NulChar */ , sizeof (char))) == NULL) { WARN_OUT_OF_MEMORY; return (l); } My->CurrentFile->width = RecLen; } /* if( TRUE ) */ { VariantType variant; CLEAR_VARIANT (&variant); if (var_get (v, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return (l); } if (variant.VariantTypeCode == StringTypeCode) { if (My->CurrentFile->FileName != NULL) { free (My->CurrentFile->FileName); My->CurrentFile->FileName = NULL; } My->CurrentFile->FileName = variant.Buffer; variant.Buffer = NULL; } else { WARN_TYPE_MISMATCH; return (l); } } if (is_empty_string (My->CurrentFile->FileName)) { WARN_BAD_FILE_NAME; return (l); } My->CurrentFile->cfp = fopen (My->CurrentFile->FileName, "r+"); if (My->CurrentFile->cfp == NULL) { My->CurrentFile->cfp = fopen (My->CurrentFile->FileName, "w"); if (My->CurrentFile->cfp != NULL) { bwb_fclose (My->CurrentFile->cfp); My->CurrentFile->cfp = fopen (My->CurrentFile->FileName, "r+"); } } if (My->CurrentFile->cfp == NULL) { WARN_BAD_FILE_NAME; return (l); } if (My->CurrentFile->width > 0) { /* RANDOM file */ My->CurrentFile->DevMode = DEVMODE_RANDOM; } else { /* SERIAL file */ My->CurrentFile->DevMode = DEVMODE_INPUT | DEVMODE_OUTPUT; } /* OK */ My->LastFileNumber = FileNumber; } while (line_skip_seperator (l)); /* OK */ return (l); } if (line_skip_FilenumChar (l)) { /* SYNTAX: FILE # X, A$ */ int FileNumber; if (line_read_integer_expression (l, &FileNumber) == FALSE) { WARN_BAD_FILE_NUMBER; return (l); } if (line_skip_seperator (l)) { /* OK */ } else { WARN_SYNTAX_ERROR; return (l); } if (FileNumber < 0) { /* "FILE # -1" is an ERROR */ WARN_BAD_FILE_NUMBER; return (l); } if (FileNumber == 0) { /* "FILE # 0" is an ERROR */ WARN_BAD_FILE_NUMBER; return (l); } My->CurrentFile = find_file_by_number (FileNumber); if (My->CurrentFile == NULL) { My->CurrentFile = file_new (); My->CurrentFile->FileNumber = FileNumber; } { char *Value; Value = NULL; if (line_read_string_expression (l, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (Value == NULL) { WARN_SYNTAX_ERROR; return (l); } if (My->CurrentFile->FileName != NULL) { free (My->CurrentFile->FileName); My->CurrentFile->FileName = NULL; } My->CurrentFile->FileName = Value; Value = NULL; } if (My->CurrentFile->DevMode != DEVMODE_CLOSED) { My->CurrentFile->DevMode = DEVMODE_CLOSED; } if (My->CurrentFile->cfp != NULL) { bwb_fclose (My->CurrentFile->cfp); My->CurrentFile->cfp = NULL; } if (My->CurrentFile->buffer != NULL) { free (My->CurrentFile->buffer); My->CurrentFile->buffer = NULL; } My->CurrentFile->width = 0; My->CurrentFile->col = 1; My->CurrentFile->row = 1; My->CurrentFile->delimit = ','; if (is_empty_string (My->CurrentFile->FileName)) { WARN_BAD_FILE_NAME; return (l); } if (bwb_strcmp (My->CurrentFile->FileName, "*") != 0) { if ((My->CurrentFile->cfp = fopen (My->CurrentFile->FileName, "r")) == NULL) { WARN_BAD_FILE_NAME; return (l); } My->CurrentFile->DevMode = DEVMODE_INPUT; } /* OK */ return (l); } WARN_SYNTAX_ERROR; return (l); } /* -------------------------------------------------------------------------------------------- DELIMIT -------------------------------------------------------------------------------------------- */ LineType * bwb_DELIMIT (LineType * l) { /* SYNTAX: DELIMIT # X, A$ */ assert (l != NULL); assert( My != NULL ); assert( My->SYSIN != NULL ); if (line_skip_FilenumChar (l)) { /* DELIMIT # */ int FileNumber; char delimit; My->CurrentFile = My->SYSIN; if (line_read_integer_expression (l, &FileNumber) == FALSE) { WARN_BAD_FILE_NUMBER; return (l); } if (line_skip_seperator (l)) { /* OK */ } else { WARN_SYNTAX_ERROR; return (l); } { char *Value; Value = NULL; if (line_read_string_expression (l, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (Value == NULL) { WARN_SYNTAX_ERROR; return (l); } delimit = Value[0]; free (Value); Value = NULL; if (bwb_ispunct (delimit)) { /* OK */ } else { WARN_ILLEGAL_FUNCTION_CALL; return (l); } } if (FileNumber < 0) { /* "DELIMIT # -1" is SYSPRN */ My->SYSPRN->delimit = delimit; return (l); } if (FileNumber == 0) { /* "DELIMIT # 0" is SYSOUT */ My->SYSOUT->delimit = delimit; return (l); } /* normal file */ My->CurrentFile = find_file_by_number (FileNumber); if (My->CurrentFile == NULL) { WARN_BAD_FILE_NUMBER; return (l); } My->CurrentFile->delimit = delimit; /* OK */ return (l); } WARN_SYNTAX_ERROR; return (l); } /* -------------------------------------------------------------------------------------------- MARGIN -------------------------------------------------------------------------------------------- */ LineType * bwb_MARGIN (LineType * l) { /* SYNTAX: MARGIN # X, Y */ /* set width for OUTPUT */ int FileNumber; int Value; assert (l != NULL); assert( My != NULL ); assert( My->SYSIN != NULL ); if (line_skip_FilenumChar (l)) { /* MARGIN # */ My->CurrentFile = My->SYSIN; if (line_read_integer_expression (l, &FileNumber) == FALSE) { WARN_BAD_FILE_NUMBER; return (l); } if (line_skip_seperator (l)) { /* OK */ } else { WARN_SYNTAX_ERROR; return (l); } if (line_read_integer_expression (l, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (Value < 0) { WARN_ILLEGAL_FUNCTION_CALL; return (l); } if (FileNumber < 0) { /* "MARGIN # -1" is SYSPRN */ My->SYSPRN->width = Value; return (l); } if (FileNumber == 0) { /* "MARGIN # 0" is SYSOUT */ My->SYSOUT->width = Value; return (l); } /* normal file */ My->CurrentFile = find_file_by_number (FileNumber); if (My->CurrentFile == NULL) { WARN_BAD_FILE_NUMBER; return (l); } if ((My->CurrentFile->DevMode & DEVMODE_WRITE) == 0) { WARN_BAD_FILE_NUMBER; return (l); } My->CurrentFile->width = Value; /* OK */ return (l); } WARN_SYNTAX_ERROR; return (l); } /* -------------------------------------------------------------------------------------------- USE -------------------------------------------------------------------------------------------- */ LineType * bwb_USE (LineType * l) { /* SYNTAX: USE parameter$ ' CALL/360, System/360, System/370 */ VariableType *v; assert (l != NULL); assert( My != NULL ); if ((v = line_read_scalar (l)) == NULL) { WARN_SYNTAX_ERROR; return (l); } if (v->VariableTypeCode != StringTypeCode) { WARN_SYNTAX_ERROR; return (l); } /* OK */ if (My->UseParameterString) { VariantType variant; CLEAR_VARIANT (&variant); variant.VariantTypeCode = StringTypeCode; variant.Buffer = My->UseParameterString; variant.Length = bwb_strlen (My->UseParameterString); var_set (v, &variant); } return (l); } /* -------------------------------------------------------------------------------------------- CHAIN -------------------------------------------------------------------------------------------- */ LineType * bwb_CHAIN (LineType * l) { /* SYNTAX: CHAIN file-name$ [, linenumber] ' most dialects SYNTAX: CHAIN file-name$ [, parameter$] ' CALL/360, System/360, System/370 */ /* originally based upon bwb_load() */ int LineNumber; LineType *x; assert (l != NULL); assert( My != NULL ); assert( My->CurrentVersion != NULL ); assert( My->StartMarker != NULL ); assert( My->EndMarker != NULL ); /* Get an argument for filename */ if (line_is_eol (l)) { WARN_BAD_FILE_NAME; return (l); } else { char *Value; Value = NULL; if (line_read_string_expression (l, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (is_empty_string (Value)) { WARN_BAD_FILE_NAME; return (l); } if (My->ProgramFilename != NULL) { free (My->ProgramFilename); My->ProgramFilename = NULL; } My->ProgramFilename = Value; } /* optional linenumber */ LineNumber = 0; if (line_skip_seperator (l)) { if (My->CurrentVersion->OptionVersionValue & (S70 | I70 | I73)) { /* CHAIN filename$, parameter$ */ { char *Value; Value = NULL; if (line_read_string_expression (l, &Value) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (Value == NULL) { WARN_SYNTAX_ERROR; return (l); } if (My->UseParameterString) { free (My->UseParameterString); My->UseParameterString = NULL; } My->UseParameterString = Value; } } else { /* CHAIN filename$, linenumber */ if (line_read_integer_expression (l, &LineNumber) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (LineNumber < MINLIN || LineNumber > MAXLIN) { WARN_UNDEFINED_LINE; return (l); } } } /* deallocate all variables except common ones */ var_delcvars (); /* remove old program from memory */ bwb_xnew (My->StartMarker); /* load new program in memory */ if (bwb_fload (NULL) == FALSE) { WARN_BAD_FILE_NAME; return (l); } /* FIXME */ x = My->StartMarker; if (MINLIN <= LineNumber && LineNumber <= MAXLIN) { /* search for a matching line number */ while (x->number != LineNumber && x != My->EndMarker) { x = x->next; } if (x == My->EndMarker) { /* NOT FOUND */ x = My->StartMarker; } } x->position = 0; /* ** ** FORCE SCAN ** */ if (bwb_scan () == FALSE) { WARN_CANT_CONTINUE; return (l); } /* reset all stack counters */ bwb_clrexec (); if (bwb_incexec ()) { /* OK */ My->StackHead->line = x; My->StackHead->ExecCode = EXEC_NORM; } else { /* ERROR */ WARN_OUT_OF_MEMORY; return My->EndMarker; } /* run the program */ /* CHAIN */ WARN_CLEAR; /* bwb_CHAIN */ My->ContinueLine = NULL; SetOnError (0); return x; } /* -------------------------------------------------------------------------------------------- APPEND -------------------------------------------------------------------------------------------- */ LineType * bwb_APPEND (LineType * l) { /* SYNTAX: APPEND # filenumber ' Dartmouth, Mark-I, Mark-II, GCOS SYNTAX: APPEND [filename$] ' all others */ assert (l != NULL); assert( My != NULL ); assert( My->CurrentVersion != NULL ); if (My->CurrentVersion->OptionVersionValue & (D64 | G65 | G67 | G74)) { if (line_skip_FilenumChar (l)) { /* APPEND # filenumber */ int FileNumber; if (line_read_integer_expression (l, &FileNumber) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (FileNumber < 0) { /* "APPEND # -1" is silently ignored */ return (l); } if (FileNumber == 0) { /* "APPEND # 0" is silently ignored */ return (l); } My->CurrentFile = find_file_by_number (FileNumber); if (My->CurrentFile == NULL) { WARN_BAD_FILE_NUMBER; return (l); } /* normal file */ fseek (My->CurrentFile->cfp, 0, SEEK_END); My->CurrentFile->DevMode = DEVMODE_APPEND; /* OK */ return (l); } } /* APPEND filename$ */ return bwb_load (l, "APPEND FILE NAME:", FALSE); } /* -------------------------------------------------------------------------------------------- ON ERROR and so on -------------------------------------------------------------------------------------------- */ extern void SetOnError (int LineNumber) { /* scan the stack looking for a FUNCTION/SUB */ StackType *StackItem; assert( My != NULL ); if (My->StackHead == NULL) { return; } for (StackItem = My->StackHead; StackItem->next != NULL; StackItem = StackItem->next) { LineType *current; current = StackItem->LoopTopLine; if (current != NULL) { switch (current->cmdnum) { case C_FUNCTION: case C_SUB: /* FOUND */ /* we are in a FUNCTION/SUB, so this is LOCAL */ StackItem->OnErrorGoto = LineNumber; return; /* break; */ } } } /* StackItem->next == NULL */ /* NOT FOUND */ /* we are NOT in a FUNCTION/SUB */ assert (StackItem != NULL); StackItem->OnErrorGoto = LineNumber; } extern int GetOnError (void) { /* scan the stack looking for an active "ON ERROR GOTO linenumber" */ StackType *StackItem; assert( My != NULL ); for (StackItem = My->StackHead; StackItem != NULL; StackItem = StackItem->next) { if (StackItem->OnErrorGoto != 0) { /* FOUND */ return StackItem->OnErrorGoto; } } /* NOT FOUND */ return 0; } /* -------------------------------------------------------------------------------------------- ON ERROR -------------------------------------------------------------------------------------------- */ LineType * bwb_ON_ERROR (LineType * l) { assert (l != NULL); WARN_SYNTAX_ERROR; return (l); } /* -------------------------------------------------------------------------------------------- ON ERROR GOTO -------------------------------------------------------------------------------------------- */ LineType * bwb_ON_ERROR_GOTO (LineType * l) { /* ON ERROR GOTO line */ int LineNumber; assert (l != NULL); WARN_CLEAR; /* bwb_ON_ERROR_GOTO */ /* get the line number */ LineNumber = 0; if (line_is_eol (l)) { /* ON ERROR GOTO */ SetOnError (0); return (l); } if (line_read_integer_expression (l, &LineNumber) == FALSE) { WARN_SYNTAX_ERROR; return (l); } /* ON ERORR GOTO linenumber */ if (LineNumber == 0) { /* ON ERROR GOTO 0 */ SetOnError (0); return (l); } if (LineNumber < MINLIN || LineNumber > MAXLIN) { /* ERROR */ WARN_UNDEFINED_LINE; return (l); } /* OK */ SetOnError (LineNumber); return (l); } /* -------------------------------------------------------------------------------------------- ON ERROR GOSUB -------------------------------------------------------------------------------------------- */ LineType * bwb_ON_ERROR_GOSUB (LineType * l) { /* ON ERROR GOSUB line */ assert (l != NULL); return bwb_ON_ERROR_GOTO (l); } /* -------------------------------------------------------------------------------------------- ON ERROR RESUME -------------------------------------------------------------------------------------------- */ LineType * bwb_ON_ERROR_RESUME (LineType * l) { assert (l != NULL); WARN_SYNTAX_ERROR; return (l); } /* -------------------------------------------------------------------------------------------- ON ERROR RESUME NEXT -------------------------------------------------------------------------------------------- */ LineType * bwb_ON_ERROR_RESUME_NEXT (LineType * l) { assert (l != NULL); WARN_CLEAR; /* bwb_ON_ERROR_RESUME_NEXT */ SetOnError (-1); return (l); } /* -------------------------------------------------------------------------------------------- ON ERROR RETURN -------------------------------------------------------------------------------------------- */ LineType * bwb_ON_ERROR_RETURN (LineType * l) { assert (l != NULL); WARN_SYNTAX_ERROR; return (l); } /* -------------------------------------------------------------------------------------------- ON ERROR RETURN NEXT -------------------------------------------------------------------------------------------- */ LineType * bwb_ON_ERROR_RETURN_NEXT (LineType * l) { assert (l != NULL); return bwb_ON_ERROR_RESUME_NEXT (l); } /* -------------------------------------------------------------------------------------------- ON TIMER -------------------------------------------------------------------------------------------- */ LineType * bwb_ON_TIMER (LineType * l) { /* ON TIMER(...) GOSUB ... */ DoubleType v; DoubleType minv; int LineNumber; assert (l != NULL); assert( My != NULL ); My->IsTimerOn = FALSE; /* bwb_ON_TIMER */ My->OnTimerLineNumber = 0; My->OnTimerCount = 0; /* get the SECOMDS parameter */ if (line_read_numeric_expression (l, &v) == FALSE) { WARN_SYNTAX_ERROR; return (l); } minv = 1; assert (CLOCKS_PER_SEC > 0); minv /= CLOCKS_PER_SEC; if (v < minv) { /* ERROR */ WARN_ILLEGAL_FUNCTION_CALL; return (l); } /* get the GOSUB keyword */ if (line_skip_word (l, "GOSUB") == FALSE) { WARN_SYNTAX_ERROR; return (l); } /* ON TIMER(X) GOSUB line */ if (line_read_integer_expression (l, &LineNumber) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (LineNumber < MINLIN || LineNumber > MAXLIN) { /* ERROR */ WARN_UNDEFINED_LINE; return (l); } /* OK */ My->OnTimerLineNumber = LineNumber; My->OnTimerCount = v; return (l); } /* -------------------------------------------------------------------------------------------- TIMER -------------------------------------------------------------------------------------------- */ LineType * bwb_TIMER (LineType * l) { assert (l != NULL); assert( My != NULL ); My->IsTimerOn = FALSE; /* bwb_TIMER */ WARN_SYNTAX_ERROR; return (l); } /* -------------------------------------------------------------------------------------------- TIMER OFF -------------------------------------------------------------------------------------------- */ LineType * bwb_TIMER_OFF (LineType * l) { assert (l != NULL); assert( My != NULL ); /* TIMER OFF */ My->IsTimerOn = FALSE; /* bwb_TIMER_OFF */ My->OnTimerLineNumber = 0; My->OnTimerCount = 0; return (l); } /* -------------------------------------------------------------------------------------------- TIMER ON -------------------------------------------------------------------------------------------- */ LineType * bwb_TIMER_ON (LineType * l) { assert (l != NULL); assert( My != NULL ); My->IsTimerOn = FALSE; /* bwb_TIMER_ON */ /* TIMER ON */ if (My->OnTimerCount > 0 && My->OnTimerLineNumber > 0) { My->OnTimerExpires = bwx_TIMER (My->OnTimerCount); My->IsTimerOn = TRUE; /* bwb_TIMER_ON */ } return (l); } /* -------------------------------------------------------------------------------------------- TIMER STOP -------------------------------------------------------------------------------------------- */ LineType * bwb_TIMER_STOP (LineType * l) { assert (l != NULL); assert( My != NULL ); My->IsTimerOn = FALSE; /* bwb_TIMER_STOP */ return (l); } /* -------------------------------------------------------------------------------------------- RESUME -------------------------------------------------------------------------------------------- */ LineType * bwb_RESUME (LineType * l) { int LineNumber; LineType *x; assert (l != NULL); assert( My != NULL ); LineNumber = 0; x = My->ERL; /* bwb_RESUME */ WARN_CLEAR; /* bwb_RESUME */ if (l->LineFlags & (LINE_USER)) { WARN_ILLEGAL_DIRECT; return (l); } if (x == NULL) { WARN_RESUME_WITHOUT_ERROR; return (l); } /* Get optional argument for RESUME */ if (line_is_eol (l)) { /* RESUME */ /* Execution resumes at the statement which caused the error For structured commands, this is the top line of the structure. */ x->position = 0; return x; } if (line_skip_word (l, "NEXT")) { /* RESUME NEXT */ /* Execution resumes at the statement immediately following the one which caused the error. For structured commands, this is the bottom line of the structure. */ switch (x->cmdnum) { case C_IF8THEN: /* skip to END_IF */ assert (x->OtherLine != NULL); for (x = x->OtherLine; x->cmdnum != C_END_IF; x = x->OtherLine); break; case C_SELECT_CASE: /* skip to END_SELECT */ assert (x->OtherLine != NULL); for (x = x->OtherLine; x->cmdnum != C_END_SELECT; x = x->OtherLine); break; default: x = x->next; } x->position = 0; return x; } /* RESUME ### */ if (line_read_integer_expression (l, &LineNumber) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (LineNumber == 0) { /* SPECIAL CASE */ /* RESUME 0 */ /* Execution resumes at the statement which caused the error */ x->position = 0; return x; } /* VERIFY LINE EXISTS */ x = find_line_number (LineNumber); /* RESUME 100 */ if (x != NULL) { /* FOUND */ x->position = 0; return x; } /* NOT FOUND */ WARN_UNDEFINED_LINE; return (l); } /* -------------------------------------------------------------------------------------------- CMDS -------------------------------------------------------------------------------------------- */ LineType * bwb_CMDS (LineType * l) { int n; int t; assert (l != NULL); assert( My != NULL ); assert( My->SYSOUT != NULL ); assert( My->SYSOUT->cfp != NULL ); My->CurrentFile = My->SYSOUT; fprintf (My->SYSOUT->cfp, "BWBASIC COMMANDS AVAILABLE:\n"); /* run through the command table and print comand names */ t = 0; for (n = 0; n < NUM_COMMANDS; n++) { fprintf (My->SYSOUT->cfp, IntrinsicCommandTable[n].name); if (t < 4) { fprintf (My->SYSOUT->cfp, "\t"); t++; } else { fprintf (My->SYSOUT->cfp, "\n"); t = 0; } } if (t > 0) { fprintf (My->SYSOUT->cfp, "\n"); } ResetConsoleColumn (); return (l); } static void FixUp (char *Name) { char *C; assert (Name != NULL); C = Name; while (*C) { if (bwb_isalnum (*C)) { /* OK */ } else { /* FIX */ switch (*C) { case '!': *C = '1'; break; case '@': *C = '2'; break; case '#': *C = '3'; break; case '$': *C = '4'; break; case '%': *C = '5'; break; case '^': *C = '6'; break; case '&': *C = '7'; break; case '*': *C = '8'; break; case '(': *C = '9'; break; case ')': *C = '0'; break; default: *C = '_'; } } C++; } } static void CommandUniqueID (int i, char *UniqueID) { assert (UniqueID != NULL); bwb_strcpy (UniqueID, "C_"); bwb_strcat (UniqueID, IntrinsicCommandTable[i].name); FixUp (UniqueID); } static void CommandVector (int i, char *Vector) { assert (Vector != NULL); bwb_strcpy (Vector, "bwb_"); bwb_strcat (Vector, IntrinsicCommandTable[i].name); FixUp (Vector); } static void CommandOptionVersion (int n, char *OutputLine) { int i; int j; assert (OutputLine != NULL); bwb_strcpy (OutputLine, ""); j = 0; for (i = 0; i < NUM_VERSIONS; i++) { if (IntrinsicCommandTable[n].OptionVersionBitmask & bwb_vertable[i]. OptionVersionValue) { if (j > 0) { bwb_strcat (OutputLine, " | "); } bwb_strcat (OutputLine, bwb_vertable[i].ID); j++; } } } void SortAllCommands (void) { /* sort by name */ int i; assert( My != NULL ); for (i = 0; i < NUM_COMMANDS - 1; i++) { int j; int k; k = i; for (j = i + 1; j < NUM_COMMANDS; j++) { if (bwb_stricmp (IntrinsicCommandTable[j].name, IntrinsicCommandTable[k].name) < 0) { k = j; } } if (k > i) { CommandType t; bwb_memcpy (&t, &(IntrinsicCommandTable[i]), sizeof (CommandType)); bwb_memcpy (&(IntrinsicCommandTable[i]), &(IntrinsicCommandTable[k]), sizeof (CommandType)); bwb_memcpy (&(IntrinsicCommandTable[k]), &t, sizeof (CommandType)); } } #if THE_PRICE_IS_RIGHT for (i = 0; i < 26; i++) { My->CommandStart[i] = -1; } for (i = 0; i < NUM_COMMANDS; i++) { int j; j = VarTypeIndex (IntrinsicCommandTable[i].name[0]); if (j < 0) { /* non-alpha */ } else if (My->CommandStart[j] < 0) { /* this is the first command starting with this letter */ My->CommandStart[j] = i; } } #endif /* THE_PRICE_IS_RIGHT */ } void SortAllFunctions (void) { /* sort by name then number of parameters */ int i; assert( My != NULL ); for (i = 0; i < NUM_FUNCTIONS - 1; i++) { int j; int k; k = i; for (j = i + 1; j < NUM_FUNCTIONS; j++) { int n; n = bwb_stricmp (IntrinsicFunctionTable[j].Name, IntrinsicFunctionTable[k].Name); if (n < 0) { k = j; } else if (n == 0) { if (IntrinsicFunctionTable[j].ParameterCount < IntrinsicFunctionTable[k].ParameterCount) { k = j; } } } if (k > i) { IntrinsicFunctionType t; bwb_memcpy (&t, &(IntrinsicFunctionTable[i]), sizeof (IntrinsicFunctionType)); bwb_memcpy (&(IntrinsicFunctionTable[i]), &(IntrinsicFunctionTable[k]), sizeof (IntrinsicFunctionType)); bwb_memcpy (&(IntrinsicFunctionTable[k]), &t, sizeof (IntrinsicFunctionType)); } } #if THE_PRICE_IS_RIGHT for (i = 0; i < 26; i++) { My->IntrinsicFunctionStart[i] = -1; } for (i = 0; i < NUM_FUNCTIONS; i++) { int j; j = VarTypeIndex (IntrinsicFunctionTable[i].Name[0]); if (j < 0) { /* non-alpha */ } else if (My->IntrinsicFunctionStart[j] < 0) { /* this is the first command starting with this letter */ My->IntrinsicFunctionStart[j] = i; } } #endif /* THE_PRICE_IS_RIGHT */ } void DumpAllCommandUniqueID (FILE * file) { int i; int j; char LastUniqueID[NameLengthMax + 1]; assert (file != NULL); j = 0; LastUniqueID[0] = NulChar; fprintf (file, "/* COMMANDS */\n"); /* run through the command table and print comand #define */ for (i = 0; i < NUM_COMMANDS; i++) { char UniqueID[NameLengthMax + 1]; CommandUniqueID (i, UniqueID); if (bwb_stricmp (LastUniqueID, UniqueID) != 0) { /* not a duplicate */ bwb_strcpy (LastUniqueID, UniqueID); j = j + 1; fprintf (file, "#define %-30s %3d /* %-30s */\n", UniqueID, j, IntrinsicCommandTable[i].name); } } fprintf (file, "#define NUM_COMMANDS %d\n", j); fflush (file); } static void ProcessEscapeChars (const char *Input, char *Output) { int n; assert (Input != NULL); assert (Output != NULL); n = 0; while (*Input) { /* \a \b \f \n \r \t \v \" \\ */ switch (*Input) { case '\a': *Output = '\\'; Output++; *Output = 'a'; Output++; break; case '\b': *Output = '\\'; Output++; *Output = 'b'; Output++; break; case '\f': *Output = '\\'; Output++; *Output = 'f'; Output++; break; case '\n': *Output = '\\'; Output++; *Output = 'n'; Output++; break; case '\r': *Output = '\\'; Output++; *Output = 'r'; Output++; break; case '\t': *Output = '\\'; Output++; *Output = 't'; Output++; break; case '\v': *Output = '\\'; Output++; *Output = 'n'; Output++; break; case '\"': *Output = '\\'; Output++; *Output = '"'; Output++; break; case '\\': *Output = '\\'; Output++; *Output = '\\'; Output++; break; default: *Output = *Input; Output++; break; } *Output = NulChar; n++; if (n > 60 && *Input == ' ') { *Output = '\"'; Output++; *Output = '\n'; Output++; *Output = ' '; Output++; *Output = ' '; Output++; *Output = '\"'; Output++; *Output = NulChar; n = 0; } Input++; } } void DumpAllCommandTableDefinitions (FILE * file) { /* generate bwd_cmd.c */ int i; assert (file != NULL); fprintf (file, "/* COMMAND TABLE */\n\n"); fprintf (file, "#include \"bwbasic.h\"\n\n"); fprintf (file, "CommandType IntrinsicCommandTable[ /* NUM_COMMANDS */ ] =\n"); fprintf (file, "{\n"); /* run through the command table and print comand #define */ for (i = 0; i < NUM_COMMANDS; i++) { char tbuf[MAINTAINER_BUFFER_LENGTH + 1]; /* DumpAllCommandTableDefinitions */ fprintf (file, "{\n"); fprintf (file, " "); CommandUniqueID (i, tbuf); fprintf (file, tbuf); fprintf (file, ", /* UniqueID */\n"); fprintf (file, " "); fprintf (file, "\""); ProcessEscapeChars (IntrinsicCommandTable[i].Syntax, tbuf); fprintf (file, tbuf); fprintf (file, "\""); fprintf (file, ", /* Syntax */\n"); fprintf (file, " "); fprintf (file, "\""); ProcessEscapeChars (IntrinsicCommandTable[i].Description, tbuf); fprintf (file, tbuf); fprintf (file, "\""); fprintf (file, ", /* Description */\n"); fprintf (file, " "); fprintf (file, "\""); fprintf (file, IntrinsicCommandTable[i].name); fprintf (file, "\""); fprintf (file, ", /* Name */\n"); fprintf (file, " "); CommandOptionVersion (i, tbuf); fprintf (file, tbuf); fprintf (file, " /* OptionVersionBitmask */\n"); fprintf (file, "},\n"); } fprintf (file, "};\n"); fprintf (file, "\n"); fprintf (file, "const size_t NUM_COMMANDS = sizeof( IntrinsicCommandTable ) / sizeof( CommandType );\n"); fprintf (file, "\n"); fflush (file); } void DumpAllCommandSwitchStatement (FILE * file) { int i; char LastUniqueID[NameLengthMax + 1]; assert (file != NULL); LastUniqueID[0] = NulChar; /* run through the command table and print comand #define */ fprintf (file, "/* SWITCH */\n"); fprintf (file, "LineType *bwb_vector( LineType *l )\n"); fprintf (file, "{\n"); fprintf (file, " "); fprintf (file, "LineType *r;\n"); fprintf (file, " "); fprintf (file, "switch( l->cmdnum )\n"); fprintf (file, " "); fprintf (file, "{\n"); for (i = 0; i < NUM_COMMANDS; i++) { char tbuf[NameLengthMax + 1]; CommandUniqueID (i, tbuf); if (bwb_stricmp (LastUniqueID, tbuf) != 0) { /* not a duplicate */ bwb_strcpy (LastUniqueID, tbuf); fprintf (file, " "); fprintf (file, "case "); CommandUniqueID (i, tbuf); fprintf (file, tbuf); fprintf (file, ":\n"); fprintf (file, " "); fprintf (file, " "); fprintf (file, "r = "); CommandVector (i, tbuf); fprintf (file, tbuf); fprintf (file, "( l );\n"); fprintf (file, " "); fprintf (file, " "); fprintf (file, "break;\n"); } } fprintf (file, " "); fprintf (file, "default:\n"); fprintf (file, " "); fprintf (file, " "); fprintf (file, "WARN_INTERNAL_ERROR;\n"); fprintf (file, " "); fprintf (file, " "); fprintf (file, "r = l;\n"); fprintf (file, " "); fprintf (file, " "); fprintf (file, "break;\n"); fprintf (file, " "); fprintf (file, "}\n"); fprintf (file, " "); fprintf (file, "return r;\n"); fprintf (file, "}\n"); fflush (file); } void FixDescription (FILE * file, const char *left, const char *right) { char buffer[MAINTAINER_BUFFER_LENGTH + 1]; /* FixDescription */ int l; /* length of left side */ int p; /* current position */ int n; /* position of the last space character, zero means none yet seen */ int i; /* number of characters since last '\n' */ assert (left != NULL); assert (right != NULL); l = bwb_strlen (left); p = 0; n = 0; i = 0; bwb_strcpy (buffer, right); while (buffer[p]) { if (buffer[p] == '\n') { n = p; i = 0; } if (buffer[p] == ' ') { n = p; } if (i > 45 && n > 0) { buffer[n] = '\n'; i = p - n; } p++; i++; } fputs (left, file); p = 0; while (buffer[p]) { if (buffer[p] == '\n') { fputc (buffer[p], file); p++; while (buffer[p] == ' ') { p++; } for (i = 0; i < l; i++) { fputc (' ', file); } } else { fputc (buffer[p], file); p++; } } fputc ('\n', file); } void DumpOneCommandSyntax (FILE * file, int IsXref, int n) { assert (file != NULL); if (n < 0 || n >= NUM_COMMANDS) { return; } /* NAME */ { FixDescription (file, " SYNTAX: ", IntrinsicCommandTable[n].Syntax); } /* DESCRIPTION */ { FixDescription (file, "DESCRIPTION: ", IntrinsicCommandTable[n].Description); } /* COMPATIBILITY */ if (IsXref) { int i; fprintf (file, " VERSIONS:\n"); for (i = 0; i < NUM_VERSIONS; i++) { char X; if (IntrinsicCommandTable[n].OptionVersionBitmask & bwb_vertable[i]. OptionVersionValue) { /* SUPPORTED */ X = 'X'; } else { /* NOT SUPPORTED */ X = '_'; } fprintf (file, " [%c] %s\n", X, bwb_vertable[i].Name); } } fflush (file); } void DumpAllCommandSyntax (FILE * file, int IsXref, OptionVersionType OptionVersionValue) { /* for the C maintainer */ int i; assert (file != NULL); fprintf (file, "============================================================\n"); fprintf (file, " COMMANDS \n"); fprintf (file, "============================================================\n"); fprintf (file, "\n"); fprintf (file, "\n"); for (i = 0; i < NUM_COMMANDS; i++) { if (IntrinsicCommandTable[i].OptionVersionBitmask & OptionVersionValue) { fprintf (file, "------------------------------------------------------------\n"); DumpOneCommandSyntax (file, IsXref, i); } } fprintf (file, "------------------------------------------------------------\n"); fprintf (file, "\n"); fprintf (file, "\n"); fflush (file); } void DumpAllCommandHtmlTable (FILE * file) { /* generate bwd_cmd.htm */ int i; int j; assert (file != NULL); /* LEGEND */ fprintf (file, "CMDS\n"); fprintf (file, "

LEGEND


\n"); fprintf (file, "\n"); fprintf (file, ""); fprintf (file, ""); fprintf (file, ""); fprintf (file, ""); fprintf (file, "\n"); for (j = 0; j < NUM_VERSIONS; j++) { fprintf (file, ""); fprintf (file, ""); fprintf (file, ""); fprintf (file, ""); fprintf (file, "\n"); } fprintf (file, "
"); fprintf (file, ""); fprintf (file, "ID"); fprintf (file, ""); fprintf (file, ""); fprintf (file, ""); fprintf (file, "NAME"); fprintf (file, ""); fprintf (file, ""); fprintf (file, ""); fprintf (file, "DESCRIPTION"); fprintf (file, ""); fprintf (file, "
"); fprintf (file, bwb_vertable[j].ID); fprintf (file, ""); fprintf (file, bwb_vertable[j].Name); fprintf (file, ""); fprintf (file, bwb_vertable[j].Description); fprintf (file, "
\n"); fprintf (file, "
\n"); /* DETAILS */ fprintf (file, "

DETAILS


\n"); fprintf (file, "\n"); fprintf (file, ""); fprintf (file, ""); for (j = 0; j < NUM_VERSIONS; j++) { fprintf (file, ""); } fprintf (file, "\n"); /* run through the command table and print comand -vs- OPTION VERSION */ for (i = 0; i < NUM_COMMANDS; i++) { fprintf (file, ""); fprintf (file, ""); for (j = 0; j < NUM_VERSIONS; j++) { fprintf (file, ""); } fprintf (file, "\n"); } fprintf (file, "
"); fprintf (file, ""); fprintf (file, "COMMAND"); fprintf (file, ""); fprintf (file, ""); fprintf (file, ""); fprintf (file, bwb_vertable[j].ID); fprintf (file, ""); fprintf (file, "
"); fprintf (file, (char *) IntrinsicCommandTable[i].Syntax); fprintf (file, ""); if (IntrinsicCommandTable[i].OptionVersionBitmask & bwb_vertable[j]. OptionVersionValue) { fprintf (file, "X"); } else { fprintf (file, " "); } fprintf (file, "
\n"); fprintf (file, "\n"); fprintf (file, "\n"); fflush (file); } /* -------------------------------------------------------------------------------------------- HELP -------------------------------------------------------------------------------------------- */ LineType * bwb_HELP (LineType * l) { /* HELP ... */ int n; int Found; char *C; char *tbuf; assert (l != NULL); assert( My != NULL ); assert( My->ConsoleInput != NULL ); assert( My->SYSOUT != NULL ); assert( My->SYSOUT->cfp != NULL ); tbuf = My->ConsoleInput; Found = FALSE; C = l->buffer; C += l->position; bwb_strcpy (tbuf, C); /* RTRIM$ */ C = tbuf; if (*C != 0) { /* not an empty line, so remove one (or more) trailing spaces */ char *E; E = bwb_strchr (tbuf, 0); E--; while (E >= tbuf && *E == ' ') { *E = 0; E--; } } /* EXACT match */ for (n = 0; n < NUM_COMMANDS; n++) { if (bwb_stricmp (IntrinsicCommandTable[n].name, tbuf) == 0) { fprintf (My->SYSOUT->cfp, "------------------------------------------------------------\n"); DumpOneCommandSyntax (My->SYSOUT->cfp, FALSE, n); Found = TRUE; } } for (n = 0; n < NUM_FUNCTIONS; n++) { if (bwb_stricmp (IntrinsicFunctionTable[n].Name, tbuf) == 0) { fprintf (My->SYSOUT->cfp, "------------------------------------------------------------\n"); DumpOneFunctionSyntax (My->SYSOUT->cfp, FALSE, n); Found = TRUE; } } if (Found == FALSE) { /* PARTIAL match */ int Length; Length = bwb_strlen (tbuf); for (n = 0; n < NUM_COMMANDS; n++) { if (bwb_strnicmp (IntrinsicCommandTable[n].name, tbuf, Length) == 0) { if (Found == FALSE) { fprintf (My->SYSOUT->cfp, "The following topics are a partial match:\n"); } fprintf (My->SYSOUT->cfp, IntrinsicCommandTable[n].name); fprintf (My->SYSOUT->cfp, "\t"); Found = TRUE; } } for (n = 0; n < NUM_FUNCTIONS; n++) { if (bwb_strnicmp (IntrinsicFunctionTable[n].Name, tbuf, Length) == 0) { if (Found == FALSE) { fprintf (My->SYSOUT->cfp, "The following topics are a partial match:\n"); } fprintf (My->SYSOUT->cfp, IntrinsicFunctionTable[n].Name); fprintf (My->SYSOUT->cfp, "\t"); Found = TRUE; } } if (Found == TRUE) { /* match */ fprintf (My->SYSOUT->cfp, "\n"); } } if (Found == FALSE) { /* NO match */ fprintf (My->SYSOUT->cfp, "No help found.\n"); } ResetConsoleColumn (); line_skip_eol (l); return (l); } int NumberValueCheck (ParamTestType ParameterTests, DoubleType X) { DoubleType XR; /* rounded value */ unsigned char TestNibble; /* VerifyNumeric */ if (isnan (X)) { /* INTERNAL ERROR */ return -1; } if (isinf (X)) { /* - Evaluation of an expression results in an overflow * (nonfatal, the recommended recovery procedure is to supply * machine in- finity with the algebraically correct sign and * continue). */ if (X < 0) { X = MINDBL; } else { X = MAXDBL; } if (WARN_OVERFLOW) { /* ERROR */ return -1; } /* CONTINUE */ } /* OK */ /* VALID NUMERIC VALUE */ XR = bwb_rint (X); ParameterTests &= 0x0000000F; TestNibble = (unsigned char) ParameterTests; switch (TestNibble) { case P1ERR: /* INTERNAL ERROR */ return -1; /* break; */ case P1ANY: if (X < MINDBL || X > MAXDBL) { /* ERROR */ return -1; } /* OK */ return 0; /* break; */ case P1BYT: if (XR < MINBYT || XR > MAXBYT) { /* ERROR */ return -1; } /* OK */ return 0; /* break; */ case P1INT: if (XR < MININT || XR > MAXINT) { /* ERROR */ return -1; } /* OK */ return 0; /* break; */ case P1LNG: if (XR < MINLNG || XR > MAXLNG) { /* ERROR */ return -1; } /* OK */ return 0; /* break; */ case P1CUR: if (XR < MINCUR || XR > MAXCUR) { /* ERROR */ return -1; } /* OK */ return 0; /* break; */ case P1FLT: if (X < MINSNG || X > MAXSNG) { /* ERROR */ return -1; } /* OK */ return 0; /* break; */ case P1DBL: if (X < MINDBL || X > MAXDBL) { /* ERROR */ return -1; } /* OK */ return 0; /* break; */ case P1DEV: /* ERROR */ return -1; /* break; */ case P1LEN: if (XR < MINLEN || XR > MAXLEN) { /* ERROR */ return -1; } /* OK */ return 0; /* break; */ case P1POS: if (XR < 1 || XR > MAXLEN) { /* ERROR */ return -1; } /* OK */ return 0; /* break; */ case P1COM: /* ERROR */ return -1; /* break; */ case P1LPT: /* ERROR */ return -1; /* break; */ case P1GTZ: if (X > 0) { /* OK */ return 0; } break; case P1GEZ: if (X >= 0) { /* OK */ return 0; } break; case P1NEZ: if (X != 0) { /* OK */ return 0; } break; } /* ERROR */ return -1; } int StringLengthCheck (ParamTestType ParameterTests, int s) { unsigned char TestNibble; /* check for invalid string length */ if (s < 0 || s > MAXLEN) { /* INTERNAL ERROR */ return -1; } /* VALID STRING LENGTH */ ParameterTests &= 0x0000000F; TestNibble = (unsigned char) ParameterTests; switch (TestNibble) { case P1ERR: /* INTERNAL ERROR */ return -1; /* break; */ case P1ANY: /* OK */ return 0; /* break; */ case P1BYT: if (s >= sizeof (ByteType)) { /* OK */ return 0; } break; case P1INT: if (s >= sizeof (IntegerType)) { /* OK */ return 0; } break; case P1LNG: if (s >= sizeof (LongType)) { /* OK */ return 0; } break; case P1CUR: if (s >= sizeof (CurrencyType)) { /* OK */ return 0; } break; case P1FLT: if (s >= sizeof (SingleType)) { /* OK */ return 0; } break; case P1DBL: if (s >= sizeof (DoubleType)) { /* OK */ return 0; } break; case P1DEV: /* ERROR */ return -1; /* break; */ case P1LEN: /* ERROR */ return -1; /* break; */ case P1POS: /* ERROR */ return -1; /* break; */ case P1GEZ: /* ERROR */ return -1; /* break; */ case P1GTZ: /* ERROR */ return -1; /* break; */ case P1NEZ: /* ERROR */ return -1; /* break; */ } /* ERROR */ return -1; } void IntrinsicFunctionDefinitionCheck (IntrinsicFunctionType * f) { /* function definition check -- look for obvious errors */ assert (f != NULL); assert( My != NULL ); assert( My->SYSOUT != NULL ); assert( My->SYSOUT->cfp != NULL ); /* sanity check */ if (f->ParameterCount == PNONE || f->ParameterCount == 0xFF) { /* function has NO explicit parameters */ if (f->ParameterTypes == PNONE) { /* OK */ } else { /* oops */ fprintf (My->SYSOUT->cfp, "invalid ParameterTypes <%s>\n", f->Name); } if (f->ParameterTests == PNONE) { /* OK */ } else { /* oops */ fprintf (My->SYSOUT->cfp, "invalid ParameterTests <%s>\n", f->Name); } } else { /* function HAS an explicit number of parameters */ int i; ParamTestType ParameterTests; ParameterTests = f->ParameterTests; for (i = 0; i < f->ParameterCount; i++) { /* sanity check this parameter */ ParamTestType thischeck; thischeck = ParameterTests & 0x0000000F; /* verify parameter check */ if (f->ParameterTypes & (1 << i)) { /* STRING */ if (thischeck >= P1ANY && thischeck <= P1DBL) { /* OK */ } else { /* oops */ fprintf (My->SYSOUT->cfp, "invalid ParameterTests <%s> parameter %d\n", f->Name, i + 1); } } else { /* NUMBER */ if (thischeck >= P1ANY && thischeck <= P1NEZ) { /* OK */ } else { /* oops */ fprintf (My->SYSOUT->cfp, "invalid ParameterTests <%s> parameter %d\n", f->Name, i + 1); } } ParameterTests = ParameterTests >> 4; } if (ParameterTests != 0) { /* oops */ fprintf (My->SYSOUT->cfp, "invalid ParameterTests <%s> parameter %d\n", f->Name, i + 1); } } } void IntrinsicFunctionUniqueID (IntrinsicFunctionType * f, char *UniqueID) { /* generate the function's UniqueID */ /* manual fixup required for duplicates */ char NumVar; char StrVar; assert (f != NULL); assert (UniqueID != NULL); NumVar = 'X'; StrVar = 'A'; /* F_ */ bwb_strcpy (UniqueID, "F_"); /* NAME */ bwb_strcat (UniqueID, f->Name); /* PARAMETERS */ if (f->ParameterCount == PNONE || f->ParameterCount == 0xFF) { /* function has NO explicit parameters */ } else { /* function HAS explicit parameters */ int i; ParamBitsType ParameterTypes; ParameterTypes = f->ParameterTypes; for (i = 0; i < f->ParameterCount; i++) { char VarName[NameLengthMax + 1]; if (ParameterTypes & 1) { /* STRING */ sprintf (VarName, "_%c", StrVar); StrVar++; } else { /* NUMBER */ sprintf (VarName, "_%c", NumVar); NumVar++; } bwb_strcat (UniqueID, VarName); ParameterTypes = ParameterTypes >> 1; } } /* RETURN TYPE */ if (f->ReturnTypeCode == StringTypeCode) { bwb_strcat (UniqueID, "_S"); } else { bwb_strcat (UniqueID, "_N"); } /* fixup illegal characters, "DEF FN" "BLOAD:", "CLOAD*" */ FixUp (UniqueID); } void IntrinsicFunctionSyntax (IntrinsicFunctionType * f, char *Syntax) { /* generate the function's Syntax */ char NumVar; char StrVar; assert (f != NULL); assert (Syntax != NULL); NumVar = 'X'; StrVar = 'A'; /* RETURN TYPE */ if (f->ReturnTypeCode == StringTypeCode) { bwb_strcpy (Syntax, "S$ = "); } else { bwb_strcpy (Syntax, "N = "); } /* NAME */ bwb_strcat (Syntax, f->Name); /* PARAMETERS */ if (f->ParameterCount == PNONE) { /* function has NO explicit parameters */ } else if (f->ParameterCount == 0xFF) { /* function has a variable number of parameters */ bwb_strcat (Syntax, "( ... )"); } else { /* function HAS explicit parameters */ int i; ParamBitsType ParameterTypes; ParameterTypes = f->ParameterTypes; if (f->ReturnTypeCode == StringTypeCode) { bwb_strcat (Syntax, "( "); } else { bwb_strcat (Syntax, "( "); } for (i = 0; i < f->ParameterCount; i++) { char VarName[NameLengthMax + 1]; if (i > 0) { bwb_strcat (Syntax, ", "); } /* verify parameter check */ if (ParameterTypes & 1) { /* STRING */ sprintf (VarName, "%c$", StrVar); StrVar++; } else { /* NUMBER */ sprintf (VarName, "%c", NumVar); NumVar++; } bwb_strcat (Syntax, VarName); ParameterTypes = ParameterTypes >> 1; } if (f->ReturnTypeCode == StringTypeCode) { bwb_strcat (Syntax, " )"); } else { bwb_strcat (Syntax, " )"); } } } void DumpAllFunctionUniqueID (FILE * file) { /* for the C maintainer */ int i; int j; char LastUniqueID[NameLengthMax + 1]; assert (file != NULL); j = 0; LastUniqueID[0] = NulChar; fprintf (file, "/* FUNCTIONS */\n"); for (i = 0; i < NUM_FUNCTIONS; i++) { char UniqueID[NameLengthMax + 1]; IntrinsicFunctionUniqueID (&(IntrinsicFunctionTable[i]), UniqueID); if (bwb_stricmp (LastUniqueID, UniqueID) != 0) { /* not a duplicate */ char Syntax[NameLengthMax + 1]; bwb_strcpy (LastUniqueID, UniqueID); j = j + 1; IntrinsicFunctionSyntax (&(IntrinsicFunctionTable[i]), Syntax); fprintf (file, "#define %-30s %3d /* %-30s */\n", UniqueID, j, Syntax); } } fprintf (file, "#define NUM_FUNCTIONS %d\n", j); fflush (file); } void DumpAllFunctionSwitch (FILE * file) { /* for the C maintainer */ int i; assert (file != NULL); fprintf (file, "/* SWITCH */\n"); fprintf (file, "switch( UniqueID )\n"); fprintf (file, "{\n"); for (i = 0; i < NUM_FUNCTIONS; i++) { char tbuf[MAINTAINER_BUFFER_LENGTH + 1]; /* DumpAllFunctionSwitch */ fprintf (file, "case "); IntrinsicFunctionUniqueID (&(IntrinsicFunctionTable[i]), tbuf); fprintf (file, tbuf); fprintf (file, ":\n"); fprintf (file, " break;\n"); } fprintf (file, "}\n"); fflush (file); } static const char *ParameterRangeID[16] = { "P%dERR", "P%dANY", "P%dBYT", "P%dINT", "P%dLNG", "P%dCUR", "P%dFLT", "P%dDBL", "P%dDEV", "P%dLEN", "P%dPOS", "P%dCOM", "P%dLPT", "P%dGTZ", "P%dGEZ", "P%dNEZ", }; static const char *NumberVariableRange[16] = { /* P1ERR */ " PARAMETER: %c is a number, INTERNAL ERROR", /* P1ANY */ " PARAMETER: %c is a number", /* P1BYT */ " PARAMETER: %c is a number, [0,255]", /* P1INT */ " PARAMETER: %c is a number, [MININT,MAXINT]", /* P1LNG */ " PARAMETER: %c is a number, [MINLNG,MAXLNG]", /* P1CUR */ " PARAMETER: %c is a number, [MINCUR,MAXCUR]", /* P1FLT */ " PARAMETER: %c is a number, [MINFLT,MAXFLT]", /* P1DBL */ " PARAMETER: %c is a number, [MINDBL,MAXDBL]", /* P1DEV */ " PARAMETER: %c is a number, RESERVED", /* P1LEN */ " PARAMETER: %c is a number, [0,MAXLEN]", /* P1POS */ " PARAMETER: %c is a number, [1,MAXLEN]", /* P1COM */ " PARAMETER: %c is a number, RESERVED", /* P1LPT */ " PARAMETER: %c is a number, RESERVED", /* P1GTZ */ " PARAMETER: %c is a number, > 0", /* P1GEZ */ " PARAMETER: %c is a number, >= 0", /* P1NEZ */ " PARAMETER: %c is a number, <> 0", }; static const char *StringVariableRange[16] = { /* P1ERR */ " PARAMETER: %c$ is a string, INTERNAL ERROR", /* P1ANY */ " PARAMETER: %c$ is a string, LEN >= 0", /* P1BYT */ " PARAMETER: %c$ is a string, LEN >= 1", /* P1INT */ " PARAMETER: %c$ is a string, LEN >= sizeof(INT)", /* P1LNG */ " PARAMETER: %c$ is a string, LEN >= sizeof(LNG)", /* P1CUR */ " PARAMETER: %c$ is a string, LEN >= sizeof(CUR)", /* P1FLT */ " PARAMETER: %c$ is a string, LEN >= sizeof(FLT)", /* P1DBL */ " PARAMETER: %c$ is a string, LEN >= sizeof(DBL)", /* P1DEV */ " PARAMETER: %c$ is a string, RESERVED", /* P1LEN */ " PARAMETER: %c$ is a string, RESERVED", /* P1POS */ " PARAMETER: %c$ is a string, RESERVED", /* P1COM */ " PARAMETER: %c$ is a string, RESERVED", /* P1LPT */ " PARAMETER: %c$ is a string, RESERVED", /* P1GTZ */ " PARAMETER: %c$ is a string, RESERVED", /* P1GEZ */ " PARAMETER: %c$ is a string, RESERVED", /* P1NEZ */ " PARAMETER: %c$ is a string, RESERVED", }; void DumpAllFuctionTableDefinitions (FILE * file) { /* generate bwd_fun.c */ int n; assert (file != NULL); fprintf (file, "/* FUNCTION TABLE */\n"); fprintf (file, "\n"); fprintf (file, "#include \"bwbasic.h\"\n"); fprintf (file, "\n"); fprintf (file, "IntrinsicFunctionType IntrinsicFunctionTable[ /* NUM_FUNCTIONS */ ] =\n"); fprintf (file, "{\n"); for (n = 0; n < NUM_FUNCTIONS; n++) { int i; int j; char tbuf[MAINTAINER_BUFFER_LENGTH + 1]; /* DumpAllFuctionTableDefinitions */ char UniqueID[MAINTAINER_BUFFER_LENGTH + 1]; /* DumpAllFuctionTableDefinitions */ char Syntax[MAINTAINER_BUFFER_LENGTH + 1]; /* DumpAllFuctionTableDefinitions */ IntrinsicFunctionType *f; f = &(IntrinsicFunctionTable[n]); IntrinsicFunctionUniqueID (f, UniqueID); IntrinsicFunctionSyntax (f, Syntax); fprintf (file, "{\n"); fprintf (file, " %s, /* UniqueID */\n", UniqueID); fprintf (file, " \"%s\", /* Syntax */\n", Syntax); fprintf (file, " "); fprintf (file, "\""); ProcessEscapeChars (f->Description, tbuf); fprintf (file, tbuf); fprintf (file, "\""); fprintf (file, ", /* Description */\n"); fprintf (file, " \"%s\", /* Name */\n", f->Name); switch (f->ReturnTypeCode) { case ByteTypeCode: fprintf (file, " %s, /* ReturnTypeCode */\n", "ByteTypeCode"); break; case IntegerTypeCode: fprintf (file, " %s, /* ReturnTypeCode */\n", "IntegerTypeCode"); break; case LongTypeCode: fprintf (file, " %s, /* ReturnTypeCode */\n", "LongTypeCode"); break; case CurrencyTypeCode: fprintf (file, " %s, /* ReturnTypeCode */\n", "CurrencyTypeCode"); break; case SingleTypeCode: fprintf (file, " %s, /* ReturnTypeCode */\n", "SingleTypeCode"); break; case DoubleTypeCode: fprintf (file, " %s, /* ReturnTypeCode */\n", "DoubleTypeCode"); break; case StringTypeCode: fprintf (file, " %s, /* ReturnTypeCode */\n", "StringTypeCode"); break; default: fprintf (file, " %s, /* ReturnTypeCode */\n", "INTERNAL ERROR"); break; } fprintf (file, " %d, /* ParameterCount */\n", f->ParameterCount); if (f->ParameterCount == 0 || f->ParameterCount == 0xFF) { /* function has NO explicit parameters */ fprintf (file, " %s, /* ParameterTypes */\n", "PNONE"); fprintf (file, " %s, /* ParameterTests */\n", "PNONE"); } else { /* function has explicit parameters */ bwb_strcpy (tbuf, " "); for (i = 0; i < f->ParameterCount; i++) { ParamBitsType ParameterTypes; ParameterTypes = f->ParameterTypes >> i; ParameterTypes &= 0x1; if (i > 0) { bwb_strcat (tbuf, " | "); } if (ParameterTypes) { sprintf (bwb_strchr (tbuf, NulChar), "P%dSTR", i + 1); } else { sprintf (bwb_strchr (tbuf, NulChar), "P%dNUM", i + 1); } } bwb_strcat (tbuf, ", /* ParameterTypes */\n"); fprintf (file, tbuf); bwb_strcpy (tbuf, " "); for (i = 0; i < f->ParameterCount; i++) { ParamTestType ParameterTests; ParameterTests = f->ParameterTests >> (i * 4); ParameterTests &= 0xF; if (i > 0) { bwb_strcat (tbuf, " | "); } sprintf (bwb_strchr (tbuf, 0), ParameterRangeID[ParameterTests], i + 1); /* Conversion may lose significant digits */ } bwb_strcat (tbuf, ", /* ParameterTests */\n"); fprintf (file, tbuf); } bwb_strcpy (tbuf, " "); j = 0; for (i = 0; i < NUM_VERSIONS; i++) { if (f->OptionVersionBitmask & bwb_vertable[i].OptionVersionValue) { if (j > 0) { bwb_strcat (tbuf, " | "); } bwb_strcat (tbuf, bwb_vertable[i].ID); j++; } } bwb_strcat (tbuf, " /* OptionVersionBitmask */\n"); fprintf (file, tbuf); fprintf (file, "},\n"); } fprintf (file, "};\n"); fprintf (file, "\n"); fprintf (file, "const size_t NUM_FUNCTIONS = sizeof( IntrinsicFunctionTable ) / sizeof( IntrinsicFunctionType );\n"); fprintf (file, "\n"); fflush (file); } void DumpOneFunctionSyntax (FILE * file, int IsXref, int n) { IntrinsicFunctionType *f; assert (file != NULL); if (n < 0 || n >= NUM_FUNCTIONS) { return; } f = &(IntrinsicFunctionTable[n]); /* NAME */ { char UniqueID[MAINTAINER_BUFFER_LENGTH + 1]; /* DumpOneFunctionSyntax */ char Syntax[MAINTAINER_BUFFER_LENGTH + 1]; /* DumpOneFunctionSyntax */ IntrinsicFunctionUniqueID (f, UniqueID); IntrinsicFunctionSyntax (f, Syntax); fprintf (file, " SYNTAX: %s\n", Syntax); } /* PARAMETERS */ if (f->ParameterCount == PNONE || f->ParameterCount == 0xFF) { /* function has NO explicit parameters */ } else { /* function HAS explicit parameters */ int i; ParamBitsType ParameterTypes; ParamTestType ParameterTests; char NumVar; char StrVar; ParameterTypes = f->ParameterTypes; ParameterTests = f->ParameterTests; NumVar = 'X'; StrVar = 'A'; for (i = 0; i < f->ParameterCount; i++) { /* sanity check this parameter */ unsigned long thischeck; char tbuf[MAINTAINER_BUFFER_LENGTH + 1]; /* DumpOneFunctionSyntax */ thischeck = ParameterTests & 0x0000000F; /* verify parameter check */ if (ParameterTypes & 1) { /* STRING */ sprintf (tbuf, StringVariableRange[thischeck], StrVar); /* Conversion may lose significant digits */ StrVar++; } else { /* NUMBER */ sprintf (tbuf, NumberVariableRange[thischeck], NumVar); /* Conversion may lose significant digits */ NumVar++; } fprintf (file, tbuf); fprintf (file, "\n"); ParameterTypes = ParameterTypes >> 1; ParameterTests = ParameterTests >> 4; } } /* DESCRIPTION */ { FixDescription (file, "DESCRIPTION: ", f->Description); } /* COMPATIBILITY */ if (IsXref) { int i; fprintf (file, " VERSIONS:\n"); for (i = 0; i < NUM_VERSIONS; i++) { char X; if (f->OptionVersionBitmask & bwb_vertable[i].OptionVersionValue) { /* SUPPORTED */ X = 'X'; } else { /* NOT SUPPORTED */ X = '_'; } fprintf (file, " [%c] %s\n", X, bwb_vertable[i].Name); } } fflush (file); } void DumpAllFunctionSyntax (FILE * file, int IsXref, OptionVersionType OptionVersionValue) { /* for the C maintainer */ int i; assert (file != NULL); fprintf (file, "============================================================\n"); fprintf (file, " FUNCTIONS \n"); fprintf (file, "============================================================\n"); fprintf (file, "\n"); fprintf (file, "\n"); for (i = 0; i < NUM_FUNCTIONS; i++) { if (IntrinsicFunctionTable[i].OptionVersionBitmask & OptionVersionValue) { fprintf (file, "------------------------------------------------------------\n"); DumpOneFunctionSyntax (file, IsXref, i); } } fprintf (file, "------------------------------------------------------------\n"); fprintf (file, "\n"); fprintf (file, "\n"); fflush (file); } void DumpAllFunctionHtmlTable (FILE * file) { /* generate bwd_cmd.htm */ int i; int j; assert (file != NULL); /* LEGEND */ fprintf (file, "FNCS\n"); fprintf (file, "

LEGEND


\n"); fprintf (file, "\n"); fprintf (file, ""); fprintf (file, ""); fprintf (file, ""); fprintf (file, ""); fprintf (file, "\n"); for (j = 0; j < NUM_VERSIONS; j++) { fprintf (file, ""); fprintf (file, ""); fprintf (file, ""); fprintf (file, ""); fprintf (file, "\n"); } fprintf (file, "
"); fprintf (file, ""); fprintf (file, "ID"); fprintf (file, ""); fprintf (file, ""); fprintf (file, ""); fprintf (file, "NAME"); fprintf (file, ""); fprintf (file, ""); fprintf (file, ""); fprintf (file, "DESCRIPTION"); fprintf (file, ""); fprintf (file, "
"); fprintf (file, bwb_vertable[j].ID); fprintf (file, ""); fprintf (file, bwb_vertable[j].Name); fprintf (file, ""); fprintf (file, bwb_vertable[j].Description); fprintf (file, "
\n"); fprintf (file, "
\n"); /* DETAILS */ fprintf (file, "

DETAILS


\n"); fprintf (file, "\n"); fprintf (file, ""); fprintf (file, ""); for (j = 0; j < NUM_VERSIONS; j++) { fprintf (file, ""); } fprintf (file, "\n"); /* run through the command table and print comand -vs- OPTION VERSION */ for (i = 0; i < NUM_FUNCTIONS; i++) { fprintf (file, ""); fprintf (file, ""); for (j = 0; j < NUM_VERSIONS; j++) { fprintf (file, ""); } fprintf (file, "\n"); } fprintf (file, "
"); fprintf (file, ""); fprintf (file, "FUNCTION"); fprintf (file, ""); fprintf (file, ""); fprintf (file, ""); fprintf (file, bwb_vertable[j].ID); fprintf (file, ""); fprintf (file, "
"); fprintf (file, (char *) IntrinsicFunctionTable[i].Syntax); fprintf (file, ""); if (IntrinsicFunctionTable[i].OptionVersionBitmask & bwb_vertable[j]. OptionVersionValue) { fprintf (file, "X"); } else { fprintf (file, " "); } fprintf (file, "
\n"); fprintf (file, "\n"); fprintf (file, "\n"); fflush (file); } /* -------------------------------------------------------------------------------------------- FNCS -------------------------------------------------------------------------------------------- */ LineType * bwb_FNCS (LineType * l) { int n; int t; assert (l != NULL); assert( My != NULL ); assert( My->SYSOUT != NULL ); assert( My->SYSOUT->cfp != NULL ); My->CurrentFile = My->SYSOUT; fprintf (My->SYSOUT->cfp, "BWBASIC FUNCTIONS AVAILABLE:\n"); /* run through the command table and print comand names */ t = 0; for (n = 0; n < NUM_FUNCTIONS; n++) { fprintf (My->SYSOUT->cfp, IntrinsicFunctionTable[n].Name); if (t < 4) { fprintf (My->SYSOUT->cfp, "\t"); t++; } else { fprintf (My->SYSOUT->cfp, "\n"); t = 0; } } if (t > 0) { fprintf (My->SYSOUT->cfp, "\n"); } ResetConsoleColumn (); return (l); } /* -------------------------------------------------------------------------------------------- MAINTAINER -------------------------------------------------------------------------------------------- */ LineType * bwb_MAINTAINER (LineType * l) { assert (l != NULL); WARN_SYNTAX_ERROR; return (l); } LineType * bwb_MAINTAINER_CMDS (LineType * l) { assert (l != NULL); WARN_SYNTAX_ERROR; return (l); } LineType * bwb_MAINTAINER_CMDS_HTML (LineType * l) { assert (l != NULL); assert(My != NULL); assert(My->SYSPRN != NULL); assert(My->SYSPRN->cfp != NULL); DumpAllCommandHtmlTable (My->SYSPRN->cfp); return (l); } LineType * bwb_MAINTAINER_CMDS_ID (LineType * l) { assert (l != NULL); assert(My != NULL); assert(My->SYSPRN != NULL); assert(My->SYSPRN->cfp != NULL); DumpAllCommandUniqueID (My->SYSPRN->cfp); return (l); } LineType * bwb_MAINTAINER_CMDS_MANUAL (LineType * l) { assert (l != NULL); assert(My != NULL); assert(My->SYSPRN != NULL); assert(My->SYSPRN->cfp != NULL); DumpAllCommandSyntax (My->SYSPRN->cfp, TRUE, (OptionVersionType)(-1)); return (l); } LineType * bwb_MAINTAINER_CMDS_SWITCH (LineType * l) { assert (l != NULL); assert(My != NULL); assert(My->SYSPRN != NULL); assert(My->SYSPRN->cfp != NULL); DumpAllCommandSwitchStatement (My->SYSPRN->cfp); return (l); } LineType * bwb_MAINTAINER_CMDS_TABLE (LineType * l) { assert (l != NULL); assert(My != NULL); assert(My->SYSPRN != NULL); assert(My->SYSPRN->cfp != NULL); DumpAllCommandTableDefinitions (My->SYSPRN->cfp); return (l); } LineType * bwb_MAINTAINER_DEBUG (LineType * l) { assert (l != NULL); WARN_SYNTAX_ERROR; return (l); } LineType * bwb_MAINTAINER_DEBUG_ON (LineType * l) { assert (l != NULL); return (l); } LineType * bwb_MAINTAINER_DEBUG_OFF (LineType * l) { assert (l != NULL); return (l); } LineType * bwb_MAINTAINER_FNCS (LineType * l) { assert (l != NULL); WARN_SYNTAX_ERROR; return (l); } LineType * bwb_MAINTAINER_FNCS_HTML (LineType * l) { assert (l != NULL); assert(My != NULL); assert(My->SYSPRN != NULL); assert(My->SYSPRN->cfp != NULL); DumpAllFunctionHtmlTable (My->SYSPRN->cfp); return (l); } LineType * bwb_MAINTAINER_FNCS_ID (LineType * l) { assert (l != NULL); assert(My != NULL); assert(My->SYSPRN != NULL); assert(My->SYSPRN->cfp != NULL); DumpAllFunctionUniqueID (My->SYSPRN->cfp); return (l); } LineType * bwb_MAINTAINER_FNCS_MANUAL (LineType * l) { assert (l != NULL); assert(My != NULL); assert(My->SYSPRN != NULL); assert(My->SYSPRN->cfp != NULL); DumpAllFunctionSyntax (My->SYSPRN->cfp, TRUE, (OptionVersionType)(-1)); DumpAllOperatorSyntax (My->SYSPRN->cfp, TRUE, (OptionVersionType)(-1)); return (l); } LineType * bwb_MAINTAINER_FNCS_SWITCH (LineType * l) { assert (l != NULL); assert(My != NULL); assert(My->SYSPRN != NULL); assert(My->SYSPRN->cfp != NULL); DumpAllFunctionSwitch (My->SYSPRN->cfp); return (l); } LineType * bwb_MAINTAINER_FNCS_TABLE (LineType * l) { assert (l != NULL); assert(My != NULL); assert(My->SYSPRN != NULL); assert(My->SYSPRN->cfp != NULL); DumpAllFuctionTableDefinitions (My->SYSPRN->cfp); return (l); } void DumpHeader (FILE * file) { char c; assert (file != NULL); assert(My != NULL); assert(My->CurrentVersion != NULL); fprintf (file, "============================================================\n"); fprintf (file, " GENERAL \n"); fprintf (file, "============================================================\n"); fprintf (file, "\n"); fprintf (file, "\n"); fprintf (file, "OPTION VERSION \"%s\"\n", My->CurrentVersion->Name); fprintf (file, "REM INTERNAL ID: %s\n", My->CurrentVersion->ID); fprintf (file, "REM DESCRIPTION: %s\n", My->CurrentVersion->Description); fprintf (file, "REM REFERENCE: %s\n", My->CurrentVersion->ReferenceTitle); fprintf (file, "REM %s\n", My->CurrentVersion->ReferenceAuthor); fprintf (file, "REM %s\n", My->CurrentVersion->ReferenceCopyright); fprintf (file, "REM %s\n", My->CurrentVersion->ReferenceURL1); fprintf (file, "REM %s\n", My->CurrentVersion->ReferenceURL2); fprintf (file, "REM\n"); if (My->CurrentVersion->OptionFlags & (OPTION_STRICT_ON)) { fprintf (file, "OPTION STRICT ON\n"); } else { fprintf (file, "OPTION STRICT OFF\n"); } if (My->CurrentVersion->OptionFlags & (OPTION_ANGLE_DEGREES)) { fprintf (file, "OPTION ANGLE DEGREES\n"); } else if (My->CurrentVersion->OptionFlags & (OPTION_ANGLE_GRADIANS)) { fprintf (file, "OPTION ANGLE GRADIANS\n"); } else { fprintf (file, "OPTION ANGLE RADIANS\n"); } if (My->CurrentVersion->OptionFlags & (OPTION_BUGS_ON)) { fprintf (file, "OPTION BUGS ON\n"); } else { fprintf (file, "OPTION BUGS OFF\n"); } if (My->CurrentVersion->OptionFlags & (OPTION_LABELS_ON)) { fprintf (file, "OPTION LABELS ON\n"); } else { fprintf (file, "OPTION LABELS OFF\n"); } if (My->CurrentVersion->OptionFlags & (OPTION_COMPARE_TEXT)) { fprintf (file, "OPTION COMPARE TEXT\n"); } else { fprintf (file, "OPTION COMPARE BINARY\n"); } if (My->CurrentVersion->OptionFlags & (OPTION_COVERAGE_ON)) { fprintf (file, "OPTION COVERAGE ON\n"); } else { fprintf (file, "OPTION COVERAGE OFF\n"); } if (My->CurrentVersion->OptionFlags & (OPTION_TRACE_ON)) { fprintf (file, "OPTION TRACE ON\n"); } else { fprintf (file, "OPTION TRACE OFF\n"); } if (My->CurrentVersion->OptionFlags & (OPTION_ERROR_GOSUB)) { fprintf (file, "OPTION ERROR GOSUB\n"); } else { fprintf (file, "OPTION ERROR GOTO\n"); } if (My->CurrentVersion->OptionFlags & (OPTION_EXPLICIT_ON)) { fprintf (file, "OPTION EXPLICIT\n"); } else { fprintf (file, "OPTION IMPLICIT\n"); } fprintf (file, "OPTION BASE %d\n", My->CurrentVersion->OptionBaseInteger); fprintf (file, "OPTION RECLEN %d\n", My->CurrentVersion->OptionReclenInteger); fprintf (file, "OPTION DATE \"%s\"\n", My->CurrentVersion->OptionDateFormat); fprintf (file, "OPTION TIME \"%s\"\n", My->CurrentVersion->OptionTimeFormat); c = My->CurrentVersion->OptionStringChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT STRING \"%c\"\n", c); c = My->CurrentVersion->OptionDoubleChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT DOUBLE \"%c\"\n", c); c = My->CurrentVersion->OptionSingleChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT SINGLE \"%c\"\n", c); c = My->CurrentVersion->OptionCurrencyChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT CURRENCY \"%c\"\n", c); c = My->CurrentVersion->OptionLongChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT LONG \"%c\"\n", c); c = My->CurrentVersion->OptionIntegerChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT INTEGER \"%c\"\n", c); c = My->CurrentVersion->OptionByteChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT BYTE \"%c\"\n", c); c = My->CurrentVersion->OptionQuoteChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT QUOTE \"%c\"\n", c); c = My->CurrentVersion->OptionCommentChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT COMMENT \"%c\"\n", c); c = My->CurrentVersion->OptionStatementChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT STATEMENT \"%c\"\n", c); c = My->CurrentVersion->OptionPrintChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT PRINT \"%c\"\n", c); c = My->CurrentVersion->OptionInputChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT INPUT \"%c\"\n", c); c = My->CurrentVersion->OptionImageChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT IMAGE \"%c\"\n", c); c = My->CurrentVersion->OptionLparenChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT LPAREN \"%c\"\n", c); c = My->CurrentVersion->OptionRparenChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT RPAREN \"%c\"\n", c); c = My->CurrentVersion->OptionFilenumChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT FILENUM \"%c\"\n", c); c = My->CurrentVersion->OptionAtChar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION PUNCT AT \"%c\"\n", c); c = My->CurrentVersion->OptionUsingDigit; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION USING DIGIT \"%c\"\n", c); c = My->CurrentVersion->OptionUsingComma; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION USING COMMA \"%c\"\n", c); c = My->CurrentVersion->OptionUsingPeriod; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION USING PERIOD \"%c\"\n", c); c = My->CurrentVersion->OptionUsingPlus; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION USING PLUS \"%c\"\n", c); c = My->CurrentVersion->OptionUsingMinus; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION USING MINUS \"%c\"\n", c); c = My->CurrentVersion->OptionUsingExrad; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION USING EXRAD \"%c\"\n", c); c = My->CurrentVersion->OptionUsingDollar; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION USING DOLLAR \"%c\"\n", c); c = My->CurrentVersion->OptionUsingFiller; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION USING FILLER \"%c\"\n", c); c = My->CurrentVersion->OptionUsingLiteral; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION USING LITERAL \"%c\"\n", c); c = My->CurrentVersion->OptionUsingFirst; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION USING FIRST \"%c\"\n", c); c = My->CurrentVersion->OptionUsingAll; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION USING ALL \"%c\"\n", c); c = My->CurrentVersion->OptionUsingLength; if (!bwb_isgraph (c)) { c = ' '; }; fprintf (file, "OPTION USING LENGTH \"%c\"\n", c); fprintf (file, "\n"); fprintf (file, "\n"); fflush (file); } LineType * bwb_MAINTAINER_MANUAL (LineType * l) { assert (l != NULL); DumpHeader (My->SYSPRN->cfp); DumpAllCommandSyntax (My->SYSPRN->cfp, FALSE, My->CurrentVersion->OptionVersionValue); DumpAllFunctionSyntax (My->SYSPRN->cfp, FALSE, My->CurrentVersion->OptionVersionValue); DumpAllOperatorSyntax (My->SYSPRN->cfp, FALSE, My->CurrentVersion->OptionVersionValue); return (l); } LineType * bwb_MAINTAINER_STACK (LineType * l) { /* dump the current execution stack, Leftmost is the top, Rigthmost is the bottom. */ StackType *StackItem; assert (l != NULL); for (StackItem = My->StackHead; StackItem != NULL; StackItem = StackItem->next) { LineType *l; l = StackItem->line; if (l != NULL) { fprintf (My->SYSOUT->cfp, "%d:", l->number); } } fprintf (My->SYSOUT->cfp, "\n"); ResetConsoleColumn (); return (l); } /*************************************************************** FUNCTION: IntrinsicFunction_init() DESCRIPTION: This command initializes the function linked list, placing all predefined functions in the list. ***************************************************************/ int IntrinsicFunction_init (void) { int n; for (n = 0; n < NUM_FUNCTIONS; n++) { IntrinsicFunctionDefinitionCheck (&(IntrinsicFunctionTable[n])); } return TRUE; } VariableType * IntrinsicFunction_deffn (int argc, VariableType * argv, UserFunctionType * f) { /* The generic handler for user defined functions. When called by exp_function(), f->id will be set to the line number of a specific DEF USR. */ VariableType *v; VariableType *argn; int i; LineType *call_line; StackType *save_elevel; assert (argc >= 0); assert (argv != NULL); assert (f != NULL); assert(My != NULL); /* initialize the variable if necessary */ /* these errors should not occur */ if (f == NULL) { WARN_INTERNAL_ERROR; return NULL; } if (f->line == NULL) { WARN_INTERNAL_ERROR; return NULL; } if (argv == NULL) { WARN_INTERNAL_ERROR; return NULL; } if (f->ParameterCount == 0xFF) { /* VARIANT */ } else if (argc != f->ParameterCount) { WARN_INTERNAL_ERROR; return NULL; } if (f->ParameterCount == 0xFF) { /* VARIANT */ f->local_variable = argv; } else if (argc > 0) { v = f->local_variable; argn = argv; for (i = 0; i < argc; i++) { argn = argn->next; if (v == NULL) { WARN_INTERNAL_ERROR; return NULL; } if (argn == NULL) { WARN_INTERNAL_ERROR; return NULL; } if (VAR_IS_STRING (v) != VAR_IS_STRING (argn)) { WARN_INTERNAL_ERROR; return NULL; } if (is_empty_string (v->name) == FALSE) { int IsError; IsError = 0; switch (v->VariableTypeCode) { case ByteTypeCode: IsError = NumberValueCheck (P1BYT, PARAM_NUMBER); break; case IntegerTypeCode: IsError = NumberValueCheck (P1INT, PARAM_NUMBER); break; case LongTypeCode: IsError = NumberValueCheck (P1LNG, PARAM_NUMBER); break; case CurrencyTypeCode: IsError = NumberValueCheck (P1CUR, PARAM_NUMBER); break; case SingleTypeCode: IsError = NumberValueCheck (P1FLT, PARAM_NUMBER); break; case DoubleTypeCode: IsError = NumberValueCheck (P1DBL, PARAM_NUMBER); break; case StringTypeCode: IsError = StringLengthCheck (P1ANY, PARAM_LENGTH); break; default: WARN_TYPE_MISMATCH; return NULL; } if (IsError != 0) { WARN_ILLEGAL_FUNCTION_CALL; return argv; } } v = v->next; } } /* OK */ call_line = f->line; /* line to call for function */ call_line->position = f->startpos; if (call_line->cmdnum == C_DEF) { if (line_skip_EqualChar (call_line) == FALSE) { WARN_INTERNAL_ERROR; return NULL; } } /* PUSH STACK */ save_elevel = My->StackHead; if (bwb_incexec ()) { /* OK */ My->StackHead->line = call_line; My->StackHead->ExecCode = EXEC_FUNCTION; } else { /* ERROR */ WARN_OUT_OF_MEMORY; return NULL; } /* create variable chain */ if (f->ParameterCount == 0xFF) { /* VARIANT */ } else if (argc > 0) { VariableType *source = NULL; /* source variable */ source = f->local_variable; argn = argv; for (i = 0; i < argc; i++) { argn = argn->next; /* copy the name */ bwb_strcpy (argn->name, source->name); if (VAR_IS_STRING (source)) { } else { int IsError; double Value; VariantType variant; CLEAR_VARIANT (&variant); if (var_get (argn, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return NULL; } if (variant.VariantTypeCode == StringTypeCode) { WARN_TYPE_MISMATCH; return NULL; } Value = variant.Number; IsError = 0; switch (source->VariableTypeCode) { case ByteTypeCode: IsError = NumberValueCheck (P1BYT, Value); Value = bwb_rint (Value); break; case IntegerTypeCode: IsError = NumberValueCheck (P1INT, Value); Value = bwb_rint (Value); break; case LongTypeCode: IsError = NumberValueCheck (P1LNG, Value); Value = bwb_rint (Value); break; case CurrencyTypeCode: IsError = NumberValueCheck (P1CUR, Value); Value = bwb_rint (Value); break; case SingleTypeCode: IsError = NumberValueCheck (P1FLT, Value); break; case DoubleTypeCode: IsError = NumberValueCheck (P1DBL, Value); break; case StringTypeCode: WARN_TYPE_MISMATCH; return NULL; /* break; */ default: WARN_TYPE_MISMATCH; return NULL; } if (IsError != 0) { WARN_ILLEGAL_FUNCTION_CALL; return argv; } variant.Number = Value; if (var_set (argn, &variant) == FALSE) { WARN_VARIABLE_NOT_DECLARED; return NULL; } } source = source->next; } } if (call_line->cmdnum == C_DEF) { VariantType x; VariantType *X; X = &x; CLEAR_VARIANT (X); /* the function return variable is hidden */ My->StackHead->local_variable = argv->next; /* var_islocal() uses the LoopTopLine to find local variables */ My->StackHead->LoopTopLine = call_line; /* FUNCTION, SUB */ /* evaluate the expression */ if (line_read_expression (call_line, X) == FALSE) /* IntrinsicFunction_deffn */ { WARN_SYNTAX_ERROR; goto EXIT; } /* save the value */ switch (X->VariantTypeCode) { case ByteTypeCode: case IntegerTypeCode: case LongTypeCode: case CurrencyTypeCode: case SingleTypeCode: case DoubleTypeCode: if (argv->VariableTypeCode == StringTypeCode) { WARN_TYPE_MISMATCH; goto EXIT; } /* OK */ { int IsError; double Value; IsError = 0; Value = X->Number; /* VerifyNumeric */ if (isnan (Value)) { /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/ WARN_INTERNAL_ERROR; return FALSE; } if (isinf (Value)) { /* - Evaluation of an expression results in an overflow * (nonfatal, the recommended recovery procedure is to supply * machine in- finity with the algebraically correct sign and * continue). */ if (Value < 0) { Value = MINDBL; } else { Value = MAXDBL; } if (WARN_OVERFLOW) { /* ERROR */ goto EXIT; } /* CONTINUE */ } /* OK */ switch (argv->VariableTypeCode) { case ByteTypeCode: IsError = NumberValueCheck (P1BYT, Value); Value = bwb_rint (Value); break; case IntegerTypeCode: IsError = NumberValueCheck (P1INT, Value); Value = bwb_rint (Value); break; case LongTypeCode: IsError = NumberValueCheck (P1LNG, Value); Value = bwb_rint (Value); break; case CurrencyTypeCode: IsError = NumberValueCheck (P1CUR, Value); Value = bwb_rint (Value); break; case SingleTypeCode: IsError = NumberValueCheck (P1FLT, Value); break; case DoubleTypeCode: IsError = NumberValueCheck (P1DBL, Value); break; default: WARN_TYPE_MISMATCH; goto EXIT; /* break; */ } if (IsError != 0) { if (WARN_OVERFLOW) { /* ERROR */ goto EXIT; } /* CONTINUE */ } /* assign Value */ RESULT_NUMBER = Value; } break; case StringTypeCode: if (argv->VariableTypeCode != StringTypeCode) { WARN_TYPE_MISMATCH; goto EXIT; } /* OK */ if (RESULT_BUFFER != My->MaxLenBuffer) { WARN_INTERNAL_ERROR; goto EXIT; } if (X->Length > MAXLEN) { WARN_STRING_TOO_LONG; /* IntrinsicFunction_deffn */ X->Length = MAXLEN; } bwb_memcpy (RESULT_BUFFER, X->Buffer, X->Length); RESULT_LENGTH = X->Length; break; default: WARN_TYPE_MISMATCH; goto EXIT; /* break; */ } EXIT: RELEASE_VARIANT (X); /* break variable chain */ My->StackHead->local_variable = NULL; /* POP STACK */ bwb_decexec (); } else { /* the function return variable is visible */ My->StackHead->local_variable = argv; /* var_islocal() uses the LoopTopLine to find local variables */ My->StackHead->LoopTopLine = call_line; /* FUNCTION, SUB */ /* execute until function returns */ while (My->StackHead != save_elevel) { bwb_execline (); } } if (f->ParameterCount == 0xFF) { /* VARIANT */ f->local_variable = NULL; } if (is_empty_string (argv->name) == FALSE) { int IsError; IsError = 0; switch (argv->VariableTypeCode) { case ByteTypeCode: IsError = NumberValueCheck (P1BYT, RESULT_NUMBER); break; case IntegerTypeCode: IsError = NumberValueCheck (P1INT, RESULT_NUMBER); break; case LongTypeCode: IsError = NumberValueCheck (P1LNG, RESULT_NUMBER); break; case CurrencyTypeCode: IsError = NumberValueCheck (P1CUR, RESULT_NUMBER); break; case SingleTypeCode: IsError = NumberValueCheck (P1FLT, RESULT_NUMBER); break; case DoubleTypeCode: IsError = NumberValueCheck (P1DBL, RESULT_NUMBER); break; case StringTypeCode: IsError = StringLengthCheck (P1ANY, RESULT_LENGTH); break; default: /* no check */ break; } if (IsError != 0) { if (WARN_OVERFLOW) { /* ERROR */ } /* CONTINUE */ } } return argv; } /*************************************************************** FUNCTION: IntrinsicFunction_find() DESCRIPTION: This C function attempts to locate a BASIC function with the specified name. If successful, it returns a pointer to the C structure for the BASIC function, if not successful, it returns NULL. ***************************************************************/ extern int IntrinsicFunction_name (char *name) { /* search INTRINSIC functions */ IntrinsicFunctionType *f; int i; assert (name != NULL); assert(My != NULL); assert(My->CurrentVersion != NULL); #if THE_PRICE_IS_RIGHT /* start with the closest function, without going over */ i = VarTypeIndex (name[0]); if (i < 0) { /* non-alpha */ return FALSE; } i = My->IntrinsicFunctionStart[i]; /* first function starting with this letter */ if (i < 0) { /* NOT FOUND */ return FALSE; } #else /* THE_PRICE_IS_RIGHT */ i = 0; #endif /* THE_PRICE_IS_RIGHT */ for (; i < NUM_FUNCTIONS; i++) { f = &IntrinsicFunctionTable[i]; if (My->CurrentVersion->OptionVersionValue & f->OptionVersionBitmask) { int result; result = bwb_stricmp (f->Name, name); if (result == 0) { /* FOUND */ return TRUE; } if (result > 0 /* found > searched */ ) { /* NOT FOUND */ return FALSE; } } } /* NOT FOUND */ return FALSE; } IntrinsicFunctionType * IntrinsicFunction_find_exact (char *name, int ParameterCount, ParamBitsType ParameterTypes) { IntrinsicFunctionType *f; int i; assert (name != NULL); assert(My != NULL); assert(My->CurrentVersion != NULL); /* search INTRINSIC functions */ #if THE_PRICE_IS_RIGHT /* start with the closest function, without going over */ i = VarTypeIndex (name[0]); if (i < 0) { /* non-alpha */ return NULL; } i = My->IntrinsicFunctionStart[i]; /* first function starting with this letter */ if (i < 0) { /* NOT FOUND */ return NULL; } #else /* THE_PRICE_IS_RIGHT */ i = 0; #endif /* THE_PRICE_IS_RIGHT */ for (; i < NUM_FUNCTIONS; i++) { f = &IntrinsicFunctionTable[i]; if (My->CurrentVersion->OptionVersionValue & f->OptionVersionBitmask) { if (f->ParameterCount == ParameterCount) { if (f->ParameterTypes == ParameterTypes) { int result; result = bwb_stricmp (f->Name, name); if (result == 0) { /* FOUND */ return f; } if (result > 0 /* found > searched */ ) { /* NOT FOUND */ return NULL; } } } } } /* NOT FOUND */ return NULL; } static VariableType * find_variable_by_type (char *name, int dimensions, char VariableTypeCode) { VariableType *v = NULL; assert (name != NULL); v = var_find (name, dimensions, FALSE); if (v) { if (VAR_IS_STRING (v)) { if (VariableTypeCode == StringTypeCode) { /* found */ return v; } } else { if (VariableTypeCode != StringTypeCode) { /* found */ return v; } } } /* not found */ return NULL; } /* -------------------------------------------------------------------------------------------- CHANGE -------------------------------------------------------------------------------------------- */ LineType * bwb_CHANGE (LineType * l) { /* SYNTAX: CHANGE A$ TO X */ /* SYNTAX: CHANGE X TO A$ */ char varname[NameLengthMax + 1]; VariableType *v; VariableType *A; VariableType *X; int IsStringToArray; assert (l != NULL); v = NULL; A = NULL; X = NULL; IsStringToArray = FALSE; /* get 1st variable */ if (line_read_varname (l, varname) == FALSE) { WARN_SYNTAX_ERROR; return (l); } v = find_variable_by_type (varname, 0, StringTypeCode); if (v) { /* STRING to ARRAY */ A = v; IsStringToArray = TRUE; } else { /* ARRAY to STRING */ v = find_variable_by_type (varname, 1, DoubleTypeCode); if (v) { X = v; IsStringToArray = FALSE; } } if (v == NULL) { WARN_VARIABLE_NOT_DECLARED; return (l); } /* get "TO" */ if (line_skip_word (l, "TO") == FALSE) { WARN_SYNTAX_ERROR; return (l); } /* get 2nd variable */ if (line_read_varname (l, varname) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (IsStringToArray) { /* STRING to ARRAY */ v = find_variable_by_type (varname, 1, DoubleTypeCode); if (v == NULL) { v = var_find (varname, 1, TRUE); } if (v) { X = v; } } else { /* ARRAY to STRING */ v = find_variable_by_type (varname, 0, StringTypeCode); if (v == NULL) { v = var_find (varname, 0, TRUE); } if (v) { A = v; } } if (v == NULL) { WARN_VARIABLE_NOT_DECLARED; return (l); } assert(A != NULL); assert(X != NULL); if (IsStringToArray) { /* CHANGE A$ TO X */ int i; int n; char *a; DoubleType *x; unsigned long t; if (A->Value.String == NULL) { WARN_INTERNAL_ERROR; return (l); } if (A->Value.String->sbuffer == NULL) { WARN_INTERNAL_ERROR; return (l); } /* variable storage is a mess, we bypass that tradition here. */ t = 1; for (n = 0; n < X->dimensions; n++) { t *= X->UBOUND[n] - X->LBOUND[n] + 1; } if (t <= A->Value.String->length) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } n = A->Value.String->length; a = A->Value.String->sbuffer; x = X->Value.Number; *x = n; x++; for (i = 0; i < n; i++) { char C; DoubleType V; C = *a; V = C; *x = V; x++; a++; } } else { /* CHANGE X TO A$ */ int i; int n; char *a; DoubleType *x; unsigned long t; /* variable storage is a mess, we bypass that tradition here. */ t = 1; for (n = 0; n < X->dimensions; n++) { t *= X->UBOUND[n] - X->LBOUND[n] + 1; } if (t <= 1) { WARN_SUBSCRIPT_OUT_OF_RANGE; return (l); } if (t > MAXLEN) { WARN_STRING_TOO_LONG; /* bwb_CHANGE */ t = MAXLEN; } if (A->Value.String == NULL) { if ((A->Value.String = (StringType *) calloc (1, sizeof (StringType))) == NULL) { WARN_OUT_OF_MEMORY; return (l); } A->Value.String->sbuffer = NULL; A->Value.String->length = 0; } if (A->Value.String->sbuffer != NULL) { free (A->Value.String->sbuffer); A->Value.String->sbuffer = NULL; A->Value.String->length = 0; } if (A->Value.String->sbuffer == NULL) { A->Value.String->length = 0; if ((A->Value.String->sbuffer = (char *) calloc (t + 1 /* NulChar */ , sizeof (char))) == NULL) { WARN_OUT_OF_MEMORY; return (l); } } a = A->Value.String->sbuffer; x = X->Value.Number; n = (int) bwb_rint (*x); if (n > MAXLEN) { WARN_STRING_TOO_LONG; /* bwb_CHANGE */ n = MAXLEN; } A->Value.String->length = n; x++; for (i = 0; i < n; i++) { char C; DoubleType V; V = *x; C = V; *a = C; x++; a++; } } return (l); } /* -------------------------------------------------------------------------------------------- CONSOLE -------------------------------------------------------------------------------------------- */ LineType * bwb_CONSOLE (LineType * l) { /* SYNTAX: CONSOLE */ /* SYNTAX: CONSOLE WIDTH width */ assert (l != NULL); assert(My != NULL); assert(My->SYSPRN != NULL); assert(My->SYSPRN->cfp != NULL); assert(My->SYSOUT != NULL); assert(My->SYSOUT->cfp != NULL); if (My->IsPrinter == TRUE) { /* reset printer column */ if (My->SYSPRN->col != 1) { fputc ('\n', My->SYSPRN->cfp); My->SYSPRN->col = 1; } My->IsPrinter = FALSE; } if (line_skip_word (l, "WIDTH")) { int width; width = 0; if (line_read_integer_expression (l, &width) == FALSE) { WARN_ILLEGAL_FUNCTION_CALL; return (l); } if (width < 0) { WARN_ILLEGAL_FUNCTION_CALL; return (l); } My->SYSOUT->width = width; } return (l); } /* -------------------------------------------------------------------------------------------- LPRINTER -------------------------------------------------------------------------------------------- */ LineType * bwb_LPRINTER (LineType * l) { /* SYNTAX: LPRINTER */ /* SYNTAX: LPRINTER WIDTH width */ assert (l != NULL); assert(My != NULL); assert(My->SYSPRN != NULL); assert(My->SYSPRN->cfp != NULL); assert(My->SYSOUT != NULL); assert(My->SYSOUT->cfp != NULL); if (My->IsPrinter == FALSE) { /* reset console column */ if (My->SYSOUT->col != 1) { fputc ('\n', My->SYSOUT->cfp); My->SYSOUT->col = 1; } My->IsPrinter = TRUE; } if (line_skip_word (l, "WIDTH")) { int width; width = 0; if (line_read_integer_expression (l, &width) == FALSE) { WARN_ILLEGAL_FUNCTION_CALL; return (l); } if (width < 0) { WARN_ILLEGAL_FUNCTION_CALL; return (l); } My->SYSPRN->width = width; } return (l); } extern void bwb_fclose (FILE * file) { if (file == NULL) { /* don't close */ } else if (file == stdin) { /* don't close */ } else if (file == stdout) { /* don't close */ } else if (file == stderr) { /* don't close */ } else { fclose (file); } } LineType * bwb_LPT (LineType * l) { /* SYNTAX: LPT */ /* SYNTAX: LPT filename$ */ FILE *file; char *filename; assert (l != NULL); assert(My != NULL); assert(My->SYSOUT != NULL); assert(My->SYSOUT->cfp != NULL); file = NULL; filename = NULL; if (line_is_eol (l)) { /* OK */ file = stderr; } else if (line_read_string_expression (l, &filename)) { /* OK */ if (is_empty_string (filename)) { WARN_BAD_FILE_NAME; return (l); } file = fopen (filename, "w"); free (filename); } else { WARN_SYNTAX_ERROR; return (l); } if (file == NULL) { WARN_BAD_FILE_NAME; return (l); } bwb_fclose (My->SYSOUT->cfp); My->SYSOUT->cfp = file; return (l); } LineType * bwb_PTP (LineType * l) { /* SYNTAX: PTP */ /* SYNTAX: PTP filename$ */ FILE *file; char *filename; assert (l != NULL); assert(My != NULL); assert(My->SYSOUT != NULL); assert(My->SYSOUT->cfp != NULL); file = NULL; filename = NULL; if (line_is_eol (l)) { /* OK */ file = fopen ("PTP", "w"); } else if (line_read_string_expression (l, &filename)) { /* OK */ if (is_empty_string (filename)) { WARN_BAD_FILE_NAME; return (l); } file = fopen (filename, "w"); free (filename); } else { WARN_SYNTAX_ERROR; return (l); } if (file == NULL) { WARN_BAD_FILE_NAME; return (l); } bwb_fclose (My->SYSOUT->cfp); My->SYSOUT->cfp = file; return (l); } LineType * bwb_PTR (LineType * l) { /* SYNTAX: PTR */ /* SYNTAX: PTR filename$ */ FILE *file; char *filename; assert (l != NULL); assert(My != NULL); assert(My->SYSIN != NULL); assert(My->SYSIN->cfp != NULL); file = NULL; filename = NULL; if (line_is_eol (l)) { /* OK */ file = fopen ("PTR", "r"); } else if (line_read_string_expression (l, &filename)) { /* OK */ if (is_empty_string (filename)) { WARN_BAD_FILE_NAME; return (l); } file = fopen (filename, "r"); free (filename); } else { WARN_SYNTAX_ERROR; return (l); } if (file == NULL) { WARN_BAD_FILE_NAME; return (l); } bwb_fclose (My->SYSIN->cfp); My->SYSIN->cfp = file; return (l); } LineType * bwb_TTY (LineType * l) { /* SYNTAX: TTY */ assert (l != NULL); bwb_TTY_IN (l); bwb_TTY_OUT (l); return (l); } LineType * bwb_TTY_IN (LineType * l) { /* SYNTAX: TTY IN */ assert (l != NULL); assert(My != NULL); assert(My->SYSIN != NULL); assert(My->SYSIN->cfp != NULL); bwb_fclose (My->SYSIN->cfp); My->SYSIN->cfp = stdin; return (l); } LineType * bwb_TTY_OUT (LineType * l) { /* SYNTAX: TTY OUT */ assert (l != NULL); assert(My != NULL); assert(My->SYSOUT != NULL); assert(My->SYSOUT->cfp != NULL); bwb_fclose (My->SYSOUT->cfp); My->SYSOUT->cfp = stdout; return (l); } /* -------------------------------------------------------------------------------------------- CREATE -------------------------------------------------------------------------------------------- */ LineType * bwb_CREATE (LineType * l) { /* SYNTAX: CREATE filename$ [ RECL reclen ] AS filenum [ BUFF number ] [ RECS size ] */ int FileNumber; int width; int buffnum; int recsnum; char *filename; assert (l != NULL); assert(My != NULL); FileNumber = 0; width = 0; buffnum = 0; recsnum = 0; filename = NULL; if (line_read_string_expression (l, &filename) == FALSE) { WARN_SYNTAX_ERROR; return (l); } if (is_empty_string (filename)) { WARN_BAD_FILE_NAME; return (l); } if (line_skip_word (l, "RECL")) { if (line_read_integer_expression (l, &width) == FALSE) { WARN_FIELD_OVERFLOW; return (l); } if (width <= 0) { WARN_FIELD_OVERFLOW; return (l); } } if (line_skip_word (l, "AS") == FALSE) { WARN_SYNTAX_ERROR; return (l); } 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, "BUFF")) { if (line_read_integer_expression (l, &buffnum) == FALSE) { WARN_FIELD_OVERFLOW; return (l); } if (buffnum <= 0) { WARN_FIELD_OVERFLOW; return (l); } } if (line_skip_word (l, "RECS")) { if (line_read_integer_expression (l, &recsnum) == FALSE) { WARN_FIELD_OVERFLOW; return (l); } if (recsnum <= 0) { WARN_FIELD_OVERFLOW; 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; } if (My->CurrentFile->FileName != NULL) { free (My->CurrentFile->FileName); My->CurrentFile->FileName = NULL; } My->CurrentFile->FileName = filename; filename = NULL; if (My->CurrentFile->DevMode != DEVMODE_CLOSED) { My->CurrentFile->DevMode = DEVMODE_CLOSED; } if (My->CurrentFile->cfp != NULL) { bwb_fclose (My->CurrentFile->cfp); My->CurrentFile->cfp = NULL; } if (My->CurrentFile->buffer != NULL) { free (My->CurrentFile->buffer); My->CurrentFile->buffer = NULL; } My->CurrentFile->width = 0; My->CurrentFile->col = 1; My->CurrentFile->row = 1; My->CurrentFile->delimit = ','; /* truncate to zero length or create text file for update (reading and writing) */ if (is_empty_string (My->CurrentFile->FileName)) { WARN_BAD_FILE_NAME; return (l); } if ((My->CurrentFile->cfp = fopen (My->CurrentFile->FileName, "w+")) == NULL) { WARN_BAD_FILE_NAME; return (l); } if (width > 0) { My->CurrentFile->width = width; My->CurrentFile->DevMode = DEVMODE_RANDOM; } else { My->CurrentFile->DevMode = DEVMODE_INPUT | DEVMODE_OUTPUT; } return (l); } /* -------------------------------------------------------------------------------------------- COPY -------------------------------------------------------------------------------------------- */ static void bwb_copy_file (char *Source, char *Target) { FILE *source; FILE *target; source = NULL; target = NULL; if (is_empty_string (Source)) { WARN_BAD_FILE_NAME; goto EXIT; } if (is_empty_string (Target)) { WARN_BAD_FILE_NAME; goto EXIT; } source = fopen (Source, "rb"); if (source == NULL) { WARN_BAD_FILE_NAME; goto EXIT; } target = fopen (Target, "wb"); if (target == NULL) { WARN_BAD_FILE_NAME; goto EXIT; } /* OK */ while (TRUE) { int C; C = fgetc (source); if (C < 0 /* EOF */ || feof (source) || ferror (source)) { break; } fputc (C, target); if (ferror (target)) { break; } } /* DONE */ EXIT: if (source) { fclose (source); } if (target) { fclose (target); } } LineType * bwb_COPY (LineType * Line) { /* SYNTAX: COPY source$ TO target$ */ char *Source; char *Target; assert (Line != NULL); Source = NULL; Target = NULL; if (line_read_string_expression (Line, &Source) == FALSE) { WARN_SYNTAX_ERROR; goto EXIT; } if (line_skip_word (Line, "TO") == FALSE) { WARN_SYNTAX_ERROR; goto EXIT; } if (line_read_string_expression (Line, &Target) == FALSE) { WARN_SYNTAX_ERROR; goto EXIT; } bwb_copy_file (Source, Target); EXIT: if (Source) { free (Source); } if (Target) { free (Target); } return (Line); } /* -------------------------------------------------------------------------------------------- DISPLAY -------------------------------------------------------------------------------------------- */ static void bwb_display_file (char *Source) { FILE *source; assert (My->SYSOUT != NULL); assert (My->SYSOUT->cfp != NULL); source = NULL; if (is_empty_string (Source)) { WARN_BAD_FILE_NAME; goto EXIT; } source = fopen (Source, "rb"); if (source == NULL) { WARN_BAD_FILE_NAME; goto EXIT; } /* OK */ while (TRUE) { int C; C = fgetc (source); if (C < 0 /* EOF */ || feof (source) || ferror (source)) { break; } fputc (C, My->SYSOUT->cfp); } /* DONE */ EXIT: if (source) { fclose (source); } } LineType * bwb_DISPLAY (LineType * Line) { /* SYNTAX: DISPLAY source$ */ char *Source; assert (Line != NULL); Source = NULL; if (line_read_string_expression (Line, &Source) == FALSE) { WARN_SYNTAX_ERROR; goto EXIT; } bwb_display_file (Source); EXIT: if (Source) { free (Source); } return (Line); } /* -------------------------------------------------------------------------------------------- EOF -------------------------------------------------------------------------------------------- */ /* EOF */