|
- /***************************************************************
-
- 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 */
- /* */
- /* Version 3.20A by Ken Martin Mainly corrected fprint issues */
- /* */
- /*---------------------------------------------------------------*/
-
-
-
- #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, "%s", 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, "%s", tbuf);
- fprintf (file, ", /* UniqueID */\n");
-
- fprintf (file, " ");
- fprintf (file, "\"");
- ProcessEscapeChars (IntrinsicCommandTable[i].Syntax, tbuf);
- fprintf (file, "%s", tbuf);
- fprintf (file, "\"");
- fprintf (file, ", /* Syntax */\n");
-
- fprintf (file, " ");
- fprintf (file, "\"");
- ProcessEscapeChars (IntrinsicCommandTable[i].Description, tbuf);
- fprintf (file, "%s", tbuf);
- fprintf (file, "\"");
- fprintf (file, ", /* Description */\n");
-
- fprintf (file, " ");
- fprintf (file, "\"");
- fprintf (file, "%s", IntrinsicCommandTable[i].name);
- fprintf (file, "\"");
- fprintf (file, ", /* Name */\n");
-
- fprintf (file, " ");
- CommandOptionVersion (i, tbuf);
- fprintf (file, "%s", 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, "%s", tbuf);
- fprintf (file, ":\n");
-
- fprintf (file, " ");
- fprintf (file, " ");
- fprintf (file, "r = ");
- CommandVector (i, tbuf);
- fprintf (file, "%s", 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, "<html><head><title>CMDS</title></head><body>\n");
- fprintf (file, "<h1>LEGEND</h1><br>\n");
- fprintf (file, "<table>\n");
-
- fprintf (file, "<tr>");
- fprintf (file, "<td>");
- fprintf (file, "<b>");
- fprintf (file, "ID");
- fprintf (file, "</b>");
- fprintf (file, "</td>");
- fprintf (file, "<td>");
- fprintf (file, "<b>");
- fprintf (file, "NAME");
- fprintf (file, "</b>");
- fprintf (file, "</td>");
- fprintf (file, "<td>");
- fprintf (file, "<b>");
- fprintf (file, "DESCRIPTION");
- fprintf (file, "</b>");
- fprintf (file, "</td>");
- fprintf (file, "</tr>\n");
-
- for (j = 0; j < NUM_VERSIONS; j++)
- {
- fprintf (file, "<tr>");
- fprintf (file, "<td>");
- fprintf (file, "%s", bwb_vertable[j].ID);
- fprintf (file, "</td>");
- fprintf (file, "<td>");
- fprintf (file, "%s", bwb_vertable[j].Name);
- fprintf (file, "</td>");
- fprintf (file, "<td>");
- fprintf (file, "%s", bwb_vertable[j].Description);
- fprintf (file, "</td>");
- fprintf (file, "</tr>\n");
- }
- fprintf (file, "</table>\n");
- fprintf (file, "<hr>\n");
-
-
- /* DETAILS */
- fprintf (file, "<h1>DETAILS</h1><br>\n");
- fprintf (file, "<table>\n");
-
- fprintf (file, "<tr>");
- fprintf (file, "<td>");
- fprintf (file, "<b>");
- fprintf (file, "COMMAND");
- fprintf (file, "</b>");
- fprintf (file, "</td>");
- for (j = 0; j < NUM_VERSIONS; j++)
- {
- fprintf (file, "<td>");
- fprintf (file, "<b>");
- fprintf (file, "%s", bwb_vertable[j].ID);
- fprintf (file, "</b>");
- fprintf (file, "</td>");
- }
- fprintf (file, "</tr>\n");
-
-
- /* run through the command table and print comand -vs- OPTION VERSION */
-
- for (i = 0; i < NUM_COMMANDS; i++)
- {
- fprintf (file, "<tr>");
- fprintf (file, "<td>");
- fprintf (file, "%s", (char *) IntrinsicCommandTable[i].Syntax);
- fprintf (file, "</td>");
-
- for (j = 0; j < NUM_VERSIONS; j++)
- {
- fprintf (file, "<td>");
- if (IntrinsicCommandTable[i].OptionVersionBitmask & bwb_vertable[j].
- OptionVersionValue)
- {
- fprintf (file, "X");
- }
- else
- {
- fprintf (file, " ");
- }
- fprintf (file, "</td>");
- }
- fprintf (file, "</tr>\n");
- }
- fprintf (file, "</table>\n");
- fprintf (file, "</body></html>\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, "%s", 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, "%s", 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, "%s", 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, "%s", 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, "%s", 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, "%s", 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, "%s", 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, "%s", 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, "<html><head><title>FNCS</title></head><body>\n");
- fprintf (file, "<h1>LEGEND</h1><br>\n");
- fprintf (file, "<table>\n");
-
- fprintf (file, "<tr>");
- fprintf (file, "<td>");
- fprintf (file, "<b>");
- fprintf (file, "ID");
- fprintf (file, "</b>");
- fprintf (file, "</td>");
- fprintf (file, "<td>");
- fprintf (file, "<b>");
- fprintf (file, "NAME");
- fprintf (file, "</b>");
- fprintf (file, "</td>");
- fprintf (file, "<td>");
- fprintf (file, "<b>");
- fprintf (file, "DESCRIPTION");
- fprintf (file, "</b>");
- fprintf (file, "</td>");
- fprintf (file, "</tr>\n");
-
- for (j = 0; j < NUM_VERSIONS; j++)
- {
- fprintf (file, "<tr>");
- fprintf (file, "<td>");
- fprintf (file, "%s", bwb_vertable[j].ID);
- fprintf (file, "</td>");
- fprintf (file, "<td>");
- fprintf (file, "%s", bwb_vertable[j].Name);
- fprintf (file, "</td>");
- fprintf (file, "<td>");
- fprintf (file, "%s", bwb_vertable[j].Description);
- fprintf (file, "</td>");
- fprintf (file, "</tr>\n");
- }
- fprintf (file, "</table>\n");
- fprintf (file, "<hr>\n");
-
-
- /* DETAILS */
- fprintf (file, "<h1>DETAILS</h1><br>\n");
- fprintf (file, "<table>\n");
-
- fprintf (file, "<tr>");
- fprintf (file, "<td>");
- fprintf (file, "<b>");
- fprintf (file, "FUNCTION");
- fprintf (file, "</b>");
- fprintf (file, "</td>");
- for (j = 0; j < NUM_VERSIONS; j++)
- {
- fprintf (file, "<td>");
- fprintf (file, "<b>");
- fprintf (file, "%s", bwb_vertable[j].ID);
- fprintf (file, "</b>");
- fprintf (file, "</td>");
- }
- fprintf (file, "</tr>\n");
-
-
- /* run through the command table and print comand -vs- OPTION VERSION */
-
- for (i = 0; i < NUM_FUNCTIONS; i++)
- {
- fprintf (file, "<tr>");
- fprintf (file, "<td>");
- fprintf (file, "%s", (char *) IntrinsicFunctionTable[i].Syntax);
- fprintf (file, "</td>");
-
- for (j = 0; j < NUM_VERSIONS; j++)
- {
- fprintf (file, "<td>");
- if (IntrinsicFunctionTable[i].OptionVersionBitmask & bwb_vertable[j].
- OptionVersionValue)
- {
- fprintf (file, "X");
- }
- else
- {
- fprintf (file, " ");
- }
- fprintf (file, "</td>");
- }
- fprintf (file, "</tr>\n");
- }
- fprintf (file, "</table>\n");
- fprintf (file, "</body></html>\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, "%s", 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 */
|