$ include "seed7_05.s7i";
include "stdio.s7i";
include "osfiles.s7i";
include "scanfile.s7i";
include "scanstri.s7i";
include "chartype.s7i";
include "float.s7i";
include "console.s7i";
include "draw.s7i";
include "graph_file.s7i";
include "window.s7i";
include "keybd.s7i";
include "keydescr.s7i";
include "echo.s7i";
include "line.s7i";
include "time.s7i";
include "duration.s7i";
include "math.s7i";
include "bin32.s7i";
include "bin64.s7i";
include "wildcard.s7i";
include "logfile.s7i";
include "font8x8.s7i";
include "pixmap_file.s7i";
include "editline.s7i";
const integer: MAX_LINENUM is 2147483647;
const integer: TEXT_LINES is 25;
const integer: TEXT_COLUMNS is 80;
const set of char: basic_name_char is alphanum_char | {'.'};
const set of char: number_suffix is {'%', '!', '#', '&'};
const set of char: numeric_var_suffix is {'%', '!', '#'};
const type: lineType is new struct
var string: fileName is "";
var integer: fileLine is 0;
var string: linenum is "";
var string: label is "";
var string: line is "";
end struct;
var array lineType: prg is 0 times lineType.value;
var string: command_line is "";
var logFile: log is STD_NULL;
var file: err is STD_NULL;
var text: scr is STD_NULL;
var text: win is STD_NULL;
var integer: file_line_number is 0;
var string: statement_label is "";
var string: on_error_label is "";
var integer: error_code is 0;
var string: error_linenum is "";
var integer: resume_next_line is 0;
var integer: resume_next_column is 0;
var integer: resume_same_line is 0;
var integer: resume_same_column is 0;
var boolean: in_error_handler is FALSE;
const type: label_hash is hash [string] integer;
var label_hash: label is label_hash.EMPTY_HASH;
var label_hash: subprogram is label_hash.EMPTY_HASH;
var label_hash: subfunction is label_hash.EMPTY_HASH;
var label_hash: sub_declared is label_hash.EMPTY_HASH;
const type: stringSet is set of string;
enable_output(stringSet);
var stringSet: usedLabel is stringSet.value;
var stringSet: usedAsStatement is stringSet.value;
const type: fileLineList is array integer;
const type: multipleDefinedType is hash [string] fileLineList;
var multipleDefinedType: multipleDefinedLabel is multipleDefinedType.value;
var integer: data_line_number is 0;
var string: data_line is "";
var string: varseg_variable is "";
var set of char: defstr_var is (set of char).EMPTY_SET;
const type: defFnType is new struct
var string: name is "";
var string: params is "";
var string: expression is "";
end struct;
const type: def_fn_hash is hash [string] defFnType;
var def_fn_hash: def_fn_list is def_fn_hash.EMPTY_HASH;
const type: numeric_hash is hash [string] float;
var numeric_hash: numeric_var is numeric_hash.EMPTY_HASH;
const type: string_hash is hash [string] string;
var string_hash: string_var is string_hash.EMPTY_HASH;
var stringSet: string_var_name is stringSet.value;
const type: image_hash is hash [string] PRIMITIVE_WINDOW;
var image_hash: image_var is image_hash.EMPTY_HASH;
const type: file_hash is hash [integer] file;
var file_hash: file_value is file_hash.EMPTY_HASH;
const type: varptr_hash is hash [string] integer;
var varptr_hash: varptr_value is varptr_hash.EMPTY_HASH;
const type: varname_hash is hash [integer] string;
var varname_hash: varname_value is varname_hash.EMPTY_HASH;
const type: reclen_array is array integer;
var reclen_array: reclen_value is 256 times 0;
const type: field_type is array string;
const type: field_array is array field_type;
var field_array: field_value is 256 times 0 times "";
const type: forLoopDescrType is new struct
var string: varName is "";
var float: endValue is 0.0;
var float: stepValue is 0.0;
var integer: bodyLine is 0;
var integer: bodyColumn is 0;
end struct;
var array forLoopDescrType: forLoop is 0 times forLoopDescrType.value;
const type: whileLoopDescrType is new struct
var integer: condLine is 0;
var integer: condColumn is 0;
end struct;
var array whileLoopDescrType: whileLoop is 0 times whileLoopDescrType.value;
const type: doLoopDescrType is new struct
var integer: headLine is 0;
var integer: headColumn is 0;
end struct;
var array doLoopDescrType: doLoop is 0 times doLoopDescrType.value;
const type: doLoopHeaderInColumn is hash [integer] doLoopDescrType;
const type: doLoopHeaderData is hash [integer] doLoopHeaderInColumn;
var doLoopHeaderData: doLoopHeaders is doLoopHeaderData.EMPTY_HASH;
const type: gosubReturnDescrType is new struct
var integer: returnLine is 0;
var integer: returnColumn is 0;
var integer: subEntryLine is 0;
var string: subName is "";
var integer: forLoopStackDepth is 0;
var integer: whileLoopStackDepth is 0;
var integer: doLoopStackDepth is 0;
end struct;
var array gosubReturnDescrType: gosubReturn is 0 times gosubReturnDescrType.value;
const type: boundsType is new struct
var integer: lbound is 0;
var integer: ubound is 0;
end struct;
const type: dimensionType is array boundsType;
var float: lastRandomNumber is 0.0;
var integer: screenMode is 0;
var integer: currX is 0;
var integer: currY is 0;
var integer: foreground_color is 0;
var integer: background_color is 0;
var bitmapFont: currentFont is bitmapFont.value;
var set of string: numeric_functions is {
"ABS", "ASC", "ATN", "CDBL", "CINT", "CLNG",
"COS", "CSNG", "CSRLIN", "CVI", "CVL", "EOF",
"ERL", "ERR", "EXP", "FIX", "FRE", "FREEFILE",
"INP", "INSTR", "INT", "LBOUND", "LEN", "LOF",
"LOG", "PEEK", "POINT", "POS", "RND", "SCREEN",
"SGN", "SIN", "SQR", "STRIG", "TAN", "TIMER",
"UBOUND", "VAL", "VARPTR"};
const set of string: not_allowed_as_label is {
"BEEP", "CLEAR", "CLOSE", "CLS", "COLOR", "COMMON",
"CONST", "DATA", "DECLARE", "DEF", "DEFDBL", "DEFINT",
"DEFSNG", "DEFSTR", "DIM", "DO", "DRAW", "ELSE",
"ELSEIF", "END", "ERASE", "EXIT", "GET", "IF",
"INPUT", "KEY", "LET", "LOCATE", "LOOP", "LPRINT",
"NEXT", "OPEN", "OPTION", "OUT", "PAINT", "PALETTE",
"PLAY", "POKE", "PRINT", "PUT", "RANDOMIZE", "READ",
"REDIM", "REM", "RESET", "RESTORE", "RESUME", "RETURN",
"RUN", "SCREEN", "SEEK", "SELECT", "SLEEP", "STOP",
"SUB", "SYSTEM", "WEND", "WRITE"};
const array color: loresColor is [0] (
black,
color(16#9000, 16#1700, 16#4000),
color(16#4000, 16#2c00, 16#a500),
color(16#d000, 16#4300, 16#e500),
color(16#0000, 16#6900, 16#4000),
color(16#8000, 16#8000, 16#8000),
color(16#2f00, 16#9500, 16#e500),
color(16#bf00, 16#ab00, 16#ff00),
color(16#4000, 16#2400, 16#0000),
color(16#d000, 16#6a00, 16#1a00),
color(16#8000, 16#8000, 16#8000),
color(16#ff00, 16#9600, 16#bf00),
color(16#2f00, 16#bc00, 16#1a00),
color(16#bf00, 16#d300, 16#5a00),
color(16#6f00, 16#e800, 16#bf00),
white);
const array color: hiresColor is [0] (
black,
color(16#2f00, 16#bc00, 16#1a00),
color(16#d000, 16#4300, 16#e500),
white,
black,
color(16#d000, 16#6a00, 16#1a00),
color(16#2f00, 16#9500, 16#e500),
white);
const proc: sleep (in integer: secs) is func
local
var time: start_time is time.value;
begin
start_time := time(NOW);
await(start_time + secs . SECONDS);
end func;
const proc: delay (in float: secs) is func
local
var time: start_time is time.value;
var integer: seconds is 0;
var integer: micro_seconds is 0;
begin
start_time := time(NOW);
seconds := trunc(secs);
micro_seconds := round((secs - flt(seconds)) * 1000000.0);
await(start_time + seconds . SECONDS + micro_seconds . MICRO_SECONDS);
end func;
const proc: listProg (inout file: listFile, in integer: fromLine, in integer: toLine) is func
local
var integer: number is 0;
var boolean: doList is FALSE;
begin
doList := fromLine = 0;
for number range 1 to length(prg) do
if prg[number].linenum <> "" then
doList := integer(prg[number].linenum) >= fromLine and
integer(prg[number].linenum) <= toLine;
end if;
if doList and (prg[number].line <> "" or prg[number].linenum <> "" or
prg[number].label <> "") then
if prg[number].linenum <> "" then
write(listFile, prg[number].linenum <& " ");
end if;
if prg[number].label <> "" then
write(listFile, prg[number].label <& ": ");
end if;
writeln(listFile, prg[number].line);
end if;
if prg[number].linenum <> "" then
doList := integer(prg[number].linenum) >= fromLine and
integer(prg[number].linenum) < toLine;
end if;
end for;
end func;
const func string: get_symbol (inout string: line) is func
result
var string: symbol is "";
local
var integer: leng is 0;
var integer: start is 0;
var integer: index is 0;
var char: ch is ' ';
begin
leng := length(line);
if leng > 0 then
repeat
incr(start);
if start <= leng then
ch := line[start];
else
ch := '\0;';
end if;
until ch <> ' ' and ch <> '\t';
index := start;
case ch of
when letter_char:
repeat
incr(index);
if index <= leng then
ch := line[index];
else
ch := ' ';
end if;
until ch not in basic_name_char;
if ch = '$' or ch = '%' or ch = '!' or ch = '#' or ch = '&' then
incr(index);
end if;
symbol := upper(line[start .. pred(index)]);
line := line[index .. ];
when digit_char:
repeat
incr(index);
if index <= leng then
ch := line[index];
else
ch := ' ';
end if;
until ch not in digit_char;
if ch = '.' then
incr(index);
if index <= leng and line[index] in digit_char then
repeat
incr(index);
if index <= leng then
ch := line[index];
else
ch := ' ';
end if;
until ch not in digit_char;
end if;
end if;
if ch = 'E' or ch = 'e' then
incr(index);
if index <= leng then
ch := line[index];
else
ch := ' ';
end if;
if ch in digit_char or ch = '+' or ch = '-' then
if ch = '+' or ch = '-' then
incr(index);
if index <= leng then
ch := line[index];
else
ch := ' ';
end if;
end if;
while ch in digit_char do
incr(index);
if index <= leng then
ch := line[index];
else
ch := ' ';
end if;
end while;
else
decr(index);
end if;
end if;
if ch in number_suffix then
incr(index);
end if;
symbol := line[start .. pred(index)];
line := line[index .. ];
when {'.'}:
incr(index);
if index <= leng and line[index] in digit_char then
repeat
incr(index);
if index <= leng then
ch := line[index];
else
ch := ' ';
end if;
until ch not in digit_char;
if ch = 'E' or ch = 'e' then
incr(index);
if index <= leng then
ch := line[index];
else
ch := ' ';
end if;
if ch in digit_char or ch = '+' or ch = '-' then
if ch = '+' or ch = '-' then
incr(index);
if index <= leng then
ch := line[index];
else
ch := ' ';
end if;
end if;
while ch in digit_char do
incr(index);
if index <= leng then
ch := line[index];
else
ch := ' ';
end if;
end while;
else
decr(index);
end if;
end if;
if ch in number_suffix then
incr(index);
end if;
symbol := "0" & line[start .. pred(index)];
line := line[index .. ];
else
symbol := ".";
line := line[index .. ];
end if;
when {'&'}:
incr(index);
if index <= leng then
ch := line[index];
if ch = 'H' or ch = 'h' then
incr(index);
start := index;
while index <= leng and line[index] in hexdigit_char do
incr(index);
end while;
if index > start then
symbol := str(integer(line[start .. pred(index)], 16));
if index <= leng and line[index] in number_suffix then
symbol &:= line[index len 1];
incr(index);
end if;
else
symbol := "&H";
end if;
elsif ch = 'O' or ch = 'o' then
incr(index);
start := index;
while index <= leng and line[index] in octdigit_char do
incr(index);
end while;
if index > start then
symbol := str(integer(line[start .. pred(index)], 8));
if index <= leng and line[index] in number_suffix then
symbol &:= line[index len 1];
incr(index);
end if;
else
symbol := "&O";
end if;
else
symbol := "&";
end if;
else
symbol := "&";
end if;
line := line[index .. ];
when {'"'}:
repeat
incr(index);
until index > leng or line[index] = '"';
symbol := line[start .. pred(index)];
line := line[succ(index) .. ];
when {'<'}:
repeat
incr(index);
if index <= leng then
ch := line[index];
else
ch := '\0;';
end if;
until ch <> ' ' and ch <> '\t';
if ch = '>' then
incr(index);
symbol := "<>";
elsif ch = '=' then
incr(index);
symbol := "<=";
else
symbol := "<";
end if;
line := line[index .. ];
when {'>'}:
repeat
incr(index);
if index <= leng then
ch := line[index];
else
ch := '\0;';
end if;
until ch <> ' ' and ch <> '\t';
if ch = '=' then
incr(index);
symbol := ">=";
elsif ch = '<' then
incr(index);
symbol := "<>";
else
symbol := ">";
end if;
line := line[index .. ];
when {'='}:
repeat
incr(index);
if index <= leng then
ch := line[index];
else
ch := '\0;';
end if;
until ch <> ' ' and ch <> '\t';
if ch = '<' then
incr(index);
symbol := "<=";
elsif ch = '>' then
incr(index);
symbol := ">=";
else
symbol := "=";
end if;
line := line[index .. ];
when {'\r'}:
symbol := "";
line := line[succ(index) .. ];
otherwise:
symbol := line[index len 1];
line := line[succ(index) .. ];
end case;
end if;
end func;
const func boolean: endOfStatement (in string: symbol) is
return symbol = ":" or symbol = "" or symbol = "'" or symbol = "REM" or symbol = "ELSE";
const func boolean: ignoreRestOfLine (in string: symbol) is
return symbol = "'" or symbol = "REM" or symbol = "DATA" or symbol = "DATA&";
const func boolean: isStringExpr (in string: symbol) is
return symbol in string_var_name or
symbol <> "" and
(symbol[length(symbol)] = '$' or symbol[1] = '\"' or symbol[1] in defstr_var and
not symbol[length(symbol)] in numeric_var_suffix);
const func boolean: isStringVar (in string: symbol) is
return symbol in string_var_name or
symbol <> "" and
(symbol[length(symbol)] = '$' or symbol[1] in defstr_var and
not symbol[length(symbol)] in numeric_var_suffix);
const func boolean: isNumericVar (in string: symbol) is
return symbol not in string_var_name or
symbol <> "" and
(symbol[1] in letter_char - defstr_var or
symbol[length(symbol)] in numeric_var_suffix);
const func float: getNumericVar (in string: varName) is func
result
var float: numericValue is 0.0;
begin
if varName in numeric_var then
numericValue := numeric_var[varName];
end if;
end func;
const proc: setNumericVar (in string: varName, in float: number) is func
begin
numeric_var @:= [varName] number;
end func;
const func string: getStringVar (in string: varName) is func
result
var string: stringValue is "";
begin
if varName in string_var then
stringValue := string_var[varName];
end if;
end func;
const proc: setStringVar (in string: varName, in string: stri) is func
begin
string_var @:= [varName] stri;
end func;
const func integer: varptr (in string: variable_name) is func
result
var integer: address is 0;
begin
if variable_name not in varptr_value then
varptr_value @:= [variable_name] succ(length(varptr_value));
end if;
address := varptr_value[variable_name];
varname_value @:= [address] variable_name;
end func;
const func string: varptrStri (in string: variable_name) is func
result
var string: addrStri is "";
local
var integer: address is 0;
begin
address := varptr(variable_name);
addrStri := "\3;" & bytes(address, UNSIGNED, LE);
end func;
const func string: varname (in integer: address) is func
result
var string: variable_name is "";
begin
if address in varname_value then
variable_name := varname_value[address];
end if;
end func;
const func file: getFileValue (in integer: file_number) is func
result
var file: fileValue is STD_NULL;
begin
if file_number in file_value then
fileValue := file_value[file_number];
end if;
end func;
const proc: setFileValue (in integer: file_number, in file: aFile) is func
begin
file_value @:= [file_number] aFile;
end func;
const proc: closeAllFiles is func
local
var file: aFile is STD_NULL;
begin
for aFile range file_value do
close(aFile);
end for;
file_value := file_hash.EMPTY_HASH;
end func;
const proc: addDoLoopHeader (in integer: tailLine, in integer: tailColumn,
in integer: headLine, in integer: headColumn) is func
begin
if tailLine in doLoopHeaders then
if tailColumn not in doLoopHeaders[tailLine] then
doLoopHeaders[tailLine] @:= [tailColumn] doLoopDescrType.value;
end if;
else
doLoopHeaders @:= [tailLine] doLoopHeaderInColumn.value;
doLoopHeaders[tailLine] @:= [tailColumn] doLoopDescrType.value;
end if;
doLoopHeaders[tailLine][tailColumn].headLine := headLine;
doLoopHeaders[tailLine][tailColumn].headColumn := headColumn;
end func;
const func boolean: doLoopHeaderPresent (in integer: tailLine, in integer: tailColumn,
inout integer: headLine, inout integer: headColumn) is func
result
var boolean: headerIsPresent is FALSE;
begin
if tailLine in doLoopHeaders then
if tailColumn in doLoopHeaders[tailLine] then
headerIsPresent := TRUE;
headLine := doLoopHeaders[tailLine][tailColumn].headLine;
headColumn := doLoopHeaders[tailLine][tailColumn].headColumn;
end if;
end if;
end func;
const proc: line_marker is func
begin
if statement_label <> "" then
write(log, statement_label <& " ");
elsif file_line_number >= 1 and file_line_number <= length(prg) then
if prg[file_line_number].fileName <> prg[1].fileName then
write(log, prg[file_line_number].fileName);
end if;
write(log, "(" <& prg[file_line_number].fileLine <& ") ");
else
write(log, "##### " <& file_line_number <& " ##### ");
end if;
end func;
const proc: line_marker (in integer: line_number) is func
begin
if line_number >= 1 and line_number <= length(prg) then
if prg[line_number].label <> "" then
write(log, prg[line_number].label);
elsif prg[line_number].linenum <> "" then
write(log, prg[line_number].linenum);
else
if prg[line_number].fileName <> prg[1].fileName then
write(log, prg[line_number].fileName);
end if;
write(log, "(" <& prg[line_number].fileLine <& ")");
end if;
else
write(log, "##### " <& line_number <& " ##### ");
end if;
end func;
const proc: error_marker is func
begin
write(err, " ***** ");
if statement_label <> "" then
write(err, "[" <& statement_label <& "] ");
elsif file_line_number >= 1 and file_line_number <= length(prg) then
if prg[file_line_number].fileName <> prg[1].fileName then
write(err, prg[file_line_number].fileName);
end if;
write(err, "(" <& prg[file_line_number].fileLine <& ") ");
end if;
end func;
const proc: error_marker (in string: label) is func
begin
write(err, " ***** (" <& label <& ") ");
end func;
const proc: error_expect (in string: expected_symbol, in string: symbol) is func
begin
error_marker;
writeln(err, literal(expected_symbol) <&
" EXPECTED - FOUND " <& literal(symbol) <& ".");
end func;
const proc: error_expect2 (in string: expected_symbol1, in string: expected_symbol2, in string: symbol) is func
begin
error_marker;
writeln(err, literal(expected_symbol1) <& " OR " <& literal(expected_symbol2) <&
" EXPECTED - FOUND " <& literal(symbol) <& ".");
end func;
const proc: error_expect3 (in string: expected_symbol1, in string: expected_symbol2,
in string: expected_symbol3, in string: symbol) is func
begin
error_marker;
writeln(err, literal(expected_symbol1) <& ", " <& literal(expected_symbol2) <& " OR " <&
literal(expected_symbol3) <& " EXPECTED - FOUND " <& literal(symbol) <& ".");
end func;
const proc: expect (in string: expected_symbol, inout string: symbol, inout string: line) is func
begin
if symbol = expected_symbol then
symbol := get_symbol(line);
else
error_expect(expected_symbol, symbol);
end if;
end func;
const func boolean: label_or_linenum (in string: symbol) is
return symbol in label or (symbol <> "" and symbol[1] in digit_char);
const proc: goto_label_or_linenum (in string: new_label) is func
local
var integer: number is 0;
var integer: searched_linenum is 0;
var integer: matched_linenum is MAX_LINENUM;
var integer: linenum is 0;
begin
if new_label in label then
statement_label := new_label;
file_line_number := pred(label[statement_label]);
elsif new_label <> "" and new_label[1] in digit_char then
searched_linenum := integer(new_label);
for number range 1 to length(prg) do
if prg[number].linenum <> "" then
linenum := integer(prg[number].linenum);
if linenum >= searched_linenum and
linenum < matched_linenum then
matched_linenum := linenum;
end if;
end if;
end for;
if matched_linenum <> MAX_LINENUM and
str(matched_linenum) in label then
error_marker;
writeln(err, "LABEL " <& new_label <&
" DOES NOT EXIST - USE " <& matched_linenum <& " INSTEAD");
statement_label := str(matched_linenum);
file_line_number := pred(label[statement_label]);
else
error_marker;
writeln(err, "LABEL " <& new_label <& " DOES NOT EXIST");
end if;
else
error_marker;
writeln(err, "LABEL " <& new_label <& " DOES NOT EXIST");
end if;
end func;
const proc: set_return_position (in string: line) is func
local
var integer: column is 0;
begin
column := length(prg[file_line_number].line) - length(line) + 1;
gosubReturn := [] (gosubReturnDescrType.value) & gosubReturn;
gosubReturn[1].returnLine := file_line_number;
gosubReturn[1].returnColumn := column;
gosubReturn[1].forLoopStackDepth := length(forLoop);
gosubReturn[1].whileLoopStackDepth := length(whileLoop);
gosubReturn[1].doLoopStackDepth := length(doLoop);
end func;
const proc: set_sub_entry_position is func
begin
gosubReturn[1].subEntryLine := succ(file_line_number);
end func;
const proc: check_loop_stacks_before_return (in string: returnStatementName) is func
begin
if length(forLoop) > gosubReturn[1].forLoopStackDepth then
error_marker;
writeln(err, returnStatementName <& " - SOME FOR LOOPS WERE NOT LEFT");
repeat
line_marker;
write(log, "LEAVE THE \"FOR " <& forLoop[1].varName <&
"\" LOOP AT LINE ");
line_marker(forLoop[1].bodyLine);
writeln(log);
forLoop := forLoop[2 .. ];
until length(forLoop) <= gosubReturn[1].forLoopStackDepth;
end if;
if length(whileLoop) > gosubReturn[1].whileLoopStackDepth then
error_marker;
writeln(err, returnStatementName <& " - SOME WHILE LOOPS WERE NOT LEFT");
repeat
line_marker;
write(log, "LEAVE THE \"WHILE\" LOOP AT LINE ");
line_marker(whileLoop[1].condLine);
writeln(log);
whileLoop := whileLoop[2 .. ];
until length(whileLoop) <= gosubReturn[1].whileLoopStackDepth;
end if;
if length(doLoop) > gosubReturn[1].doLoopStackDepth then
error_marker;
writeln(err, returnStatementName <& " - SOME DO LOOPS WERE NOT LEFT");
repeat
line_marker;
write(log, "LEAVE THE \"DO\" LOOP AT LINE ");
line_marker(doLoop[1].headLine);
writeln(log);
doLoop := doLoop[2 .. ];
until length(doLoop) <= gosubReturn[1].doLoopStackDepth;
end if;
end func;
const proc: do_return (inout string: symbol, inout string: line) is func
begin
file_line_number := gosubReturn[1].returnLine;
statement_label := prg[file_line_number].linenum;
line := prg[file_line_number].line[gosubReturn[1].returnColumn .. ];
symbol := get_symbol(line);
gosubReturn := gosubReturn[2 .. ];
end func;
const proc: goto_on_error (in string: on_error_label, in string: line) is func
begin
error_linenum := prg[file_line_number].linenum;
resume_next_line := file_line_number;
resume_next_column :=
length(prg[file_line_number].line) - length(line) + 1;
in_error_handler := TRUE;
goto_label_or_linenum(on_error_label);
end func;
const proc: do_resume_next (inout string: symbol, inout string: line) is func
begin
if resume_next_line <> 0 then
file_line_number := resume_next_line;
statement_label := prg[file_line_number].linenum;
line := prg[file_line_number].line[resume_next_column .. ];
symbol := get_symbol(line);
in_error_handler := FALSE;
resume_next_line := 0;
else
error_marker;
writeln(err, "CANNOT RESUME NEXT");
end if;
end func;
const proc: do_resume_same (inout string: symbol, inout string: line) is func
begin
if resume_same_line <> 0 then
file_line_number := resume_same_line;
statement_label := prg[file_line_number].linenum;
line := prg[file_line_number].line[resume_same_column .. ];
symbol := get_symbol(line);
in_error_handler := FALSE;
resume_same_line := 0;
else
error_marker;
writeln(err, "CANNOT RESUME 0");
end if;
end func;
const func color: color_num (in integer: col_num) is func
result
var color: col is black;
begin
case col_num of
when {0}: col := black;
when {1}: col := dark_blue;
when {2}: col := dark_green;
when {3}: col := dark_cyan;
when {4}: col := dark_red;
when {5}: col := dark_magenta;
when {6}: col := brown;
when {7}: col := light_gray;
when {8}: col := dark_gray;
when {9}: col := light_blue;
when {10}: col := light_green;
when {11}: col := light_cyan;
when {12}: col := light_red;
when {13}: col := light_magenta;
when {14}: col := yellow;
when {15}: col := white;
end case;
end func;
const func string: get_data_line (inout string: symbol, inout string: line) is func
result
var string: data_line is "";
local
var boolean: searching is TRUE;
var string: data_symbol is "";
begin
while searching do
incr(data_line_number);
if data_line_number > length(prg) then
if on_error_label <> "" then
error_code := 4;
line_marker;
writeln(log, error_code <& " OUT OF DATA" <&
" - ON ERROR GOTO " <& on_error_label);
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "OUT OF DATA");
end if;
data_line := ",,,,,,,,,,,,,,,,,,,,,,,,,";
searching := FALSE;
elsif prg[data_line_number].line <> "" then
data_line := prg[data_line_number].line;
repeat
data_symbol := get_symbol(data_line);
until data_symbol = "" or
data_symbol = "DATA" or data_symbol = "DATA&" or
data_symbol = "'" or data_symbol = "REM";
if data_symbol = "DATA&" then
data_symbol := "DATA";
data_line := "&" & data_line;
line_marker;
writeln(log, "DATA STATEMENT CORRECTED FROM " <&
literal(prg[data_line_number].line) <&
" TO " <& literal("DATA " & data_line));
end if;
if data_symbol = "DATA" then
searching := FALSE;
end if;
end if;
end while;
end func;
const proc: data_statement_in_line is func
local
var string: data_symbol is "";
begin
data_symbol := get_symbol(data_line);
if data_symbol = "DATA&" then
data_symbol := "DATA";
data_line := "&" & data_line;
line_marker;
writeln(log, "DATA STATEMENT CORRECTED FROM " <&
literal(prg[data_line_number].line) <&
" TO " <& literal("DATA " & data_line));
end if;
if data_symbol = "'" or data_symbol = "REM" then
data_line := "";
elsif data_symbol <> "" and data_symbol <> "DATA" then
error_expect3("DATA", "REM", "'", data_symbol);
end if;
end func;
const func string: get_data_field (inout string: symbol, inout string: line) is func
result
var string: data_field is "";
local
var integer: comma_pos is 0;
var integer: quote_pos is 0;
var integer: colon_pos is 0;
var string: data_symbol is "";
begin
if data_line = "" then
data_line := get_data_line(symbol, line);
end if;
if not in_error_handler then
while data_line <> "" and data_line[1] = ' ' do
data_line := data_line[2 .. ];
end while;
if data_line <> "" and data_line[1] = '"' then
data_field := "";
data_line := data_line[2 .. ];
quote_pos := pos(data_line, "\"");
while quote_pos <> 0 do
if succ(quote_pos) <= length(data_line) and
data_line[succ(quote_pos)] = '"' then
data_field &:= data_line[ .. quote_pos];
data_line := data_line[quote_pos + 2 .. ];
quote_pos := pos(data_line, "\"");
else
data_field &:= data_line[ .. pred(quote_pos)];
data_line := data_line[succ(quote_pos) .. ];
quote_pos := 0;
end if;
end while;
while data_line <> "" and data_line[1] = ' ' do
data_line := data_line[2 .. ];
end while;
if data_line <> "" then
if data_line[1] = ':' then
data_line := data_line[2 .. ];
data_statement_in_line;
elsif data_line[1] = ',' then
data_line := data_line[2 .. ];
else
data_symbol := get_symbol(data_line);
if data_symbol = "'" or data_symbol = "REM" then
data_line := "";
else
error_expect2(",", ":", data_symbol);
end if;
end if;
end if;
else
comma_pos := pos(data_line, ",");
colon_pos := pos(data_line, ":");
if colon_pos <> 0 then
if comma_pos = 0 or colon_pos < comma_pos then
data_field := data_line[ .. pred(colon_pos)];
data_line := data_line[succ(colon_pos) .. ];
data_statement_in_line;
else
data_field := data_line[ .. pred(comma_pos)];
data_line := data_line[succ(comma_pos) .. ];
if data_line = "" then
data_line := " ";
end if;
end if;
else
if comma_pos <> 0 then
data_field := data_line[ .. pred(comma_pos)];
data_line := data_line[succ(comma_pos) .. ];
if data_line = "" then
data_line := " ";
end if;
else
data_field := data_line;
data_line := "";
end if;
end if;
end if;
end if;
end func;
const proc: skip_space_cr_lf (inout file: inFile) is func
local
var char: ch is ' ';
begin
ch := inFile.bufferChar;
while ch = ' ' or ch = '\r' or ch = '\n' do
ch := getc(inFile);
end while;
inFile.bufferChar := ch;
end func;
const func string: read_input_string (inout file: inFile) is func
result
var string: stri is "";
local
var char: ch is ' ';
begin
ch := inFile.bufferChar;
if ch = '"' then
ch := getc(inFile);
while ch <> '"' and ch <> '\r' and ch <> '\n' and ch <> EOF do
stri &:= str(ch);
ch := getc(inFile);
end while;
ch := getc(inFile);
else
while ch <> ',' and ch <> '\r' and ch <> '\n' and ch <> EOF do
stri &:= str(ch);
ch := getc(inFile);
end while;
end if;
inFile.bufferChar := ch;
end func;
const func string: read_input_number (inout file: inFile) is func
result
var string: number is "";
local
var char: ch is ' ';
begin
ch := inFile.bufferChar;
if ch = '"' then
ch := getc(inFile);
while ch <> '"' and ch <> '\r' and ch <> '\n' and ch <> EOF do
number &:= str(ch);
ch := getc(inFile);
end while;
ch := getc(inFile);
else
while ch <> ',' and ch <> ' ' and ch <> '\r' and ch <> '\n' and ch <> EOF do
number &:= str(ch);
ch := getc(inFile);
end while;
end if;
inFile.bufferChar := ch;
end func;
const proc: assign_input_number (in string: variable_name, in string: param1) is func
local
var float: num1 is 0.0;
begin
block
num1 := float(param1);
setNumericVar(variable_name, num1);
line_marker;
writeln(log, "INPUT " <& variable_name <& " <- " <& num1);
exception
catch RANGE_ERROR:
error_marker;
writeln(err, "NUMBER EXPECTED FOR INPUT OF " <& variable_name <&
" FOUND " <& literal(param1) <& ".");
end block;
end func;
const proc: assign_input_string (in string: variable_name, in string: param1) is func
begin
setStringVar(variable_name, param1);
line_marker;
writeln(log, "INPUT " <& variable_name <& " <- " <& literal(param1));
end func;
const proc: set_function (in string: name, in string: params, in string: expression) is func
local
var defFnType: newDefFn is defFnType.value;
begin
if name not in def_fn_list then
newDefFn.name := name;
newDefFn.params := params;
newDefFn.expression := expression;
def_fn_list @:= [name] (newDefFn);
end if;
end func;
const proc: define_function (in var string: variable_name,
inout string: symbol, inout string: line, in boolean: doLog) is func
local
var string: param1 is "";
var string: param2 is "";
var integer: func_end_pos is 0;
begin
symbol := get_symbol(line);
if variable_name = "FN" and symbol <> "" and
symbol[1] >= 'A' and symbol[1] <= 'Z' then
variable_name &:= symbol;
symbol := get_symbol(line);
end if;
param1 := "";
if symbol = "(" then
repeat
symbol := get_symbol(line);
if symbol <> "" and symbol[1] >= 'A' and symbol[1] <= 'Z' then
param1 &:= symbol & " ";
end if;
symbol := get_symbol(line);
until symbol <> ",";
expect(")", symbol, line);
if length(param1) >= 1 then
param1 := param1[.. pred(length(param1))];
end if;
end if;
if symbol = "=" then
param2 := line;
repeat
func_end_pos := length(line);
symbol := get_symbol(line);
until endOfStatement(symbol);
param2 := param2[ .. length(param2) - func_end_pos];
set_function(variable_name, param1, param2);
if doLog then
line_marker;
writeln(log, "DEF " <& variable_name <& "(" <& param1 <& ")=" <& param2);
end if;
else
expect("=", symbol, line);
end if;
end func;
const proc: getBoundsFromIndexPart (in var string: indexPart, in integer: dimension,
inout boolean: first, inout integer: lbound, inout integer: ubound) is func
local
var integer: indexDimension is 0;
var integer: anIndex is 0;
begin
if indexPart <> "" and (indexPart[1] = '[' or indexPart[1] = '(') then
repeat
indexPart := indexPart[2 ..];
anIndex := integer(getDigits(indexPart));
incr(indexDimension);
until indexDimension = dimension;
if first then
lbound := anIndex;
ubound := anIndex;
first := FALSE;
else
if anIndex < lbound then
lbound := anIndex;
end if;
if anIndex > ubound then
ubound := anIndex;
end if;
end if;
end if;
end func;
const proc: getBounds (in string: array_name, in integer: dimension,
inout integer: lbound, inout integer: ubound) is func
local
var string: varName is "";
var boolean: first is TRUE;
begin
for key varName range numeric_var do
if startsWith(varName, array_name) then
getBoundsFromIndexPart(varName[succ(length(array_name)) ..],
dimension, first, lbound, ubound);
end if;
end for;
for key varName range string_var do
if startsWith(varName, array_name) then
getBoundsFromIndexPart(varName[succ(length(array_name)) ..],
dimension, first, lbound, ubound);
end if;
end for;
end func;
const func integer: exec_lbound (in string: array_name, in integer: dimension) is func
result
var integer: lbound is 0;
local
var integer: ubound is 0;
begin
getBounds(array_name, dimension, lbound, ubound);
end func;
const func integer: exec_ubound (in string: array_name, in integer: dimension) is func
result
var integer: ubound is 0;
local
var integer: lbound is 0;
begin
getBounds(array_name, dimension, lbound, ubound);
end func;
const func integer: getFirstIndex (in string: array_name,
inout string: name_start, inout string: name_end) is func
result
var integer: lbound is 0;
local
var integer: parenPos is 0;
var integer: commaPos is 0;
var integer: paren2Pos is 0;
var string: indexString is "";
begin
parenPos := pos(array_name, "(");
if parenPos = 0 then
parenPos := pos(array_name, "[");
end if;
if parenPos <> 0 then
name_start := array_name[.. parenPos];
commaPos := pos(array_name, ",", succ(parenPos));
if commaPos <> 0 then
name_end := array_name[commaPos ..];
indexString := array_name[succ(parenPos) .. pred(commaPos)];
else
paren2Pos := pos(array_name, ")", succ(parenPos));
if paren2Pos = 0 then
paren2Pos := pos(array_name, "]", succ(parenPos));
end if;
if paren2Pos <> 0 then
name_end := array_name[paren2Pos ..];
indexString := array_name[succ(parenPos) .. pred(paren2Pos)];
end if;
end if;
lbound := integer(indexString);
end if;
end func;
const func float: exec_expr (inout string: symbol, inout string: line) is forward;
const proc: append_index (inout string: name, inout string: symbol, inout string: line) is func
local
var float: num is 0.0;
begin
if symbol = "(" or symbol = "[" then
symbol := get_symbol(line);
num := exec_expr(symbol, line);
name &:= "(" & str(round(num));
while symbol = "," do
symbol := get_symbol(line);
num := exec_expr(symbol, line);
name &:= "," & str(round(num));
end while;
if symbol <> ")" and symbol <> "]" then
error_expect2(")", "]", symbol);
else
name &:= ")";
symbol := get_symbol(line);
end if;
end if;
if symbol = "." then
symbol := get_symbol(line);
name &:= "." & symbol;
symbol := get_symbol(line);
end if;
end func;
const func string: get_name (inout string: symbol, inout string: line) is func
result
var string: name is "";
begin
name := symbol;
symbol := get_symbol(line);
append_index(name, symbol, line);
end func;
const proc: skip_parenthesized_stri (inout string: symbol, inout string: line) is func
local
var string: close_symbol is "";
begin
if symbol = "(" then
close_symbol := ")";
elsif symbol = "[" then
close_symbol := "]";
end if;
symbol := get_symbol(line);
while symbol <> close_symbol and symbol <> "" do
if symbol = "(" or symbol = "[" then
skip_parenthesized_stri(symbol, line);
else
symbol := get_symbol(line);
end if;
end while;
if symbol <> close_symbol then
error_expect(close_symbol, symbol);
else
symbol := get_symbol(line);
end if;
end func;
const func boolean: is_let_statement (in string: line) is func
result
var boolean: is_let_statement is FALSE;
local
var string: symbol is "";
var string: help_line is "";
begin
help_line := line;
symbol := get_symbol(help_line);
if symbol = "(" or symbol = "[" then
skip_parenthesized_stri(symbol, help_line);
end if;
if symbol = "." then
symbol := get_symbol(help_line);
symbol := get_symbol(help_line);
end if;
is_let_statement := symbol = "=";
end func;
const func string: exec_str_expr (
inout string: symbol,
inout string: line,
inout string: variable_name) is forward;
const func string: exec_str_function (in defFnType: defFn, inout string: symbol, inout string: line) is func
result
var string: exprResult is "";
local
var string: func_expr is "";
var string: func_symbol is "";
var string: formal_params is "";
var string: formal_param is "";
var string: unused_name is "";
var array string: str_value_backup is 0 times "";
var array float: num_value_backup is 0 times 0.0;
begin
write(log, "function " <& defFn.name);
formal_params := defFn.params;
symbol := get_symbol(line);
if symbol = "(" then
write(log, "(");
repeat
symbol := get_symbol(line);
formal_param := get_symbol(formal_params);
if formal_param[length(formal_param)] = '$' then
if formal_param in string_var then
str_value_backup &:= [] (string_var[formal_param]);
else
str_value_backup &:= [] ("");
end if;
string_var @:= [formal_param] exec_str_expr(symbol, line, unused_name);
write(log, string_var[formal_param]);
else
if formal_param in numeric_var then
num_value_backup &:= [] (numeric_var[formal_param]);
else
num_value_backup &:= [] (0.0);
end if;
numeric_var @:= [formal_param] exec_expr(symbol, line);
write(log, numeric_var[formal_param]);
end if;
write(log, symbol);
until symbol <> ",";
expect(")", symbol, line);
end if;
func_expr := defFn.expression;
writeln(log, " = " <& func_expr);
func_symbol := get_symbol(func_expr);
exprResult := exec_str_expr(func_symbol, func_expr, unused_name);
formal_params := defFn.params;
formal_param := get_symbol(formal_params);
while formal_param <> "" do
if formal_param[length(formal_param)] = '$' then
string_var @:= [formal_param] str_value_backup[1];
str_value_backup := str_value_backup[2 ..];
else
numeric_var @:= [formal_param] num_value_backup[1];
num_value_backup := num_value_backup[2 ..];
end if;
formal_param := get_symbol(formal_params);
end while;
end func;
const func string: extendedKeyCode (in char: current_key) is func
result
var string: keyCode is "";
begin
case current_key of
when {KEY_NL}: keyCode := "\r";
when {KEY_ALT_A}: keyCode := "\0;\30;";
when {KEY_ALT_B}: keyCode := "\0;\48;";
when {KEY_ALT_C}: keyCode := "\0;\46;";
when {KEY_ALT_D}: keyCode := "\0;\32;";
when {KEY_ALT_E}: keyCode := "\0;\18;";
when {KEY_ALT_F}: keyCode := "\0;\33;";
when {KEY_ALT_G}: keyCode := "\0;\34;";
when {KEY_ALT_H}: keyCode := "\0;\35;";
when {KEY_ALT_I}: keyCode := "\0;\23;";
when {KEY_ALT_J}: keyCode := "\0;\36;";
when {KEY_ALT_K}: keyCode := "\0;\37;";
when {KEY_ALT_L}: keyCode := "\0;\38;";
when {KEY_ALT_M}: keyCode := "\0;\50;";
when {KEY_ALT_N}: keyCode := "\0;\49;";
when {KEY_ALT_O}: keyCode := "\0;\24;";
when {KEY_ALT_P}: keyCode := "\0;\25;";
when {KEY_ALT_Q}: keyCode := "\0;\16;";
when {KEY_ALT_R}: keyCode := "\0;\19;";
when {KEY_ALT_S}: keyCode := "\0;\31;";
when {KEY_ALT_T}: keyCode := "\0;\20;";
when {KEY_ALT_U}: keyCode := "\0;\22;";
when {KEY_ALT_V}: keyCode := "\0;\47;";
when {KEY_ALT_W}: keyCode := "\0;\17;";
when {KEY_ALT_X}: keyCode := "\0;\45;";
when {KEY_ALT_Y}: keyCode := "\0;\21;";
when {KEY_ALT_Z}: keyCode := "\0;\44;";
when {KEY_ALT_0}: keyCode := "\0;\120;";
when {KEY_ALT_1}: keyCode := "\0;\121;";
when {KEY_ALT_2}: keyCode := "\0;\122;";
when {KEY_ALT_3}: keyCode := "\0;\123;";
when {KEY_ALT_4}: keyCode := "\0;\124;";
when {KEY_ALT_5}: keyCode := "\0;\125;";
when {KEY_ALT_6}: keyCode := "\0;\126;";
when {KEY_ALT_7}: keyCode := "\0;\127;";
when {KEY_ALT_8}: keyCode := "\0;\128;";
when {KEY_ALT_9}: keyCode := "\0;\129;";
when {KEY_F1}: keyCode := "\0;;";
when {KEY_F2}: keyCode := "\0;<";
when {KEY_F3}: keyCode := "\0;=";
when {KEY_F4}: keyCode := "\0;>";
when {KEY_F5}: keyCode := "\0;?";
when {KEY_F6}: keyCode := "\0;@";
when {KEY_F7}: keyCode := "\0;A";
when {KEY_F8}: keyCode := "\0;B";
when {KEY_F9}: keyCode := "\0;C";
when {KEY_F10}: keyCode := "\0;D";
when {KEY_SFT_F1}: keyCode := "\0;T";
when {KEY_SFT_F2}: keyCode := "\0;U";
when {KEY_SFT_F3}: keyCode := "\0;V";
when {KEY_SFT_F4}: keyCode := "\0;W";
when {KEY_SFT_F5}: keyCode := "\0;X";
when {KEY_SFT_F6}: keyCode := "\0;Y";
when {KEY_SFT_F7}: keyCode := "\0;Z";
when {KEY_SFT_F8}: keyCode := "\0;[";
when {KEY_SFT_F9}: keyCode := "\0;\\";
when {KEY_SFT_F10}: keyCode := "\0;]";
when {KEY_CTL_F1}: keyCode := "\0;^";
when {KEY_CTL_F2}: keyCode := "\0;_";
when {KEY_CTL_F3}: keyCode := "\0;`";
when {KEY_CTL_F4}: keyCode := "\0;a";
when {KEY_CTL_F5}: keyCode := "\0;b";
when {KEY_CTL_F6}: keyCode := "\0;c";
when {KEY_CTL_F7}: keyCode := "\0;d";
when {KEY_CTL_F8}: keyCode := "\0;e";
when {KEY_CTL_F9}: keyCode := "\0;f";
when {KEY_CTL_F10}: keyCode := "\0;g";
when {KEY_ALT_F1}: keyCode := "\0;h";
when {KEY_ALT_F2}: keyCode := "\0;i";
when {KEY_ALT_F3}: keyCode := "\0;j";
when {KEY_ALT_F4}: keyCode := "\0;k";
when {KEY_ALT_F5}: keyCode := "\0;l";
when {KEY_ALT_F6}: keyCode := "\0;m";
when {KEY_ALT_F7}: keyCode := "\0;n";
when {KEY_ALT_F8}: keyCode := "\0;o";
when {KEY_ALT_F9}: keyCode := "\0;p";
when {KEY_ALT_F10}: keyCode := "\0;q";
when {KEY_BACKTAB}: keyCode := "\0;\15;";
when {KEY_LEFT}: keyCode := "\0;K";
when {KEY_RIGHT}: keyCode := "\0;M";
when {KEY_UP}: keyCode := "\0;H";
when {KEY_DOWN}: keyCode := "\0;P";
when {KEY_HOME}: keyCode := "\0;G";
when {KEY_END}: keyCode := "\0;O";
when {KEY_PGUP}: keyCode := "\0;I";
when {KEY_PGDN}: keyCode := "\0;Q";
when {KEY_INS}: keyCode := "\0;R";
when {KEY_DEL}: keyCode := "\0;S";
when {KEY_CTL_LEFT}: keyCode := "\0;\115;";
when {KEY_CTL_RIGHT}: keyCode := "\0;\116;";
when {KEY_CTL_HOME}: keyCode := "\0;\119;";
when {KEY_CTL_END}: keyCode := "\0;\117;";
when {KEY_CTL_PGUP}: keyCode := "\0;\132;";
when {KEY_CTL_PGDN}: keyCode := "\0;\118;";
otherwise: keyCode := str(current_key);
end case;
end func;
const func integer: keyboardScanCode (in char: current_key) is func
result
var integer: scanCode is 0;
begin
case current_key of
when {KEY_ESC}: scanCode := 16#01;
when {'!' }: scanCode := 16#02;
when {'@' }: scanCode := 16#03;
when {'#' }: scanCode := 16#04;
when {'$' }: scanCode := 16#05;
when {'%' }: scanCode := 16#06;
when {'^' }: scanCode := 16#07;
when {'&' }: scanCode := 16#08;
when {'*' }: scanCode := 16#09;
when {'(' }: scanCode := 16#0a;
when {')' }: scanCode := 16#0b;
when {'_', '-'}: scanCode := 16#0c;
when {'+', '='}: scanCode := 16#0d;
when {KEY_BS}: scanCode := 16#0e;
when {KEY_TAB}: scanCode := 16#0f;
when {'Q', 'q', KEY_ALT_Q, KEY_CTL_Q}: scanCode := 16#10;
when {'W', 'w', KEY_ALT_W, KEY_CTL_W}: scanCode := 16#11;
when {'E', 'e', KEY_ALT_E, KEY_CTL_E}: scanCode := 16#12;
when {'R', 'r', KEY_ALT_R, KEY_CTL_R}: scanCode := 16#13;
when {'T', 't', KEY_ALT_T, KEY_CTL_T}: scanCode := 16#14;
when {'Y', 'y', KEY_ALT_Y, KEY_CTL_Y}: scanCode := 16#15;
when {'U', 'u', KEY_ALT_U, KEY_CTL_U}: scanCode := 16#16;
when {'I', 'i', KEY_ALT_I }: scanCode := 16#17;
when {'O', 'o', KEY_ALT_O, KEY_CTL_O}: scanCode := 16#18;
when {'P', 'p', KEY_ALT_P, KEY_CTL_P}: scanCode := 16#19;
when {'{', '['}: scanCode := 16#1a;
when {'}', ']'}: scanCode := 16#1b;
when {KEY_NL}: scanCode := 16#1c;
when {'A', 'a', KEY_ALT_A, KEY_CTL_A}: scanCode := 16#1e;
when {'S', 's', KEY_ALT_S, KEY_CTL_S}: scanCode := 16#1f;
when {'D', 'd', KEY_ALT_D, KEY_CTL_D}: scanCode := 16#20;
when {'F', 'f', KEY_ALT_F, KEY_CTL_F}: scanCode := 16#21;
when {'G', 'g', KEY_ALT_G, KEY_CTL_G}: scanCode := 16#22;
when {'H', 'h', KEY_ALT_H }: scanCode := 16#23;
when {'J', 'j', KEY_ALT_J }: scanCode := 16#24;
when {'K', 'k', KEY_ALT_K, KEY_CTL_K}: scanCode := 16#25;
when {'L', 'l', KEY_ALT_L, KEY_CTL_L}: scanCode := 16#26;
when {':', ';'}: scanCode := 16#27;
when {'"', '\''}: scanCode := 16#28;
when {'~', '`'}: scanCode := 16#29;
when {'|', '\\'}: scanCode := 16#2b;
when {'Z', 'z', KEY_ALT_Z, KEY_CTL_Z}: scanCode := 16#2c;
when {'X', 'x', KEY_ALT_X, KEY_CTL_X}: scanCode := 16#2d;
when {'C', 'c', KEY_ALT_C, KEY_CTL_C}: scanCode := 16#2e;
when {'V', 'v', KEY_ALT_V, KEY_CTL_V}: scanCode := 16#2f;
when {'B', 'b', KEY_ALT_B, KEY_CTL_B}: scanCode := 16#30;
when {'N', 'n', KEY_ALT_N, KEY_CTL_N}: scanCode := 16#31;
when {'M', 'm', KEY_ALT_M, KEY_CTL_M}: scanCode := 16#32;
when {'<', ','}: scanCode := 16#33;
when {'>', '.'}: scanCode := 16#34;
when {'?', '/'}: scanCode := 16#35;
when {' '}: scanCode := 16#39;
when {KEY_F1, KEY_SFT_F1, KEY_CTL_F1, KEY_ALT_F1}: scanCode := 16#3b;
when {KEY_F2, KEY_SFT_F2, KEY_CTL_F2, KEY_ALT_F2}: scanCode := 16#3c;
when {KEY_F3, KEY_SFT_F3, KEY_CTL_F3, KEY_ALT_F3}: scanCode := 16#3d;
when {KEY_F4, KEY_SFT_F4, KEY_CTL_F4, KEY_ALT_F4}: scanCode := 16#3e;
when {KEY_F5, KEY_SFT_F5, KEY_CTL_F5, KEY_ALT_F5}: scanCode := 16#3f;
when {KEY_F6, KEY_SFT_F6, KEY_CTL_F6, KEY_ALT_F6}: scanCode := 16#40;
when {KEY_F7, KEY_SFT_F7, KEY_CTL_F7, KEY_ALT_F7}: scanCode := 16#41;
when {KEY_F8, KEY_SFT_F8, KEY_CTL_F8, KEY_ALT_F8}: scanCode := 16#42;
when {KEY_F9, KEY_SFT_F9, KEY_CTL_F9, KEY_ALT_F9}: scanCode := 16#43;
when {KEY_F10, KEY_SFT_F10, KEY_CTL_F10, KEY_ALT_F10}: scanCode := 16#44;
when {KEY_HOME, KEY_CTL_HOME, '7'}: scanCode := 16#47;
when {KEY_UP, KEY_CTL_UP, '8'}: scanCode := 16#48;
when {KEY_PGUP, KEY_CTL_PGUP, '9'}: scanCode := 16#49;
when {KEY_LEFT, KEY_CTL_LEFT, '4'}: scanCode := 16#4b;
when {KEY_PAD_CENTER, '5'}: scanCode := 16#4c;
when {KEY_RIGHT, KEY_CTL_RIGHT, '6'}: scanCode := 16#4d;
when {KEY_END, KEY_CTL_END, '1'}: scanCode := 16#4f;
when {KEY_DOWN, KEY_CTL_DOWN, '2'}: scanCode := 16#50;
when {KEY_PGDN, KEY_CTL_PGDN, '3'}: scanCode := 16#51;
when {KEY_INS, KEY_CTL_INS, '0'}: scanCode := 16#52;
when {KEY_DEL, KEY_CTL_DEL }: scanCode := 16#53;
otherwise: scanCode := 0;
end case;
end func;
const proc: execLines is forward;
const func string: exec_str_primary (inout string: symbol, inout string: line,
inout string: variable_name) is func
result
var string: exprResult is "";
local
var string: unused_name is "";
var string: stri1 is "";
var string: stri2 is "";
var float: num1 is 0.0;
var float: num2 is 0.0;
var integer: index1 is 0;
var integer: index2 is 0;
var file: aFile is STD_NULL;
var char: current_key is ' ';
var string: func_name is "";
begin
variable_name := "";
case symbol of
when {""}:
error_marker;
writeln(err, "EXPRESSION EXPECTED - FOUND END OF LINE.");
when {"CHR$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := str(chr(round(num1)));
writeln(log, "CHR$(" <& num1 <& ") -> " <& literal(exprResult));
when {"COMMAND$"}:
symbol := get_symbol(line);
exprResult := command_line;
writeln(log, "COMMAND$ -> " <& literal(exprResult));
when {"DATE$"}:
symbol := get_symbol(line);
exprResult := str_mm_dd_yyyy(time(NOW), "-");
writeln(log, "DATE$ -> " <& literal(exprResult));
when {"HEX$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := round(num1) RADIX 16;
writeln(log, "HEX$(" <& num1 <& ") -> " <& literal(exprResult));
when {"INKEY$"}:
symbol := get_symbol(line);
write(log, "INKEY$ ");
flush(log);
flush(win);
if inputReady(KEYBOARD) then
current_key := getc(KEYBOARD);
exprResult := extendedKeyCode(current_key);
else
exprResult := "";
end if;
write(log, "-> " <& literal(exprResult));
if exprResult <> "" and current_key in keyDescription then
write(log, " (" <& keyDescription[current_key] <& ")");
end if;
writeln(log);
when {"INPUT$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
index1 := round(exec_expr(symbol, line));
if index1 >= 0 then
if symbol = "," then
symbol := get_symbol(line);
if symbol = "#" then
symbol := get_symbol(line);
end if;
index2 := round(exec_expr(symbol, line));
expect(")", symbol, line);
aFile := getFileValue(index2);
if aFile <> STD_NULL then
write(log, "INPUT$(" <& index1 <& ", #" <& index2 <& ") ");
flush(log);
exprResult := gets(aFile, index1);
writeln(log, "-> " <& literal(exprResult));
else
error_marker;
writeln(err, "FILE #" <& index2 <& " NOT OPEN IN INPUT$.");
end if;
else
expect(")", symbol, line);
write(log, "INPUT$(" <& index1 <& ") ");
flush(log);
flush(win);
exprResult := gets(KEYBOARD, index1);
writeln(log, "-> " <& literal(exprResult));
end if;
else
error_marker;
writeln(err, "INPUT$ WITH NEGATIVE NUMBER " <& index1 <& ".");
while symbol <> ")" do
symbol := get_symbol(line);
end while;
symbol := get_symbol(line);
end if;
when {"LCASE$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
exprResult := lower(stri1);
writeln(log, "LCASE$(" <& literal(stri1) <& ") -> " <& literal(exprResult));
when {"LEFT$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(",", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := stri1[ .. round(num1)];
writeln(log, "LEFT$(" <& literal(stri1) <& ", " <& num1 <&
") -> " <& literal(exprResult));
when {"LTRIM$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
index1 := 1;
while index1 <= length(stri1) and stri1[index1] = ' ' do
incr(index1);
end while;
exprResult := stri1[index1 ..];
writeln(log, "LTRIM$(" <& literal(stri1) <& ") -> " <& literal(exprResult));
when {"MID$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(",", symbol, line);
num1 := exec_expr(symbol, line);
if symbol = "," then
symbol := get_symbol(line);
num2 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := stri1[round(num1) .. round(num1) + round(num2) - 1];
write(log, "MID$(" <& literal(stri1) <& ", " <& num1 <& ", " <& num2);
else
expect(")", symbol, line);
exprResult := stri1[round(num1) .. ];
write(log, "MID$(" <& literal(stri1) <& ", " <& num1);
end if;
writeln(log, ") -> " <& literal(exprResult));
when {"MKD$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := bytes(bin64(num1), LE, 8);
writeln(log, "MKD$(" <& num1 <& ") -> " <& literal(exprResult));
when {"MKDMBF$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
block
exprResult := bytes(float2MbfBits(num1, DOUBLE), LE, 8);
writeln(log, "MKDMBF$(" <& num1 <& ") -> " <& literal(exprResult));
exception
catch RANGE_ERROR:
error_marker;
writeln(err, "MKDMBF$(" <& num1 <& ") FAILED");
end block
when {"MKI$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
index1 := round(exec_expr(symbol, line));
expect(")", symbol, line);
exprResult := str(chr(index1 mod 256)) &
str(chr(index1 mdiv 256 mod 256));
writeln(log, "MKI$(" <& index1 <& ") -> " <& literal(exprResult));
when {"MKL$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
index1 := round(exec_expr(symbol, line));
expect(")", symbol, line);
exprResult := str(chr(index1 mod 256)) &
str(chr(index1 mdiv 256 mod 256)) &
str(chr(index1 mdiv 65536 mod 256)) &
str(chr(index1 mdiv 16777216 mod 256));
writeln(log, "MKL$(" <& index1 <& ") -> " <& literal(exprResult));
when {"MKS$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := bytes(bin32(num1), LE, 4);
writeln(log, "MKS$(" <& num1 <& ") -> " <& literal(exprResult));
when {"MKSMBF$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
block
exprResult := bytes(float2MbfBits(num1, SINGLE), LE, 4);
writeln(log, "MKSMBF$(" <& num1 <& ") -> " <& literal(exprResult));
exception
catch RANGE_ERROR:
error_marker;
writeln(err, "MKSMBF$(" <& num1 <& ") FAILED");
end block
when {"OCT$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := round(num1) RADIX 8;
writeln(log, "OCT$(" <& num1 <& ") -> " <& literal(exprResult));
when {"RIGHT$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(",", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := stri1[length(stri1) - round(num1) + 1 .. ];
writeln(log, "RIGHT$(" <& literal(stri1) <& ", " <& num1 <&
") -> " <& literal(exprResult));
when {"RPT$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(",", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
index1 := round(num1);
if index1 >= 0 then
exprResult := stri1 mult index1;
writeln(log, "RPT$(" <& literal(stri1) <& ", " <& num1 <&
") -> " <& literal(exprResult));
else
error_marker;
writeln(err, "RPT$(" <& literal(stri1) <& ", " <& num1 <&
") - REPEAT COUNT NEGATIVE");
end if;
when {"RTRIM$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
index1 := length(stri1);
while index1 >= 1 and stri1[index1] = ' ' do
decr(index1);
end while;
exprResult := stri1[.. index1];
writeln(log, "RTRIM$(" <& literal(stri1) <& ") -> " <& literal(exprResult));
when {"SEG$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(",", symbol, line);
num1 := exec_expr(symbol, line);
expect(",", symbol, line);
num2 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := stri1[round(num1) len round(num2)];
write(log, "SEG$(" <& literal(stri1) <& ", " <& num1 <& ", " <& num2);
writeln(log, ") -> " <& literal(exprResult));
when {"SPACE$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
index1 := round(num1);
if index1 >= 0 then
exprResult := " " mult index1;
writeln(log, "SPACE$(" <& num1 <& ") -> " <& literal(exprResult));
else
error_marker;
writeln(err, "REPEAT COUNT " <& num1 <& " NEGATIVE IN SPACE$.");
end if;
when {"STR$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := str(round(num1));
if exprResult[1] <> '-' then
exprResult := " " & exprResult;
end if;
if exprResult[length(exprResult) - 1 .. ] = ".0" then
exprResult := exprResult[ .. length(exprResult) - 2];
end if;
writeln(log, "STR$(" <& num1 <& ") -> " <& literal(exprResult));
when {"STRING$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(",", symbol, line);
index1 := round(num1);
if index1 >= 0 then
if isStringExpr(symbol) then
stri1 := exec_str_expr(symbol, line, unused_name);
exprResult := stri1 mult index1;
writeln(log, "STRING$(" <& num1 <& ", " <& literal(stri1) <&
") -> " <& literal(exprResult));
else
num2 := exec_expr(symbol, line);
exprResult := str(chr(round(num2))) mult index1;
writeln(log, "STRING$(" <& num1 <& ", " <& num2 <&
") -> " <& literal(exprResult));
end if;
expect(")", symbol, line);
else
error_marker;
writeln(err, "REPEAT COUNT " <& num1 <& " NEGATIVE IN STRING$.");
while symbol <> ")" do
symbol := get_symbol(line);
end while;
symbol := get_symbol(line);
end if;
when {"TIME$"}:
symbol := get_symbol(line);
exprResult := strTime(truncToSecond(time(NOW)));
writeln(log, "TIME$ -> " <& literal(exprResult));
when {"UCASE$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
exprResult := upper(stri1);
writeln(log, "UCASE$(" <& literal(stri1) <& ") -> " <& literal(exprResult));
when {"VARPTR$"}:
symbol := get_symbol(line);
expect("(", symbol, line);
variable_name := get_name(symbol, line);
expect(")", symbol, line);
exprResult := varptrStri(variable_name);
writeln(log, "VARPTR$(" <& variable_name <& ") -> " <& literal(exprResult));
otherwise:
if symbol[1] = '"' then
exprResult := symbol[2 .. ];
symbol := get_symbol(line);
elsif symbol[1] >= 'A' and symbol[1] <= 'Z' then
if symbol in def_fn_list then
func_name := symbol;
exprResult := exec_str_function(def_fn_list[func_name], symbol, line);
writeln(log, "function " <& func_name <& " is " <& literal(exprResult));
elsif symbol in subfunction then
func_name := symbol;
line_marker;
writeln(log, "**CALL FUNCTION " <& symbol);
symbol := get_symbol(line);
if symbol = "(" then
repeat
symbol := get_symbol(line);
until symbol = ")";
symbol := get_symbol(line);
end if;
set_return_position(line);
gosubReturn[1].subName := func_name;
file_line_number := subfunction[func_name];
line_marker;
writeln(log, "EXECUTE FUNCTION " <& func_name);
incr(file_line_number);
execLines;
file_line_number := gosubReturn[1].returnLine;
gosubReturn := gosubReturn[2 .. ];
exprResult := getStringVar(func_name);
line_marker;
writeln(log, "RETURN FROM FUNCTION " <& func_name <& " -> " <& literal(exprResult));
else
variable_name := get_name(symbol, line);
exprResult := getStringVar(variable_name);
writeln(log, variable_name <& " is " <& literal(exprResult));
end if;
else
error_marker;
writeln(err, "UNEXPECTED SYMBOL " <& literal(symbol) <& ".");
end if;
end case;
end func;
const func string: exec_str_mult (inout string: symbol, inout string: line,
inout string: variable_name) is func
result
var string: exprResult is "";
local
var float: num1 is 0.0;
var integer: factor is 0;
begin
exprResult := exec_str_primary(symbol, line, variable_name);
while symbol = "*" do
variable_name := "";
symbol := get_symbol(line);
num1 := exec_expr(symbol, line);
factor := round(num1);
if factor >= 0 then
exprResult := exprResult mult factor;
else
error_marker;
writeln(err, "REPEAT COUNT " <& num1 <&
" NEGATIVE IN STRING MULTIPLICATION.");
end if;
end while;
end func;
const func string: exec_str_expr (inout string: symbol, inout string: line,
inout string: variable_name) is func
result
var string: exprResult is "";
local
var string: unused_name is "";
var string: stri is "";
begin
exprResult := exec_str_mult(symbol, line, variable_name);
while symbol = "+" or symbol = "&" do
variable_name := "";
symbol := get_symbol(line);
stri := exec_str_mult(symbol, line, unused_name);
exprResult &:= stri;
end while;
end func;
const func float: exec_function (in defFnType: defFn, inout string: symbol, inout string: line) is func
result
var float: exprResult is 0.0;
local
var string: func_expr is "";
var string: func_symbol is "";
var string: formal_params is "";
var string: formal_param is "";
var string: unused_name is "";
var array string: str_value_backup is 0 times "";
var array float: num_value_backup is 0 times 0.0;
begin
write(log, "function " <& defFn.name);
formal_params := defFn.params;
symbol := get_symbol(line);
if symbol = "(" then
write(log, "(");
repeat
symbol := get_symbol(line);
formal_param := get_symbol(formal_params);
if formal_param[length(formal_param)] = '$' then
if formal_param in string_var then
str_value_backup &:= [] (string_var[formal_param]);
else
str_value_backup &:= [] ("");
end if;
string_var @:= [formal_param] exec_str_expr(symbol, line, unused_name);
write(log, string_var[formal_param]);
else
if formal_param in numeric_var then
num_value_backup &:= [] (numeric_var[formal_param]);
else
num_value_backup &:= [] (0.0);
end if;
numeric_var @:= [formal_param] exec_expr(symbol, line);
write(log, numeric_var[formal_param]);
end if;
write(log, symbol);
until symbol <> ",";
expect(")", symbol, line);
end if;
func_expr := defFn.expression;
writeln(log, " = " <& func_expr);
func_symbol := get_symbol(func_expr);
exprResult := exec_expr(func_symbol, func_expr);
formal_params := defFn.params;
formal_param := get_symbol(formal_params);
while formal_param <> "" do
if formal_param[length(formal_param)] = '$' then
string_var @:= [formal_param] str_value_backup[1];
str_value_backup := str_value_backup[2 ..];
else
numeric_var @:= [formal_param] num_value_backup[1];
num_value_backup := num_value_backup[2 ..];
end if;
formal_param := get_symbol(formal_params);
end while;
end func;
const func float: exec_primary (inout string: symbol, inout string: line) is func
result
var float: exprResult is 0.0;
local
var string: variable_name is "";
var string: unused_name is "";
var string: stri1 is "";
var string: stri2 is "";
var float: num1 is 0.0;
var integer: index1 is 0;
var integer: index2 is 0;
var char: current_key is ' ';
var time: time_now is time.value;
var duration: since_midnight is duration.value;
var string: func_name is "";
var file: aFile is STD_NULL;
begin
case symbol of
when {""}:
error_marker;
writeln(err, "EXPRESSION EXPECTED - FOUND END OF LINE.");
when {"ABS"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := abs(num1);
writeln(log, "ABS(" <& num1 <& ") -> " <& exprResult);
when {"ASC"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
if stri1 <> "" then
exprResult := flt(ord(stri1[1]));
writeln(log, "ASC(" <& literal(stri1) <& ") -> " <& exprResult);
else
error_marker;
writeln(err, "ASC(\"\") - ILLEGAL FUNCTION CALL");
end if;
when {"ATN"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := atan(num1);
writeln(log, "ATN(" <& num1 <& ") -> " <& exprResult);
when {"CDBL"}:
symbol := get_symbol(line);
expect("(", symbol, line);
exprResult := exec_expr(symbol, line);
expect(")", symbol, line);
writeln(log, "CDBL(" <& exprResult <& ") -> " <& exprResult);
when {"CINT"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := flt(round(num1));
writeln(log, "CINT(" <& num1 <& ") -> " <& exprResult);
when {"CLNG"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := flt(round(num1));
writeln(log, "CLNG(" <& num1 <& ") -> " <& exprResult);
when {"COS"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := cos(num1);
writeln(log, "COS(" <& num1 <& ") -> " <& exprResult);
when {"CSNG"}:
symbol := get_symbol(line);
expect("(", symbol, line);
exprResult := exec_expr(symbol, line);
expect(")", symbol, line);
writeln(log, "CSNG(" <& exprResult <& ") -> " <& exprResult);
when {"CSRLIN"}:
symbol := get_symbol(line);
exprResult := flt(line(win));
writeln(log, "CSRLIN -> " <& exprResult);
when {"CVD"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
if length(stri1) >= 8 then
exprResult := float(bin64(stri1[.. 8], LE));
writeln(log, "CVD(" <& literal(stri1) <& ") -> " <& exprResult);
else
error_marker;
writeln(err, "CVD(" <& literal(stri1) <& ") IS ILLEGAL.");
exprResult := 0.0;
end if;
when {"CVDMBF"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
if length(stri1) >= 8 then
exprResult := mbfBits2Float(bin64(stri1[.. 8], LE));
writeln(log, "CVDMBF(" <& literal(stri1) <& ") -> " <& exprResult);
else
error_marker;
writeln(err, "CVDMBF(" <& literal(stri1) <& ") IS ILLEGAL.");
exprResult := 0.0;
end if;
when {"CVI"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
if length(stri1) >= 2 then
if ord(stri1[2]) >= 128 then
exprResult := flt((ord(stri1[2]) - 256) * 256 + ord(stri1[1]));
else
exprResult := flt(ord(stri1[2]) * 256 + ord(stri1[1]));
end if;
writeln(log, "CVI(" <& literal(stri1) <& ") -> " <& exprResult);
else
error_marker;
writeln(err, "CVI(" <& literal(stri1) <& ") IS ILLEGAL.");
exprResult := 0.0;
end if;
when {"CVL"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
if length(stri1) >= 4 then
if ord(stri1[4]) >= 128 then
exprResult := flt((((ord(stri1[4]) - 256) * 256 + ord(stri1[3])) * 256 +
ord(stri1[2])) * 256 + ord(stri1[1]));
else
exprResult := flt(((ord(stri1[4]) * 256 + ord(stri1[3])) * 256 +
ord(stri1[2])) * 256 + ord(stri1[1]));
end if;
writeln(log, "CVL(" <& literal(stri1) <& ") -> " <& exprResult);
else
error_marker;
writeln(err, "CVL(" <& literal(stri1) <& ") IS ILLEGAL.");
exprResult := 0.0;
end if;
when {"CVS"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
if length(stri1) >= 4 then
exprResult := float(bin32(stri1[.. 4], LE));
writeln(log, "CVS(" <& literal(stri1) <& ") -> " <& exprResult);
else
error_marker;
writeln(err, "CVS(" <& literal(stri1) <& ") IS ILLEGAL.");
exprResult := 0.0;
end if;
when {"CVSMBF"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
if length(stri1) >= 4 then
exprResult := mbfBits2Float(bin32(stri1[.. 4], LE));
writeln(log, "CVSMBF(" <& literal(stri1) <& ") -> " <& exprResult);
else
error_marker;
writeln(err, "CVSMBF(" <& literal(stri1) <& ") IS ILLEGAL.");
exprResult := 0.0;
end if;
when {"EOF"}:
symbol := get_symbol(line);
expect("(", symbol, line);
index1 := round(exec_expr(symbol, line));
expect(")", symbol, line);
aFile := getFileValue(index1);
if aFile <> STD_NULL then
if hasNext(aFile) then
exprResult := 0.0;
else
exprResult := -1.0;
end if;
writeln(log, "EOF(" <& index1 <& ") -> " <& exprResult);
else
error_marker;
writeln(err, "FILE #" <& index1 <& " NOT OPEN IN EOF.");
exprResult := -1.0;
end if;
when {"ERL"}:
symbol := get_symbol(line);
if error_linenum <> "" and error_linenum[1] in digit_char then
exprResult := flt(integer(error_linenum));
else
exprResult := 0.0;
end if;
writeln(log, "ERL -> " <& exprResult);
when {"ERR"}:
symbol := get_symbol(line);
exprResult := flt(error_code);
writeln(log, "ERR -> " <& exprResult);
when {"EXP"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := exp(num1);
writeln(log, "EXP(" <& num1 <& ") -> " <& exprResult);
when {"FIX"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := flt(trunc(num1));
writeln(log, "FIX(" <& num1 <& ") -> " <& exprResult);
when {"FN"}:
variable_name := get_name(symbol, line);
if variable_name <> "FN" or ("FN" & symbol) not in def_fn_list then
exprResult := getNumericVar(variable_name);
writeln(log, variable_name <& " is " <& exprResult);
else
func_name := "FN" & symbol;
exprResult := exec_function(def_fn_list[func_name], symbol, line);
writeln(log, "function " <& func_name <& " is " <& exprResult);
end if;
when {"FRE"}:
symbol := get_symbol(line);
expect("(", symbol, line);
if isStringExpr(symbol) then
stri1 := exec_str_expr(symbol, line, unused_name);
else
num1 := exec_expr(symbol, line);
end if;
expect(")", symbol, line);
exprResult := 32767.0;
writeln(log, "FRE -> " <& exprResult);
when {"FREEFILE"}:
symbol := get_symbol(line);
index1 := 1;
while getFileValue(index1) <> STD_NULL do
incr(index1);
end while;
exprResult := flt(index1);
writeln(log, "FREEFILE -> " <& exprResult);
when {"INP"}:
symbol := get_symbol(line);
expect("(", symbol, line);
index1 := round(exec_expr(symbol, line));
expect(")", symbol, line);
case index1 of
when {16#60}:
if inputReady(KEYBOARD) then
exprResult := flt(keyboardScanCode(getc(KEYBOARD)));
else
exprResult := 128.0;
end if;
when {16#3DA}:
exprResult := flt(rand(0, 1) * 8);
otherwise:
exprResult := 0.0;
end case;
writeln(log, "**INP(" <& index1 <& ") -> " <& exprResult);
when {"INSTR"}:
symbol := get_symbol(line);
expect("(", symbol, line);
if isStringExpr(symbol) then
index1 := 1;
else
index1 := round(exec_expr(symbol, line));
expect(",", symbol, line);
end if;
stri1 := exec_str_expr(symbol, line, unused_name);
expect(",", symbol, line);
stri2 := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
if index1 >= 1 then
exprResult := flt(pos(stri1, stri2, index1));
write(log, "INSTR(");
if index1 <> 1 then
write(log, index1 <& ", ");
end if;
writeln(log, literal(stri1) <& ", " <& literal(stri2) <& ") -> " <& exprResult);
else
error_marker;
writeln(err, "INSTR(" <& index1 <& ", " <& literal(stri1) <& ", " <&
literal(stri2) <& ") - ILLEGAL FUNCTION CALL");
end if;
when {"INT"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := floor(num1);
writeln(log, "INT(" <& num1 <& ") -> " <& exprResult);
when {"LBOUND"}:
symbol := get_symbol(line);
expect("(", symbol, line);
variable_name := symbol;
symbol := get_symbol(line);
if symbol = "," then
symbol := get_symbol(line);
index1 := round(exec_expr(symbol, line));
else
index1 := 1;
end if;
expect(")", symbol, line);
exprResult := flt(exec_lbound(variable_name, index1));
writeln(log, "LBOUND(" <& variable_name <& ", " <& index1 <& ") -> " <& exprResult);
when {"LEN"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
exprResult := flt(length(stri1));
writeln(log, "LEN(" <& literal(stri1) <& ") -> " <& exprResult);
when {"LOF"}:
symbol := get_symbol(line);
expect("(", symbol, line);
index1 := round(exec_expr(symbol, line));
expect(")", symbol, line);
aFile := getFileValue(index1);
if aFile <> STD_NULL then
exprResult := flt(length(aFile));
writeln(log, "LOF(" <& index1 <& ") -> " <& exprResult);
else
error_marker;
writeln(err, "FILE #" <& index1 <& " NOT OPEN IN LOF.");
end if;
when {"LOG"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
if num1 > 0.0 then
exprResult := log(num1);
writeln(log, "LOG(" <& num1 <& ") -> " <& exprResult);
else
error_marker;
writeln(err, "LOG(" <& num1 <& ") - ILLEGAL FUNCTION CALL");
end if;
when {"PEEK"}:
symbol := get_symbol(line);
expect("(", symbol, line);
index1 := round(exec_expr(symbol, line));
expect(")", symbol, line);
case index1 of
when {16}:
exprResult := 35.0;
when {1040}:
exprResult := 35.0;
when {16#6c}:
time_now := time(NOW);
since_midnight := time_now - truncToDay(time_now);
exprResult := 18.2 * (flt(toSeconds(since_midnight)) +
flt(since_midnight.micro_second) / 1000000.0);
exprResult -:= floor(exprResult / 256.0) * 256.0;
index1 := round(exprResult);
if index1 < 0 then
exprResult := 0.0;
elsif index1 > 255 then
exprResult := 255.0;
else
exprResult := flt(index1);
end if;
when {49152, -16384}:
if inputReady(KEYBOARD) then
current_key := getc(KEYBOARD);
if current_key = KEY_NL then
current_key := KEY_CR;
elsif current_key >= '\128;' then
current_key := '\0;';
end if;
exprResult := flt(ord(current_key) + 128);
else
exprResult := 0.0;
end if;
otherwise:
exprResult := 0.0;
end case;
writeln(log, "**PEEK(" <& index1 <& ") -> " <& exprResult);
when {"POINT"}:
symbol := get_symbol(line);
expect("(", symbol, line);
index1 := round(exec_expr(symbol, line));
if symbol = "," then
symbol := get_symbol(line);
index2 := round(exec_expr(symbol, line));
expect(")", symbol, line);
exprResult := 0.0;
writeln(log, "**POINT(" <& index1 <& ", " <& index2 <& ") -> " <& exprResult);
else
expect(")", symbol, line);
exprResult := 0.0;
writeln(log, "**POINT(" <& index1 <& ") -> " <& exprResult);
end if;
when {"POS"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := flt(column(win));
writeln(log, "POS -> " <& exprResult);
when {"RND"}:
symbol := get_symbol(line);
if symbol = "(" then
symbol := get_symbol(line);
if symbol <> ")" then
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
if num1 <> 0.0 then
lastRandomNumber := rand(0.0, 1.0);
end if;
else
expect(")", symbol, line);
lastRandomNumber := rand(0.0, 1.0);
end if;
else
lastRandomNumber := rand(0.0, 1.0);
end if;
exprResult := lastRandomNumber;
writeln(log, "RND -> " <& exprResult);
when {"SCREEN"}:
symbol := get_symbol(line);
expect("(", symbol, line);
index1 := round(exec_expr(symbol, line));
expect(",", symbol, line);
index2 := round(exec_expr(symbol, line));
if symbol = "," then
symbol := get_symbol(line);
num1 := exec_expr(symbol, line);
end if;
expect(")", symbol, line);
exprResult := 32.0;
writeln(log, "**SCREEN(" <& index1 <& ", " <& index2 <& ") -> " <& exprResult);
when {"SGN"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
if num1 > 0.0 then
exprResult := 1.0;
elsif num1 = 0.0 then
exprResult := 0.0;
else
exprResult := -1.0;
end if;
writeln(log, "SGN(" <& num1 <& ") -> " <& exprResult);
when {"SIN"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := sin(num1);
writeln(log, "SIN(" <& num1 <& ") -> " <& exprResult);
when {"SQR"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
if num1 >= 0.0 then
exprResult := sqrt(num1);
writeln(log, "SQR(" <& num1 <& ") -> " <& exprResult);
else
error_marker;
writeln(err, "SQR(" <& num1 <& ") - ILLEGAL FUNCTION CALL");
end if;
when {"STRIG"}:
symbol := get_symbol(line);
expect("(", symbol, line);
index1 := round(exec_expr(symbol, line));
expect(")", symbol, line);
exprResult := 0.0;
current_key := getc(KEYBOARD, NO_WAIT);
case index1 of
when {0, 1}:
if current_key = KEY_MOUSE1 then
current_key := getc(KEYBOARD);
exprResult := -1.0;
end if;
when {4, 5}:
if current_key = KEY_MOUSE3 then
current_key := getc(KEYBOARD);
exprResult := -1.0;
end if;
end case;
writeln(log, "**STRIG(" <& index1 <& ") -> " <& exprResult);
when {"TAN"}:
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
exprResult := tan(num1);
writeln(log, "TAN(" <& num1 <& ") -> " <& exprResult);
when {"TIMER"}:
symbol := get_symbol(line);
time_now := time(NOW);
since_midnight := time_now - truncToDay(time_now);
exprResult := flt(toSeconds(since_midnight)) +
flt(since_midnight.micro_second) / 1000000.0;
writeln(log, "TIMER -> " <& exprResult);
when {"UBOUND"}:
symbol := get_symbol(line);
expect("(", symbol, line);
variable_name := symbol;
symbol := get_symbol(line);
if symbol = "," then
symbol := get_symbol(line);
index1 := round(exec_expr(symbol, line));
else
index1 := 1;
end if;
expect(")", symbol, line);
exprResult := flt(exec_ubound(variable_name, index1));
writeln(log, "UBOUND(" <& variable_name <& ", " <& index1 <& ") -> " <& exprResult);
when {"VAL"}:
symbol := get_symbol(line);
expect("(", symbol, line);
stri1 := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
stri2 := get_symbol(stri1);
if stri2 = "-" then
stri2 &:= get_symbol(stri1);
elsif stri2 = "+" then
stri2 := get_symbol(stri1);
end if;
block
exprResult := float(stri2);
exception
catch RANGE_ERROR:
exprResult := 0.0;
end block;
writeln(log, "VAL(" <& literal(stri2) <& ") -> " <& exprResult);
when {"VARPTR"}:
symbol := get_symbol(line);
expect("(", symbol, line);
variable_name := get_name(symbol, line);
expect(")", symbol, line);
exprResult := flt(varptr(variable_name));
writeln(log, "VARPTR(" <& variable_name <& ") -> " <& exprResult);
when {"("}:
symbol := get_symbol(line);
exprResult := exec_expr(symbol, line);
expect(")", symbol, line);
when {"%"}:
variable_name := "";
repeat
variable_name &:= symbol;
symbol := get_symbol(line);
if symbol <> "" and symbol[1] in alphanum_char then
variable_name &:= symbol;
symbol := get_symbol(line);
end if;
until symbol <> "_";
append_index(variable_name, symbol, line);
exprResult := getNumericVar(variable_name);
writeln(log, variable_name <& " is " <& exprResult);
otherwise:
if symbol[1] in digit_char then
if symbol[length(symbol)] in number_suffix then
symbol := symbol[.. pred(length(symbol))];
end if;
block
exprResult := float(symbol);
exception
catch RANGE_ERROR:
error_marker;
writeln(err, "ERROR IN PARSE NUMBER " <& literal(symbol) <& ".");
end block;
symbol := get_symbol(line);
elsif symbol[1] >= 'A' and symbol[1] <= 'Z' then
if symbol in def_fn_list then
func_name := symbol;
exprResult := exec_function(def_fn_list[func_name], symbol, line);
writeln(log, "function " <& func_name <& " is " <& exprResult);
elsif symbol in subfunction then
func_name := symbol;
line_marker;
writeln(log, "**CALL FUNCTION " <& symbol);
symbol := get_symbol(line);
if symbol = "(" then
repeat
symbol := get_symbol(line);
until symbol = ")";
symbol := get_symbol(line);
end if;
set_return_position(line);
gosubReturn[1].subName := func_name;
file_line_number := subfunction[func_name];
line_marker;
writeln(log, "EXECUTE FUNCTION " <& func_name);
incr(file_line_number);
execLines;
file_line_number := gosubReturn[1].returnLine;
gosubReturn := gosubReturn[2 .. ];
exprResult := getNumericVar(func_name);
line_marker;
writeln(log, "RETURN FROM FUNCTION " <& func_name <& " -> " <& exprResult);
else
variable_name := get_name(symbol, line);
exprResult := getNumericVar(variable_name);
writeln(log, variable_name <& " is " <& exprResult);
end if;
else
error_marker;
writeln(err, "UNEXPECTED SYMBOL " <& literal(symbol) <& ".");
end if;
end case;
end func;
const func float: exec_exponentation (inout string: symbol, inout string: line) is func
result
var float: exprResult is 0.0;
local
var float: num is 0.0;
begin
exprResult := exec_primary(symbol, line);
if symbol = "^" then
symbol := get_symbol(line);
num := exec_primary(symbol, line);
if flt(round(num)) = num then
exprResult := exprResult ** round(num);
else
exprResult := exprResult ** num;
end if;
end if;
end func;
const func float: exec_negation (inout string: symbol, inout string: line) is func
result
var float: exprResult is 0.0;
begin
if symbol = "-" then
symbol := get_symbol(line);
exprResult := -exec_exponentation(symbol, line);
elsif symbol = "+" then
symbol := get_symbol(line);
exprResult := exec_exponentation(symbol, line);
else
exprResult := exec_exponentation(symbol, line);
end if;
end func;
const func float: exec_multdiv (inout string: symbol, inout string: line) is func
result
var float: exprResult is 0.0;
local
var string: op is "";
var float: num1 is 0.0;
var float: num2 is 0.0;
begin
exprResult := exec_negation(symbol, line);
while symbol = "*" or symbol = "/" or symbol = "\\" or symbol = "MOD" do
op := symbol;
symbol := get_symbol(line);
num1 := exprResult;
num2 := exec_negation(symbol, line);
if op = "*" then
exprResult := num1 * num2;
else
block
if op = "/" then
exprResult := num1 / num2;
if abs(exprResult) = Infinity or isNaN(exprResult) then
raise NUMERIC_ERROR;
end if;
elsif op = "\\" then
exprResult := flt(round(num1) div round(num2));
elsif op = "MOD" then
exprResult := flt(round(num1) rem round(num2));
end if;
exception
catch NUMERIC_ERROR:
if on_error_label <> "" then
error_code := 11;
writeln(log);
line_marker;
writeln(log, error_code <& " DIVISION BY ZERO (" <&
num1 <& " " <& op <& " " <& num2 <& ")" <&
" - ON ERROR GOTO " <& on_error_label);
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "DIVISION BY ZERO (" <&
num1 <& " " <& op <& " " <& num2 <& ")");
end if;
if num1 >= 0.0 then
exprResult := Infinity;
else
exprResult := -Infinity;
end if;
end block;
end if;
end while;
end func;
const func float: exec_addsub (inout string: symbol, inout string: line) is func
result
var float: exprResult is 0.0;
local
var string: op is "";
var float: num is 0.0;
begin
exprResult := exec_multdiv(symbol, line);
while symbol = "+" or symbol = "-" do
op := symbol;
symbol := get_symbol(line);
num := exec_multdiv(symbol, line);
if op = "+" then
exprResult := exprResult + num;
elsif op = "-" then
exprResult := exprResult - num;
end if;
end while;
end func;
const func float: exec_comparison (inout string: symbol, inout string: line) is func
result
var float: exprResult is 0.0;
local
var string: unused_name is "";
var string: op is "";
var string: stri1 is "";
var string: stri2 is "";
var float: num is 0.0;
begin
if isStringExpr(symbol) and symbol not in numeric_functions then
stri1 := exec_str_expr(symbol, line, unused_name);
if symbol = "=" or symbol = "<>" or
symbol = "<" or symbol = ">" or
symbol = "<=" or symbol = ">=" then
op := symbol;
symbol := get_symbol(line);
stri2 := exec_str_expr(symbol, line, unused_name);
if op = "=" then
exprResult := flt(-ord(stri1 = stri2));
elsif op = "<>" then
exprResult := flt(-ord(stri1 <> stri2));
elsif op = "<" then
exprResult := flt(-ord(stri1 < stri2));
elsif op = ">" then
exprResult := flt(-ord(stri1 > stri2));
elsif op = "<=" then
exprResult := flt(-ord(stri1 <= stri2));
elsif op = ">=" then
exprResult := flt(-ord(stri1 >= stri2));
end if;
else
error_marker;
writeln(err, "COMPARISON EXPECTED - FOUND " <& literal(symbol) <& ".");
end if;
else
exprResult := exec_addsub(symbol, line);
if symbol = "=" or symbol = "<>" or
symbol = "<" or symbol = ">" or
symbol = "<=" or symbol = ">=" then
op := symbol;
symbol := get_symbol(line);
num := exec_addsub(symbol, line);
if op = "=" then
exprResult := flt(-ord(exprResult = num));
elsif op = "<>" then
exprResult := flt(-ord(exprResult <> num));
elsif op = "<" then
exprResult := flt(-ord(exprResult < num));
elsif op = ">" then
exprResult := flt(-ord(exprResult > num));
elsif op = "<=" then
exprResult := flt(-ord(exprResult <= num));
elsif op = ">=" then
exprResult := flt(-ord(exprResult >= num));
end if;
end if;
end if;
end func;
const func float: exec_cond_not (inout string: symbol, inout string: line) is func
result
var float: exprResult is 0.0;
local
var float: num is 0.0;
begin
if symbol = "NOT" then
symbol := get_symbol(line);
num := exec_comparison(symbol, line);
exprResult := flt(-ord(num = 0.0));
else
exprResult := exec_comparison(symbol, line);
end if;
end func;
const func integer: binary_and (in var integer: number1, in var integer: number2) is func
result
var integer: exprResult is 0;
local
var integer: count is 0;
begin
for count range 0 to 15 do
if odd(number1) and odd(number2) then
exprResult +:= 2 ** count;
end if;
number1 := number1 div 2;
number2 := number2 div 2;
end for;
end func;
const func float: exec_cond_and (inout string: symbol, inout string: line) is func
result
var float: exprResult is 0.0;
local
var integer: number1 is 0;
var integer: number2 is 0;
begin
exprResult := exec_cond_not(symbol, line);
if startsWith(symbol, "AND") then
line := symbol[4 ..] & line;
symbol := "AND";
end if;
while symbol = "AND" do
number1 := round(exprResult);
symbol := get_symbol(line);
number2 := round(exec_cond_not(symbol, line));
exprResult := flt(binary_and(number1, number2));
if startsWith(symbol, "AND") then
line := symbol[4 ..] & line;
symbol := "AND";
end if;
end while;
end func;
const func integer: binary_or (in var integer: number1, in var integer: number2) is func
result
var integer: exprResult is 0;
local
var integer: count is 0;
begin
for count range 0 to 15 do
if odd(number1) or odd(number2) then
exprResult +:= 2 ** count;
end if;
number1 := number1 div 2;
number2 := number2 div 2;
end for;
end func;
const func integer: binary_xor (in var integer: number1, in var integer: number2) is func
result
var integer: exprResult is 0;
local
var integer: count is 0;
begin
for count range 0 to 15 do
if odd(number1) <> odd(number2) then
exprResult +:= 2 ** count;
end if;
number1 := number1 div 2;
number2 := number2 div 2;
end for;
end func;
const func float: exec_cond_or (inout string: symbol, inout string: line) is func
result
var float: exprResult is 0.0;
local
var string: op is "";
var integer: number1 is 0;
var integer: number2 is 0;
begin
exprResult := exec_cond_and(symbol, line);
if startsWith(symbol, "OR") then
line := symbol[3 ..] & line;
symbol := "OR";
end if;
while symbol = "OR" or symbol = "XOR" do
number1 := round(exprResult);
op := symbol;
symbol := get_symbol(line);
number2 := round(exec_cond_and(symbol, line));
if op = "OR" then
exprResult := flt(binary_or(number1, number2));
elsif op = "XOR" then
exprResult := flt(binary_xor(number1, number2));
end if;
if startsWith(symbol, "OR") then
line := symbol[3 ..] & line;
symbol := "OR";
end if;
end while;
end func;
const func integer: binary_eqv (in var integer: number1, in var integer: number2) is func
result
var integer: exprResult is 0;
local
var integer: count is 0;
begin
for count range 0 to 15 do
if odd(number1) = odd(number2) then
exprResult +:= 2 ** count;
end if;
number1 := number1 div 2;
number2 := number2 div 2;
end for;
end func;
const func float: exec_cond_eqv (inout string: symbol, inout string: line) is func
result
var float: exprResult is 0.0;
local
var integer: number1 is 0;
var integer: number2 is 0;
begin
exprResult := exec_cond_or(symbol, line);
while symbol = "EQV" do
number1 := round(exprResult);
symbol := get_symbol(line);
number2 := round(exec_cond_or(symbol, line));
exprResult := flt(binary_eqv(number1, number2));
end while;
end func;
const func integer: binary_imp (in var integer: number1, in var integer: number2) is func
result
var integer: exprResult is 0;
local
var integer: count is 0;
begin
for count range 0 to 15 do
if odd(number1) <= odd(number2) then
exprResult +:= 2 ** count;
end if;
number1 := number1 div 2;
number2 := number2 div 2;
end for;
end func;
const func float: exec_expr (inout string: symbol, inout string: line) is func
result
var float: exprResult is 0.0;
local
var integer: number1 is 0;
var integer: number2 is 0;
begin
exprResult := exec_cond_eqv(symbol, line);
while symbol = "IMP" do
number1 := round(exprResult);
symbol := get_symbol(line);
number2 := round(exec_cond_eqv(symbol, line));
exprResult := flt(binary_imp(number1, number2));
end while;
end func;
const func string: getNameList (inout string: symbol, inout string: line) is func
result
var string: nameList is "";
begin
nameList &:= symbol;
symbol := get_symbol(line);
while symbol = "," do
symbol := get_symbol(line);
if not endOfStatement(symbol) then
nameList &:= ",";
nameList &:= symbol;
symbol := get_symbol(line);
end if;
end while;
end func;
const func boolean: nameInList (in string: name, in var string: nameList) is func
result
var boolean: found is FALSE;
local
var string: symbol is "";
begin
repeat
symbol := get_symbol(nameList);
if name = symbol then
found := TRUE;
else
symbol := get_symbol(nameList);
end if;
until symbol <> "," or found;
end func;
const func string: removeNameFromList (in string: name, in var string: nameList) is func
result
var string: newNameList is "";
local
var string: symbol is "";
var boolean: found is FALSE;
begin
repeat
symbol := get_symbol(nameList);
if name = symbol then
symbol := get_symbol(nameList);
found := TRUE;
else
if newNameList <> "" then
newNameList &:= ",";
end if;
newNameList &:= symbol;
symbol := get_symbol(nameList);
end if;
until symbol <> "," or found;
newNameList &:= nameList;
end func;
const func string: next_symbol (inout string: line) is func
result
var string: symbol is "";
begin
repeat
symbol := get_symbol(line);
if symbol = "" then
incr(file_line_number);
if file_line_number <= length(prg) then
statement_label := prg[file_line_number].linenum;
line := prg[file_line_number].line;
symbol := get_symbol(line);
end if;
end if;
until symbol <> "" or file_line_number > length(prg);
end func;
const func string: find_then (inout string: line) is func
result
var string: symbol is "";
begin
symbol := get_symbol(line);
while symbol <> "THEN" and symbol <> "" do
if ignoreRestOfLine(symbol) then
line := "";
end if;
symbol := get_symbol(line);
end while;
end func;
const proc: find_else (inout string: symbol, inout string: line) is func
begin
if startsWith(symbol, "ELSE") and not is_let_statement(line) then
line := symbol[5 ..] & line;
symbol := "ELSE";
end if;
while symbol <> "ELSE" and symbol <> "" do
if startsWith(symbol, "IF") and not is_let_statement(line) then
line := symbol[3 ..] & line;
symbol := "IF";
end if;
if symbol = "IF" then
symbol := get_symbol(line);
find_else(symbol, line);
elsif ignoreRestOfLine(symbol) then
line := "";
end if;
symbol := get_symbol(line);
if startsWith(symbol, "ELSE") and not is_let_statement(line) then
line := symbol[5 ..] & line;
symbol := "ELSE";
end if;
end while;
end func;
const func boolean: find_next (inout string: symbol, inout string: line,
in string: varName, inout string: nameList) is func
result
var boolean: found is FALSE;
local
var string: label is "";
var string: innerVarName is "";
var string: innerNameList is "";
begin
while not found and symbol <> "NEXT" and symbol <> "" do
if symbol = "FOR" then
symbol := next_symbol(line);
innerVarName := symbol;
label := statement_label;
if find_next(symbol, line, innerVarName, innerNameList) and
(innerNameList = "" or nameInList(innerVarName, innerNameList)) then
if nameInList(varName, innerNameList) then
found := TRUE;
nameList := innerNameList;
end if;
else
error_marker(label);
writeln(err, "NO CORRESPONDING \"NEXT\" OR \"NEXT " <& innerVarName <&
"\" FOUND FOR \"FOR " <& innerVarName <& "\"");
end if;
elsif symbol = "EXIT" then
symbol := get_symbol(line);
elsif ignoreRestOfLine(symbol) then
line := "";
end if;
if not found then
symbol := next_symbol(line);
end if;
end while;
if not found and symbol = "NEXT" then
found := TRUE;
symbol := get_symbol(line);
if endOfStatement(symbol) then
nameList := "";
else
nameList := getNameList(symbol, line);
end if;
end if;
end func;
const func boolean: find_next (inout string: symbol, inout string: line,
in string: varName) is func
result
var boolean: found is FALSE;
local
var string: nameList is "";
begin
if symbol = "" then
symbol := next_symbol(line);
end if;
found := find_next(symbol, line, varName, nameList) and
(nameList = "" or nameInList(varName, nameList));
if found then
line_marker;
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
write(log, "LEAVE \"FOR " <& varName <& "\" - CONTINUE AFTER \"NEXT");
if nameList <> "" then
write(log, " " <& nameList);
end if;
writeln(log, "\"");
end if;
end func;
const func string: find_wend (inout string: line) is func
result
var string: symbol is "";
begin
symbol := next_symbol(line);
while symbol <> "WEND" and symbol <> "" do
if symbol = "WHILE" then
symbol := find_wend(line);
elsif symbol = "EXIT" then
symbol := get_symbol(line);
elsif ignoreRestOfLine(symbol) then
line := "";
end if;
symbol := next_symbol(line);
end while;
end func;
const func string: find_do (inout string: line) is func
result
var string: symbol is "";
begin
symbol := next_symbol(line);
while symbol <> "DO" and symbol <> "" do
if ignoreRestOfLine(symbol) then
line := "";
else
repeat
symbol := get_symbol(line);
until endOfStatement(symbol) or symbol = "THEN";
if ignoreRestOfLine(symbol) then
line := "";
end if;
end if;
symbol := next_symbol(line);
end while;
end func;
const func string: find_loop (inout string: line) is func
result
var string: symbol is "";
begin
symbol := next_symbol(line);
while symbol <> "LOOP" and symbol <> "" do
if symbol = "DO" then
symbol := find_loop(line);
elsif symbol = "EXIT" then
symbol := get_symbol(line);
elsif ignoreRestOfLine(symbol) then
line := "";
end if;
symbol := next_symbol(line);
end while;
end func;
const func string: find_end_sub (inout string: line) is func
result
var string: symbol is "";
begin
symbol := next_symbol(line);
while symbol <> "END" and symbol <> "" do
if symbol = "SUB" then
symbol := find_end_sub(line);
elsif symbol = "EXIT" then
symbol := get_symbol(line);
elsif ignoreRestOfLine(symbol) then
line := "";
end if;
symbol := next_symbol(line);
end while;
if symbol = "END" then
repeat
symbol := get_symbol(line);
until symbol <> "END";
if ignoreRestOfLine(symbol) then
line := "";
end if;
if symbol <> "SUB" then
symbol := find_end_sub(line);
end if;
end if;
end func;
const func string: find_end_function (inout string: line) is func
result
var string: symbol is "";
begin
symbol := next_symbol(line);
while symbol <> "END" and symbol <> "" do
if symbol = "FUNCTION" then
symbol := find_end_function(line);
elsif symbol = "EXIT" then
symbol := get_symbol(line);
elsif ignoreRestOfLine(symbol) then
line := "";
end if;
symbol := next_symbol(line);
end while;
if symbol = "END" then
repeat
symbol := get_symbol(line);
until symbol <> "END";
if ignoreRestOfLine(symbol) then
line := "";
end if;
if symbol <> "FUNCTION" then
symbol := find_end_function(line);
end if;
end if;
end func;
const func string: find_end_select (inout string: line) is func
result
var string: symbol is "";
begin
symbol := next_symbol(line);
while symbol <> "END" and symbol <> "" do
if symbol = "SELECT" then
symbol := find_end_select(line);
elsif symbol = "EXIT" then
symbol := get_symbol(line);
elsif ignoreRestOfLine(symbol) then
line := "";
end if;
symbol := next_symbol(line);
end while;
if symbol = "END" then
repeat
symbol := get_symbol(line);
until symbol <> "END";
if ignoreRestOfLine(symbol) then
line := "";
end if;
if symbol <> "SELECT" then
symbol := find_end_select(line);
end if;
end if;
end func;
const func string: find_end_if (inout string: line) is func
result
var string: symbol is "";
begin
symbol := next_symbol(line);
while symbol <> "END" and symbol <> "ENDIF" and symbol <> "" do
if symbol = "IF" then
repeat
symbol := find_then(line);
if symbol = "THEN" then
symbol := get_symbol(line);
if symbol = "" or symbol = "'" or symbol = "REM" then
symbol := find_end_if(line);
if symbol = "IF" then
symbol := "";
end if;
else
symbol := "";
line := "";
end if;
end if;
until symbol <> "IF";
end if;
if ignoreRestOfLine(symbol) then
line := "";
end if;
symbol := next_symbol(line);
end while;
if symbol = "END" then
repeat
symbol := get_symbol(line);
until symbol <> "END";
if ignoreRestOfLine(symbol) then
line := "";
end if;
if symbol <> "IF" then
symbol := find_end_if(line);
end if;
end if;
end func;
const func string: find_else_elseif_or_end_if (inout string: line) is func
result
var string: symbol is "";
begin
symbol := next_symbol(line);
while symbol <> "ELSE" and symbol <> "ELSEIF" and
symbol <> "END" and symbol <> "ENDIF" and symbol <> "" do
if symbol = "IF" then
repeat
symbol := find_then(line);
if symbol = "THEN" then
symbol := get_symbol(line);
if symbol = "" or symbol = "'" or symbol = "REM" then
symbol := find_end_if(line);
if symbol = "IF" then
symbol := "";
end if;
else
symbol := "";
line := "";
end if;
end if;
until symbol <> "IF";
elsif symbol = "CASE" then
symbol := get_symbol(line);
end if;
if ignoreRestOfLine(symbol) then
line := "";
end if;
symbol := next_symbol(line);
end while;
if symbol = "END" then
repeat
symbol := get_symbol(line);
until symbol <> "END";
if ignoreRestOfLine(symbol) then
line := "";
end if;
if symbol <> "IF" then
symbol := find_else_elseif_or_end_if(line);
end if;
end if;
end func;
const func string: find_case_or_end_select (inout string: line) is func
result
var string: symbol is "";
begin
symbol := next_symbol(line);
while symbol <> "CASE" and symbol <> "END" and symbol <> "" do
if symbol = "SELECT" then
symbol := get_symbol(line);
if symbol = "CASE" then
symbol := find_end_select(line);
end if;
elsif symbol = "EXIT" then
symbol := get_symbol(line);
elsif ignoreRestOfLine(symbol) then
line := "";
end if;
symbol := next_symbol(line);
end while;
if symbol = "END" then
repeat
symbol := get_symbol(line);
until symbol <> "END";
if ignoreRestOfLine(symbol) then
line := "";
end if;
if symbol <> "SELECT" then
symbol := find_case_or_end_select(line);
end if;
end if;
end func;
const proc: exec_elseif_else_chain (inout string: symbol, inout string: line,
inout boolean: process_next) is func
local
var float: num1 is 0.0;
var boolean: leaveChain is TRUE;
begin
repeat
symbol := find_else_elseif_or_end_if(line);
if symbol = "ELSE" then
if upper(prg[file_line_number].line[.. 4]) <> "ELSE" then
error_marker;
writeln(err, "ELSE NOT AT BEGINNING OF LINE");
end if;
symbol := get_symbol(line);
line_marker;
writeln(log, "ELSE - EXECUTE STATEMENT BLOCK");
if symbol <> "" and symbol <> "'" and symbol <> "REM" then
error_marker;
writeln(err, "BLOCK STARTS DIRECTLY AFTER ELSE");
process_next := TRUE;
end if;
leaveChain := TRUE;
elsif symbol = "ELSEIF" then
symbol := get_symbol(line);
num1 := exec_expr(symbol, line);
if num1 <> 0.0 then
expect("THEN", symbol, line);
line_marker;
writeln(log, "ELSEIF " <& num1 <& " THEN - EXECUTE STATEMENT BLOCK");
if symbol <> "" and symbol <> "'" and symbol <> "REM" then
error_marker;
writeln(err, "BLOCK STARTS DIRECTLY AFTER THEN");
process_next := TRUE;
end if;
leaveChain := TRUE;
else
line_marker;
writeln(log, "ELSEIF " <& num1 <& " THEN - SKIP STATEMENT BLOCK");
leaveChain := FALSE;
end if;
elsif symbol = "IF" or symbol = "ENDIF" then
symbol := get_symbol(line);
line_marker;
writeln(log, "END IF - NO \"THEN\" BLOCK WAS EXECUTED");
leaveChain := TRUE;
end if;
until leaveChain;
end func;
const proc: advance_after_statement (inout string: line) is func
local
var integer: length is 0;
var integer: column is 0;
var string: symbol is "";
begin
repeat
length := length(line);
symbol := get_symbol(line);
until endOfStatement(symbol);
column := length(prg[file_line_number].line) - length + 1;
line := prg[file_line_number].line[column ..];
end func;
const proc: exec_goto (inout string: symbol, inout string: line) is func
local
var integer: index1 is 0;
var integer: index2 is 0;
begin
symbol := get_symbol(line);
if label_or_linenum(symbol) then
line_marker;
writeln(log, "GOTO " <& symbol);
goto_label_or_linenum(symbol);
symbol := "";
line := "";
elsif symbol in multipleDefinedLabel then
error_marker;
writeln(err, "GOTO MULTIPLE DEFINED LABEL " <& symbol <& ".");
symbol := get_symbol(line);
else
index1 := round(exec_expr(symbol, line));
expect("OF", symbol, line);
if index1 >= 1 then
index2 := 1;
while index2 < index1 do
symbol := get_symbol(line);
if symbol = "," then
symbol := get_symbol(line);
incr(index2);
else
index2 := succ(index1);
end if;
end while;
if index2 = index1 then
if label_or_linenum(symbol) then
line_marker;
writeln(log, "GOTO " <& index1 <& " OF " <& symbol);
goto_label_or_linenum(symbol);
symbol := "";
line := "";
else
error_marker;
writeln(err, "UNDEFINED LABEL " <& symbol <& " AFTER \"OF\".");
end if;
else
line_marker;
writeln(log, "GOTO " <& index1 <& " OF NEXT STATEMENT");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end if;
else
line_marker;
writeln(log, "GOTO " <& index1 <& " OF NEXT STATEMENT");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end if;
end if;
end func;
const proc: exec_gosub (inout string: symbol, inout string: line) is func
local
var integer: index1 is 0;
var integer: index2 is 0;
begin
symbol := get_symbol(line);
if label_or_linenum(symbol) then
line_marker;
writeln(log, "GOSUB " <& symbol);
set_return_position(line);
goto_label_or_linenum(symbol);
set_sub_entry_position;
symbol := "";
line := "";
elsif symbol in multipleDefinedLabel then
error_marker;
writeln(err, "GOSUB TO MULTIPLE DEFINED LABEL " <& symbol <& ".");
symbol := get_symbol(line);
else
index1 := round(exec_expr(symbol, line));
expect("OF", symbol, line);
if index1 >= 1 then
index2 := 1;
while index2 < index1 do
symbol := get_symbol(line);
if symbol = "," then
symbol := get_symbol(line);
incr(index2);
else
index2 := succ(index1);
end if;
end while;
if index2 = index1 then
if label_or_linenum(symbol) then
line_marker;
writeln(log, "GOSUB " <& index1 <& " OF " <& symbol);
advance_after_statement(line);
set_return_position(line);
goto_label_or_linenum(symbol);
set_sub_entry_position;
symbol := "";
line := "";
else
error_marker;
writeln(err, "UNDEFINED LABEL " <& symbol <& " AFTER \"OF\".");
end if;
else
line_marker;
writeln(log, "GOSUB " <& index1 <& " OF NEXT STATEMENT");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end if;
else
line_marker;
writeln(log, "GOSUB " <& index1 <& " OF NEXT STATEMENT");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end if;
end if;
end func;
const proc: exec_let (in var string: variable_name,
inout string: symbol, inout string: line) is func
local
var string: param1 is "";
var float: num1 is 0.0;
var string: unused_name is "";
begin
if isStringVar(variable_name) then
append_index(variable_name, symbol, line);
if symbol = "=" then
symbol := get_symbol(line);
param1 := exec_str_expr(symbol, line, unused_name);
setStringVar(variable_name, param1);
line_marker;
writeln(log, "LET " <& variable_name <& "=" <& literal(param1));
else
error_marker;
writeln(err, "\"=\" EXPECTED AFTER " <& literal(variable_name) <&
" - FOUND " <& literal(symbol) <& ".");
end if;
elsif isNumericVar(variable_name) then
append_index(variable_name, symbol, line);
if symbol = "=" then
symbol := get_symbol(line);
num1 := exec_expr(symbol, line);
setNumericVar(variable_name, num1);
line_marker;
writeln(log, "LET " <& variable_name <& "=" <& num1);
else
error_marker;
writeln(err, "\"=\" EXPECTED AFTER " <& literal(variable_name) <&
" - FOUND " <& literal(symbol) <& ".");
end if;
else
error_marker;
writeln(err, "VARIABLE EXPECTED - FOUND " <& literal(variable_name) <& ".");
end if;
end func;
const proc: exec_mid_statement (inout string: symbol, inout string: line) is func
local
var string: variable_name is "";
var string: unused_name is "";
var string: var_value is "";
var string: stri is "";
var integer: position is 0;
var integer: length is 0;
var integer: requested_length is 0;
var boolean: with_length is FALSE;
begin
symbol := get_symbol(line);
expect("(", symbol, line);
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
expect(",", symbol, line);
position := round(exec_expr(symbol, line));
if symbol = "," then
with_length := TRUE;
symbol := get_symbol(line);
requested_length := round(exec_expr(symbol, line));
length := requested_length;
expect(")", symbol, line);
expect("=", symbol, line);
stri := exec_str_expr(symbol, line, unused_name);
if length > length(stri) then
length := length(stri);
end if;
else
expect(")", symbol, line);
expect("=", symbol, line);
stri := exec_str_expr(symbol, line, unused_name);
length := length(stri);
end if;
var_value := getStringVar(variable_name);
if position <= length(var_value) then
if succ(length(var_value) - position) < length then
length := succ(length(var_value) - position);
end if;
var_value := var_value[ .. pred(position)] & stri[ .. length] &
var_value[position + length ..];
setStringVar(variable_name, var_value);
write(log, "MID$(" <& variable_name <& ", " <& position);
if with_length then
write(log, ", " <& requested_length);
end if;
writeln(log, ")=" <& literal(stri));
else
error_marker;
writeln(err, "MID$ POSITION " <& position <&
" LARGER THAN LENGTH OF " <& literal(var_value));
end if;
else
error_marker;
writeln(err, "STRING VARIABLE EXPECTED - FOUND " <& literal(symbol));
end if;
end func;
const proc: exec_next_decision (inout string: symbol, inout string: line,
val string: variable_name, in string: nameList) is func
local
var float: num1 is 0.0;
begin
if length(forLoop) >= 1 and variable_name = forLoop[1].varName then
num1 := getNumericVar(variable_name);
if (forLoop[1].stepValue > 0.0 and num1 + forLoop[1].stepValue <= forLoop[1].endValue) or
(forLoop[1].stepValue < 0.0 and num1 + forLoop[1].stepValue >= forLoop[1].endValue) then
line_marker;
setNumericVar(variable_name, num1 + forLoop[1].stepValue);
file_line_number := forLoop[1].bodyLine;
statement_label := prg[file_line_number].linenum;
line := prg[file_line_number].line[forLoop[1].bodyColumn .. ];
if line <> "" then
symbol := ":";
else
symbol := "";
end if;
write(log, "NEXT " <& variable_name <& " = " <& num1 + forLoop[1].stepValue <&
" CONTINUE THE \"FOR " <& variable_name <& "\" LOOP AT LINE ");
line_marker;
writeln(log);
else
line_marker;
writeln(log, "NEXT " <& variable_name <& " = " <& num1 <& " END FOR");
forLoop := forLoop[2 .. ];
if length(forLoop) >= 1 and forLoop[1].varName <> variable_name and
nameInList(forLoop[1].varName, nameList) then
line_marker;
write(log, "THE \"FOR " <& forLoop[1].varName <&
"\" LOOP AT LINE ");
line_marker(forLoop[1].bodyLine);
writeln(log, " IS ALSO HANDLED WITH THIS NEXT STATEMENT");
exec_next_decision(symbol, line, forLoop[1].varName,
removeNameFromList(variable_name, nameList));
end if;
end if;
else
error_marker;
writeln(err, "\"NEXT " <& forLoop[1].varName <&
"\" EXPECTED - FOUND \"NEXT " <& variable_name <& "\"");
end if;
end func;
const proc: exec_if (inout string: symbol, inout string: line,
inout boolean: process_next) is func
local
var string: param1 is "";
var float: num1 is 0.0;
begin
symbol := get_symbol(line);
num1 := exec_expr(symbol, line);
if startsWith(symbol, "THEN") then
line := symbol[5 ..] & line;
symbol := "THEN";
elsif startsWith(symbol, "GOTO") then
line := symbol[5 ..] & line;
symbol := "GOTO";
elsif startsWith(symbol, "GOSUB") then
line := symbol[6 ..] & line;
symbol := "GOSUB";
end if;
if num1 <> 0.0 then
if symbol = "THEN" then
line_marker;
write(log, "IF " <& num1);
symbol := get_symbol(line);
if symbol = "" or symbol = "'" or symbol = "REM" then
writeln(log, " THEN - EXECUTE STATEMENT BLOCK");
elsif label_or_linenum(symbol) then
param1 := symbol;
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
writeln(log, " THEN - EXECUTE STATEMENTS IN LINE UNTIL \"ELSE\"");
exec_let(param1, symbol, line);
else
writeln(log, " THEN " <& param1 <& " - GOTO LINE");
goto_label_or_linenum(param1);
symbol := "";
line := "";
end if;
else
writeln(log, " THEN - EXECUTE STATEMENTS IN LINE UNTIL \"ELSE\"");
process_next := TRUE;
end if;
elsif symbol = "GOTO" then
symbol := get_symbol(line);
line_marker;
writeln(log, "IF " <& num1 <& " GOTO " <& symbol <& " - GOTO LINE");
if label_or_linenum(symbol) then
goto_label_or_linenum(symbol);
symbol := "";
line := "";
else
error_marker;
writeln(err, "UNDEFINED LABEL " <& symbol <& " AFTER \"GOTO\".");
end if;
elsif symbol = "GOSUB" then
symbol := get_symbol(line);
line_marker;
writeln(log, "IF " <& num1 <& " GOSUB " <& symbol <& " - GOSUB LINE");
if label_or_linenum(symbol) then
set_return_position(line);
goto_label_or_linenum(symbol);
set_sub_entry_position;
symbol := "";
line := "";
else
error_marker;
writeln(err, "UNDEFINED LABEL " <& symbol <& " AFTER \"GOSUB\".");
end if;
else
error_expect3("THEN", "GOTO", "GOSUB", symbol);
end if;
else
if symbol = "THEN" or symbol = "GOTO" or symbol = "GOSUB" then
symbol := get_symbol(line);
else
error_expect3("THEN", "GOTO", "GOSUB", symbol);
end if;
line_marker;
write(log, "IF " <& num1);
if symbol = "" or symbol = "'" or symbol = "REM" then
writeln(log, " THEN - SKIP STATEMENT BLOCK");
exec_elseif_else_chain(symbol, line, process_next);
elsif label_or_linenum(symbol) then
writeln(log, " THEN " <& symbol <& " - SKIP LABEL");
symbol := get_symbol(line);
if startsWith(symbol, "ELSE") and not is_let_statement(line) then
line := symbol[5 ..] & line;
symbol := "ELSE";
end if;
if symbol = "ELSE" then
symbol := get_symbol(line);
if label_or_linenum(symbol) then
line_marker;
writeln(log, "ELSE " <& symbol <& " - GOTO LINE");
goto_label_or_linenum(symbol);
symbol := "";
line := "";
else
line_marker;
writeln(log, "ELSE - EXECUTE STATEMENTS IN LINE");
process_next := TRUE;
end if;
elsif symbol = ":" then
symbol := get_symbol(line);
if startsWith(symbol, "ELSE") and not is_let_statement(line) then
line := symbol[5 ..] & line;
symbol := "ELSE";
end if;
if symbol = "ELSE" then
symbol := get_symbol(line);
if label_or_linenum(symbol) then
line_marker;
writeln(log, "ELSE " <& symbol <& " - GOTO LINE");
goto_label_or_linenum(symbol);
symbol := "";
line := "";
else
line_marker;
writeln(log, "ELSE - EXECUTE STATEMENTS IN LINE");
process_next := TRUE;
end if;
else
line_marker;
writeln(log, "NO ELSE - CONTINUE AFTER THE LABEL");
process_next := TRUE;
end if;
else
line_marker;
writeln(log, "NO ELSE - CONTINUE AT NEXT LINE");
symbol := "";
line := "";
end if;
else
writeln(log, " THEN - SKIP STATEMENTS IN LINE UNTIL \"ELSE\"");
find_else(symbol, line);
if symbol = "ELSE" then
symbol := get_symbol(line);
if label_or_linenum(symbol) then
line_marker;
writeln(log, "ELSE " <& symbol <& " - GOTO LINE");
goto_label_or_linenum(symbol);
symbol := "";
line := "";
else
line_marker;
writeln(log, "ELSE - EXECUTE STATEMENTS IN LINE");
process_next := TRUE;
end if;
else
line_marker;
writeln(log, "NO ELSE - CONTINUE AT NEXT LINE");
symbol := "";
line := "";
end if;
end if;
end if;
end func;
const proc: exec_else (inout string: symbol, inout string: line) is func
begin
line_marker;
writeln(log, "ELSE - THE \"THEN\" BLOCK BEFORE WAS EXECUTED");
if upper(prg[file_line_number].line[.. 4]) = "ELSE" then
symbol := find_end_if(line);
if symbol = "IF" then
symbol := get_symbol(line);
line_marker;
writeln(log, "END IF");
else
error_marker;
writeln(err, "ELSE - MISSING \"END IF\".");
end if;
else
line := "";
symbol := "";
line_marker;
writeln(log, "SKIP ELSE PART - CONTINUE AT NEXT LINE");
end if;
end func;
const proc: exec_for (inout string: symbol, inout string: line) is func
local
var string: variable_name is "";
var float: num1 is 0.0;
var float: num2 is 0.0;
var float: num3 is 0.0;
var integer: index1 is 0;
var string: label is "";
begin
variable_name := get_symbol(line);
symbol := get_symbol(line);
expect("=", symbol, line);
num1 := exec_expr(symbol, line);
setNumericVar(variable_name, num1);
if symbol = "TO" then
symbol := get_symbol(line);
elsif startsWith(symbol, "TO") then
line := symbol[3 ..] & line;
symbol := get_symbol(line);
else
error_expect("TO", symbol);
end if;
num2 := exec_expr(symbol, line);
if symbol = "STEP" then
symbol := get_symbol(line);
num3 := exec_expr(symbol, line);
elsif startsWith(symbol, "STEP") then
line := symbol[5 ..] & line;
symbol := get_symbol(line);
num3 := exec_expr(symbol, line);
else
num3 := 1.0;
end if;
if (num3 > 0.0 and num1 <= num2) or
(num3 < 0.0 and num1 >= num2) then
if symbol = "'" or symbol = "REM" then
index1 := succ(length(prg[file_line_number].line));
else
index1 := length(prg[file_line_number].line) - length(line) + 1;
end if;
forLoop := [] (forLoopDescrType.value) & forLoop;
forLoop[1].varName := variable_name;
forLoop[1].endValue := num2;
forLoop[1].stepValue := num3;
forLoop[1].bodyLine := file_line_number;
forLoop[1].bodyColumn := index1;
line_marker;
writeln(log, "FOR " <& variable_name <& "=" <& num1 <&
" TO " <& num2 <& " STEP " <& num3);
else
line_marker;
writeln(log, "EMPTY FOR " <& variable_name <& "=" <& num1 <&
" TO " <& num2 <& " STEP " <& num3);
label := statement_label;
if not find_next(symbol, line, variable_name) then
error_marker(label);
writeln(err, "NO CORRESPONDING \"NEXT\" OR \"NEXT " <& variable_name <&
"\" FOUND FOR \"FOR " <& variable_name <& "\"");
end if;
end if;
end func;
const proc: exec_next (inout string: symbol, inout string: line) is func
local
var string: variable_name is "";
var string: param1 is "";
var integer: index1 is 0;
var integer: index2 is 0;
begin
if length(forLoop) >= 1 then
symbol := get_symbol(line);
if endOfStatement(symbol) then
param1 := "";
variable_name := forLoop[1].varName;
else
param1 := getNameList(symbol, line);
if nameInList(forLoop[1].varName, param1) then
variable_name := forLoop[1].varName;
else
index1 := 2;
while index1 <= length(forLoop) and not nameInList(forLoop[index1].varName, param1) do
incr(index1)
end while;
if index1 <= length(forLoop) and nameInList(forLoop[index1].varName, param1) then
for index2 range 1 to pred(index1) do
line_marker;
write(log, "THE \"FOR " <& forLoop[index2].varName <& "\" LOOP AT LINE ");
line_marker(forLoop[index2].bodyLine);
writeln(log, " SEEMS TO HAVE BEEN LEFT");
end for;
forLoop := forLoop[index1 .. ];
variable_name := forLoop[1].varName;
elsif on_error_label <> "" then
error_code := 1;
line_marker;
writeln(log, error_code <& " NEXT WITHOUT FOR" <&
" - ON ERROR GOTO " <& on_error_label);
goto_on_error(on_error_label, line);
symbol := "";
line := "";
variable_name := "";
else
error_marker;
writeln(err, "NEXT " <& param1 <& " - NO MATCHING FOR FOUND");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
variable_name := param1;
end if;
end if;
end if;
exec_next_decision(symbol, line, variable_name, param1);
elsif on_error_label <> "" then
error_code := 1;
line_marker;
writeln(log, error_code <& " NEXT " <& variable_name <& " WITHOUT FOR" <&
" - ON ERROR GOTO " <& on_error_label);
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "NEXT " <& variable_name <& " WITHOUT FOR");
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
end if;
end func;
const proc: exec_on (inout string: symbol, inout string: line) is func
local
var string: param1 is "";
var integer: index1 is 0;
var integer: index2 is 0;
var integer: keywordPos is 0;
begin
symbol := get_symbol(line);
if symbol = "ERROR" then
symbol := get_symbol(line);
expect("GOTO", symbol, line);
if symbol = "0" then
on_error_label := "";
line_marker;
writeln(log, "ON ERROR GOTO 0 - DISABLE ERROR HANDLING");
symbol := get_symbol(line);
elsif label_or_linenum(symbol) then
on_error_label := symbol;
line_marker;
writeln(log, "ON ERROR GOTO " <& literal(symbol) <&
" LINE: " <& label[symbol]);
symbol := get_symbol(line);
else
error_marker;
writeln(err, "ON ERROR GOTO NEEDS A LABEL NOT " <& literal(symbol) <& ".");
end if;
elsif symbol = "KEY" then
line_marker;
writeln(log, "**ON KEY " <& line);
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
elsif symbol = "TIMER" then
line_marker;
writeln(log, "**ON TIMER " <& line);
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
else
if symbol not in numeric_var and symbol not in def_fn_list and
symbol not in subfunction then
keywordPos := pos(symbol, "GOTO");
if keywordPos <> 0 then
line := symbol[keywordPos ..] & line;
symbol := symbol[.. pred(keywordPos)];
else
keywordPos := pos(symbol, "GOSUB");
if keywordPos <> 0 then
line := symbol[keywordPos ..] & line;
symbol := symbol[.. pred(keywordPos)];
end if;
end if;
end if;
index1 := round(exec_expr(symbol, line));
if startsWith(symbol, "GOTO") then
line := symbol[5 ..] & line;
symbol := "GOTO";
elsif startsWith(symbol, "GOSUB") then
line := symbol[6 ..] & line;
symbol := "GOSUB";
end if;
if symbol = "GOTO" or symbol = "GOSUB" then
param1 := symbol;
symbol := get_symbol(line);
if index1 >= 1 then
index2 := 1;
while index2 < index1 do
symbol := get_symbol(line);
if symbol = "," then
symbol := get_symbol(line);
incr(index2);
else
index2 := succ(index1);
end if;
end while;
if index2 = index1 then
if label_or_linenum(symbol) then
line_marker;
writeln(log, "ON " <& index1 <& " " <& param1 <& " " <& symbol);
if param1 = "GOSUB" then
advance_after_statement(line);
set_return_position(line);
goto_label_or_linenum(symbol);
set_sub_entry_position;
else
goto_label_or_linenum(symbol);
end if;
symbol := "";
line := "";
else
error_marker;
writeln(err, "UNDEFINED LABEL " <& symbol <& " AFTER \"" <&
"ON " <& index1 <& " " <& param1 <& "\".");
end if;
else
line_marker;
writeln(log, "ON " <& index1 <& " GOTO NEXT STATEMENT");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end if;
else
line_marker;
writeln(log, "ON " <& index1 <& " GOTO NEXT STATEMENT");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end if;
else
error_expect2("GOTO", "GOSUB", symbol);
end if;
end if;
end func;
const proc: exec_do (inout string: symbol, inout string: line) is func
local
var float: num1 is 0.0;
var string: headLabel is "";
var integer: headLine is 0;
var integer: headColumn is 0;
begin
headLine := file_line_number;
headColumn := length(prg[file_line_number].line) - length(line) + 1;
symbol := get_symbol(line);
if symbol = "WHILE" then
symbol := get_symbol(line);
num1 := exec_expr(symbol, line);
line_marker;
writeln(log, "DO WHILE " <& num1);
if num1 <> 0.0 then
doLoop := [] (doLoopDescrType.value) & doLoop;
doLoop[1].headLine := headLine;
doLoop[1].headColumn := headColumn;
else
line_marker;
writeln(log, "EMPTY \"DO WHILE\"");
if symbol <> "LOOP" then
headLabel := statement_label;
symbol := find_loop(line);
end if;
if symbol = "LOOP" then
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
line_marker;
writeln(log, "CONTINUE AFTER \"DO WHILE ... LOOP\"");
else
error_marker(headLabel);
writeln(err, "NO CORRESPONDING \"LOOP\" FOUND FOR \"DO WHILE\"");
end if;
end if;
elsif symbol = "UNTIL" then
symbol := get_symbol(line);
num1 := exec_expr(symbol, line);
line_marker;
writeln(log, "DO UNTIL " <& num1);
if num1 = 0.0 then
doLoop := [] (doLoopDescrType.value) & doLoop;
doLoop[1].headLine := headLine;
doLoop[1].headColumn := headColumn;
else
line_marker;
writeln(log, "EMPTY \"DO UNTIL\"");
if symbol <> "LOOP" then
headLabel := statement_label;
symbol := find_loop(line);
end if;
if symbol = "LOOP" then
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
line_marker;
writeln(log, "CONTINUE AFTER \"DO UNTIL ... LOOP\n");
else
error_marker(headLabel);
writeln(err, "NO CORRESPONDING \"LOOP\" FOUND FOR \"DO UNTIL\"");
end if;
end if;
elsif symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("DO", symbol, line);
else
line_marker;
writeln(log, "DO ... LOOP");
doLoop := [] (doLoopDescrType.value) & doLoop;
doLoop[1].headLine := headLine;
doLoop[1].headColumn := headColumn;
end if;
end func;
const proc: exec_loop (inout string: symbol, inout string: line) is func
local
var string: param1 is "";
var string: param2 is "";
var float: num1 is 0.0;
var integer: headLine is 0;
var integer: headColumn is 0;
var integer: tailLine is 0;
var integer: tailColumn is 0;
begin
tailLine := file_line_number;
tailColumn := length(prg[file_line_number].line) - length(line) + 1;
if doLoopHeaderPresent(tailLine, tailColumn, headLine, headColumn) then
if length(doLoop) >= 1 then
if doLoop[1].headLine <> headLine or
doLoop[1].headColumn <> headColumn then
error_marker;
writeln(err, "LOOP - \"DO\" LOOP ENTERED BY A GOTO");
doLoop := [] (doLoopDescrType.value) & doLoop;
doLoop[1].headLine := headLine;
doLoop[1].headColumn := headColumn;
end if;
else
error_marker;
writeln(err, "LOOP - \"DO\" LOOP ENTERED BY A GOTO");
doLoop := [] (doLoopDescrType.value) & doLoop;
doLoop[1].headLine := headLine;
doLoop[1].headColumn := headColumn;
end if;
else
error_marker;
writeln(err, "LOOP - NO STATICALLY CORRESPONDING \"DO\" STATEMENT FOUND");
end if;
symbol := get_symbol(line);
if symbol = "WHILE" then
symbol := get_symbol(line);
if length(doLoop) >= 1 then
num1 := exec_expr(symbol, line);
if num1 <> 0.0 then
line_marker;
file_line_number := doLoop[1].headLine;
statement_label := prg[file_line_number].linenum;
line := prg[file_line_number].line[doLoop[1].headColumn .. ];
symbol := get_symbol(line);
if symbol <> "WHILE" and symbol <> "UNTIL" then
writeln(log, "LOOP - CONTINUE \"DO ... LOOP WHILE\"");
else
error_marker;
writeln(err, "ILLEGAL - \"DO " <& symbol <& " ... LOOP WHILE\"");
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
end if;
else
doLoop := doLoop[2 .. ];
line_marker;
writeln(log, "LOOP - LEAVE \"DO ... LOOP WHILE\"");
end if;
else
error_marker;
writeln(err, "UNEXPECTED \"LOOP WHILE\"");
end if;
elsif symbol = "UNTIL" then
symbol := get_symbol(line);
if length(doLoop) >= 1 then
num1 := exec_expr(symbol, line);
if num1 = 0.0 then
line_marker;
file_line_number := doLoop[1].headLine;
statement_label := prg[file_line_number].linenum;
line := prg[file_line_number].line[doLoop[1].headColumn .. ];
symbol := get_symbol(line);
if symbol <> "WHILE" and symbol <> "UNTIL" then
writeln(log, "LOOP - CONTINUE \"DO ... LOOP UNTIL\"");
else
error_marker;
writeln(err, "ILLEGAL - \"DO " <& symbol <& " .. LOOP UNTIL\"");
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
end if;
else
doLoop := doLoop[2 .. ];
line_marker;
writeln(log, "LOOP - LEAVE \"DO ... LOOP UNTIL\"");
end if;
else
error_marker;
writeln(err, "UNEXPECTED \"LOOP UNTIL\"");
end if;
else
if length(doLoop) >= 1 then
headLine := doLoop[1].headLine;
param2 := prg[headLine].line[doLoop[1].headColumn .. ];
param1 := get_symbol(param2);
if param1 = "WHILE" then
param1 := get_symbol(param2);
num1 := exec_expr(param1, param2);
if num1 <> 0.0 then
line_marker;
file_line_number := headLine;
statement_label := prg[file_line_number].linenum;
symbol := param1;
line := param2;
writeln(log, "LOOP - CONTINUE \"DO WHILE ... LOOP\"");
else
doLoop := doLoop[2 .. ];
line_marker;
writeln(log, "LOOP - LEAVE \"DO WHILE ... LOOP\"");
end if;
elsif param1 = "UNTIL" then
param1 := get_symbol(param2);
num1 := exec_expr(param1, param2);
if num1 = 0.0 then
line_marker;
file_line_number := headLine;
statement_label := prg[file_line_number].linenum;
symbol := param1;
line := param2;
writeln(log, "LOOP - CONTINUE \"DO UNTIL ... LOOP\"");
else
doLoop := doLoop[2 .. ];
line_marker;
writeln(log, "LOOP - LEAVE \"DO UNTIL ... LOOP\"");
end if;
else
line_marker;
file_line_number := headLine;
statement_label := prg[file_line_number].linenum;
symbol := param1;
line := param2;
writeln(log, "LOOP - CONTINUE \"DO ... LOOP\"");
end if;
else
error_marker;
writeln(err, "UNEXPECTED \"LOOP UNTIL\"");
end if;
end if;
end func;
const proc: exec_select (inout string: symbol, inout string: line) is func
local
var string: unused_name is "";
var string: param1 is "";
var string: param2 is "";
var string: param3 is "";
var float: num1 is 0.0;
var float: num2 is 0.0;
var float: num3 is 0.0;
var boolean: found is FALSE;
var boolean: end_select is FALSE;
var boolean: end_case is FALSE;
var string: comparison is "";
begin
symbol := get_symbol(line);
if symbol = "CASE" then
symbol := get_symbol(line);
if isStringExpr(symbol) then
param1 := exec_str_expr(symbol, line, unused_name);
line_marker;
writeln(log, "SELECT CASE " <& literal(param1));
repeat
if ignoreRestOfLine(symbol) then
line := "";
end if;
symbol := find_case_or_end_select(line);
if symbol = "CASE" then
symbol := get_symbol(line);
if symbol = "ELSE" then
symbol := get_symbol(line);
found := TRUE;
line_marker;
writeln(log, "CASE ELSE - FOUND");
else
end_case := FALSE;
repeat
if symbol = "IS" then
symbol := get_symbol(line);
end if;
if symbol = "=" or symbol = "<>" or
symbol = "<" or symbol = ">" or
symbol = "<=" or symbol = ">=" then
comparison := symbol;
symbol := get_symbol(line);
else
comparison := "=";
end if;
param2 := exec_str_expr(symbol, line, unused_name);
if symbol = "TO" then
symbol := get_symbol(line);
param3 := exec_str_expr(symbol, line, unused_name);
line_marker;
write(log, "CASE " <& literal(param2) <& " TO " <&
literal(param3));
if param1 >= param2 and param1 <= param3 then
found := TRUE;
write(log, " - FOUND");
end if;
writeln(log);
else
if comparison = "=" then
found := param1 = param2;
elsif comparison = "<>" then
found := param1 <> param2;
elsif comparison = "<" then
found := param1 < param2;
elsif comparison = ">" then
found := param1 > param2;
elsif comparison = "<=" then
found := param1 <= param2;
elsif comparison = ">=" then
found := param1 >= param2;
end if;
line_marker;
write(log, "CASE IS " <& comparison <& " " <&
literal(param2));
if found then
write(log, " - FOUND");
end if;
writeln(log);
end if;
if symbol = "," then
symbol := get_symbol(line);
else
end_case := TRUE;
end if;
until found or end_case;
end if;
else
end_select := TRUE;
end if;
until found or end_select;
if not found then
line_marker;
writeln(log, "END SELECT - NO CASE FOUND FOR " <& literal(param1));
end if;
else
num1 := exec_expr(symbol, line);
line_marker;
writeln(log, "SELECT CASE " <& num1);
repeat
if ignoreRestOfLine(symbol) then
line := "";
end if;
symbol := find_case_or_end_select(line);
if symbol = "CASE" then
symbol := get_symbol(line);
if symbol = "ELSE" then
symbol := get_symbol(line);
found := TRUE;
line_marker;
writeln(log, "CASE ELSE - FOUND");
else
end_case := FALSE;
repeat
if symbol = "IS" then
symbol := get_symbol(line);
end if;
if symbol = "=" or symbol = "<>" or
symbol = "<" or symbol = ">" or
symbol = "<=" or symbol = ">=" then
comparison := symbol;
symbol := get_symbol(line);
else
comparison := "=";
end if;
num2 := exec_expr(symbol, line);
if symbol = "TO" then
symbol := get_symbol(line);
num3 := exec_expr(symbol, line);
line_marker;
write(log, "CASE " <& num2 <& " TO " <& num3);
if num1 >= num2 and num1 <= num3 then
found := TRUE;
write(log, " - FOUND");
end if;
writeln(log);
else
if comparison = "=" then
found := num1 = num2;
elsif comparison = "<>" then
found := num1 <> num2;
elsif comparison = "<" then
found := num1 < num2;
elsif comparison = ">" then
found := num1 > num2;
elsif comparison = "<=" then
found := num1 <= num2;
elsif comparison = ">=" then
found := num1 >= num2;
end if;
line_marker;
write(log, "CASE IS " <& comparison <& " " <& num2);
if found then
write(log, " - FOUND");
end if;
writeln(log);
end if;
if symbol = "," then
symbol := get_symbol(line);
else
end_case := TRUE;
end if;
until found or end_case;
end if;
else
end_select := TRUE;
end if;
until found or end_select;
if not found then
line_marker;
writeln(log, "END SELECT - NO CASE FOUND FOR " <& num1);
end if;
end if;
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
else
error_marker;
writeln(err, "\"CASE\" EXPECTED AFTER \"SELECT\"");
end if;
end func;
const func boolean: continueWithPrintStatement (in var string: line) is func
result
var boolean: continueWithPrintStatement is FALSE;
local
var string: symbol is "";
begin
repeat
symbol := get_symbol(line);
until symbol <> ":";
if symbol = "" or symbol[1] = '\"' or symbol = "TAB" then
continueWithPrintStatement := TRUE;
end if;
end func;
const proc: exec_print_using (inout file: outFile,
inout string: symbol, inout string: line) is func
local
var string: unused_name is "";
var string: param1 is "";
var string: param2 is "";
var float: num1 is 0.0;
var integer: index1 is 0;
var integer: index2 is 0;
var integer: index3 is 0;
var integer: index4 is 0;
var char: ch1 is ' ';
var char: ch2 is ' ';
var integer: implicit_semicolon_pos is -1;
begin
write(log, "USING ");
symbol := get_symbol(line);
if isStringExpr(symbol) then
param1 := exec_str_expr(symbol, line, unused_name);
writeln(log, literal(param1));
expect(";", symbol, line);
repeat
index1 := 1;
while index1 <= length(param1) do
ch1 := param1[index1];
case ch1 of
when {'!', '\\', '&'}:
if symbol = ";" or symbol = "," then
symbol := get_symbol(line);
end if;
if isStringExpr(symbol) then
param2 := exec_str_expr(symbol, line, unused_name);
if ch1 = '!' then
param2 := param2[1 len 1] rpad 1;
write(outFile, param2);
write(log, " " <& literal(param2));
elsif ch1 = '\\' then
index2 := index1;
repeat
incr(index1);
if index1 <= length(param1) then
ch1 := param1[index1];
else
ch1 := '\0;';
end if;
until ch1 <> ' ';
if ch1 = '\\' then
param2 := param2[1 len succ(index1 - index2)] rpad succ(index1 - index2);
write(outFile, param2);
write(log, " " <& literal(param2));
else
error_marker;
writeln(err, "'\\' - FOUND " <& literal(ch1) <& ".");
end if;
elsif ch1 = '&' then
write(outFile, param2);
write(log, " " <& literal(param2));
end if;
else
error_marker;
writeln(err, "STRING EXPECTED - FOUND " <& symbol <& ".");
end if;
when {'#', '+', '.'}:
if index1 < length(param1) then
ch2 := param1[succ(index1)];
else
ch2 := '\0;';
end if;
if ch1 = '#' or
ch1 = '+' and ch2 in {'#', '.'} or
ch1 = '.' and ch2 = '#' then
if symbol = ";" or symbol = "," then
symbol := get_symbol(line);
end if;
num1 := exec_expr(symbol, line);
if ch1 = '+' then
if num1 >= 0.0 then
write(outFile, '+');
write(log, '+');
end if;
ch1 := ch2;
incr(index1);
end if;
index2 := index1;
index3 := 0;
index4 := 0;
while ch1 = '#' do
incr(index2);
incr(index3);
if index2 <= length(param1) then
ch1 := param1[index2];
else
ch1 := '\0;';
end if;
if index2 < length(param1) then
ch2 := param1[succ(index2)];
else
ch2 := '\0;';
end if;
if ch1 = ',' and ch2 = '#' then
ch1 := ch2;
incr(index2);
end if;
end while;
if ch1 = '.' then
incr(index2);
if index2 <= length(param1) then
ch1 := param1[index2];
else
ch1 := '\0;';
end if;
while ch1 = '#' do
incr(index2);
incr(index4);
if index2 <= length(param1) then
ch1 := param1[index2];
else
ch1 := '\0;';
end if;
if index2 < length(param1) then
ch2 := param1[succ(index2)];
else
ch2 := '\0;';
end if;
if ch1 = ',' and ch2 = '#' then
ch1 := ch2;
incr(index2);
end if;
end while;
end if;
if index4 = 0 then
param2 := num1 digits 0 lpad index3;
else
param2 := num1 digits index4 lpad index3 + index4 + 1;
end if;
write(log, num1 <& " " <& "#" mult index3 <& "." <&
"#" mult index4 <& " " <& literal(param2));
index3 := 1;
while index1 < index2 do
if index1 <= length(param1) then
ch1 := param1[index1];
else
ch1 := '\0;';
end if;
ch2 := param2[index3];
if ch1 = ',' then
if index3 >= 2 and param2[pred(index3)] in digit_char then
param2 := param2[.. pred(index3)] & "," & param2[index3 ..];
else
param2 := param2[.. pred(index3)] & " " & param2[index3 ..];
end if;
end if;
incr(index1);
incr(index3);
end while;
write(outFile, param2);
write(log, " " <& literal(param2));
index1 := pred(index2);
else
write(outFile, ch1);
write(log, ch1);
end if;
when {'*'}:
noop;
when {'$'}:
noop;
when {'_'}:
incr(index1);
if index1 <= length(param1) then
ch1 := param1[index1];
write(outFile, ch1);
write(log, ch1);
end if;
otherwise:
write(outFile, ch1);
write(log, ch1);
end case;
incr(index1);
end while;
if endOfStatement(symbol) then
writeln(outFile);
if symbol = ":" then
if continueWithPrintStatement(line) then
symbol := get_symbol(line);
write(log, ":");
while symbol = ":" do
writeln(win);
symbol := get_symbol(line);
write(log, ":");
end while;
else
symbol := ":";
end if;
end if;
elsif symbol = ";" then
symbol := get_symbol(line);
elsif symbol = "," then
symbol := get_symbol(line);
else
if implicit_semicolon_pos <> length(line) then
implicit_semicolon_pos := length(line);
write(log, " (;) ");
else
writeln(log);
error_marker;
writeln(err, "IGNORE " <& literal(symbol));
symbol := get_symbol(line);
end if;
end if;
until endOfStatement(symbol);
writeln(log);
end if;
end func;
const proc: exec_print (inout string: symbol, inout string: line) is func
local
var string: unused_name is "";
var string: param1 is "";
var float: num1 is 0.0;
var integer: implicit_semicolon_pos is -1;
begin
line_marker;
write(log, "PRINT ");
repeat
if isStringExpr(symbol) then
param1 := exec_str_expr(symbol, line, unused_name);
write(win, param1);
write(log, literal(param1));
elsif symbol = "TAB" then
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
if column(win) < round(num1) then
write(win, "" rpad round(num1) - column(win));
end if;
write(log, "TAB(" <& round(num1) <& ")");
elsif symbol = "SPC" then
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
write(win, "" rpad round(num1));
write(log, "SPC(" <& round(num1) <& ")");
elsif symbol = "USING" then
exec_print_using(win, symbol, line);
elsif symbol <> ";" and symbol <> "," and not endOfStatement(symbol) then
write(win, " ");
write(log, " ");
num1 := exec_expr(symbol, line);
param1 := str(num1);
if param1[length(param1) - 1 .. ] = ".0" then
param1 := param1[ .. length(param1) - 2];
end if;
write(win, param1);
write(log, num1);
if not endOfStatement(symbol) then
write(win, " ");
write(log, " ");
end if;
end if;
if endOfStatement(symbol) then
writeln(win);
if symbol = ":" then
if continueWithPrintStatement(line) then
symbol := get_symbol(line);
write(log, ":");
while symbol = ":" do
writeln(win);
symbol := get_symbol(line);
write(log, ":");
end while;
else
symbol := ":";
end if;
end if;
elsif symbol = ";" then
symbol := get_symbol(line);
write(log, "; ");
elsif symbol = "," then
symbol := get_symbol(line);
write(win, "" rpad 15 - column(win) rem 14);
write(log, ", ");
else
if implicit_semicolon_pos <> length(line) then
implicit_semicolon_pos := length(line);
write(log, " (;) ");
else
writeln(log);
error_marker;
writeln(err, "IGNORE " <& literal(symbol));
symbol := get_symbol(line);
end if;
end if;
until endOfStatement(symbol);
flush(win);
writeln(log);
end func;
const proc: exec_print (inout file: outFile,
inout string: symbol, inout string: line) is func
local
var string: unused_name is "";
var string: param1 is "";
var float: num1 is 0.0;
var integer: implicit_semicolon_pos is -1;
begin
if endOfStatement(symbol) then
writeln(outFile);
else
repeat
if isStringExpr(symbol) then
param1 := exec_str_expr(symbol, line, unused_name);
write(outFile, param1);
write(log, literal(param1));
elsif symbol = "TAB" then
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
write(outFile, " ");
write(log, "TAB(" <& round(num1) <& ")");
elsif symbol = "SPC" then
symbol := get_symbol(line);
expect("(", symbol, line);
num1 := exec_expr(symbol, line);
expect(")", symbol, line);
write(outFile, "" rpad round(num1));
write(log, "SPC(" <& round(num1) <& ")");
else
write(outFile, " ");
write(log, " ");
num1 := exec_expr(symbol, line);
param1 := str(num1);
if param1[length(param1) - 1 .. ] = ".0" then
param1 := param1[ .. length(param1) - 2];
end if;
write(outFile, param1);
write(log, num1);
if not endOfStatement(symbol) then
write(outFile, " ");
write(log, " ");
end if;
end if;
if endOfStatement(symbol) then
writeln(outFile);
elsif symbol = ";" then
symbol := get_symbol(line);
write(log, "; ");
elsif symbol = "," then
symbol := get_symbol(line);
write(outFile, " ");
write(log, ", ");
else
if implicit_semicolon_pos <> length(line) then
implicit_semicolon_pos := length(line);
write(log, " (;) ");
else
writeln(log);
error_marker;
writeln(err, "IGNORE " <& literal(symbol));
symbol := get_symbol(line);
end if;
end if;
until endOfStatement(symbol);
end if;
flush(outFile);
writeln(log);
end func;
const proc: exec_print_to_file (inout string: symbol, inout string: line) is func
local
var integer: file_number is 0;
var file: aFile is STD_NULL;
begin
symbol := get_symbol(line);
file_number := round(exec_expr(symbol, line));
aFile := getFileValue(file_number);
expect(",", symbol, line);
if aFile <> STD_NULL then
line_marker;
write(log, "PRINT #" <& file_number <& ", ");
if symbol = "USING" then
exec_print_using(aFile, symbol, line);
else
exec_print(aFile, symbol, line);
end if;
elsif on_error_label <> "" then
error_code := 52;
line_marker;
writeln(log, error_code <& " BAD FILE NUMBER #" <& file_number <&
" - ON ERROR GOTO " <& on_error_label);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "BAD FILE NUMBER #" <& file_number <& " IN PRINT.");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end if;
end func;
const proc: exec_write_to_file (inout string: symbol, inout string: line) is func
local
var integer: file_number is 0;
var file: aFile is STD_NULL;
var string: variable_name is "";
var string: param1 is "";
var float: num1 is 0.0;
begin
symbol := get_symbol(line);
file_number := round(exec_expr(symbol, line));
aFile := getFileValue(file_number);
if aFile <> STD_NULL then
while symbol = "," do
symbol := get_symbol(line);
if isStringExpr(symbol) then
param1 := exec_str_expr(symbol, line, variable_name);
write(aFile, literal(param1));
line_marker;
writeln(log, "WRITE #" <& file_number <& ", " <& literal(param1));
else
num1 := exec_expr(symbol, line);
write(aFile, num1);
line_marker;
writeln(log, "WRITE #" <& file_number <& ", " <& num1);
end if;
if symbol = "," then
write(aFile, ", ");
end if;
end while;
writeln(aFile);
flush(aFile);
elsif on_error_label <> "" then
error_code := 52;
line_marker;
writeln(log, error_code <& " BAD FILE NUMBER #" <& file_number <&
" - ON ERROR GOTO " <& on_error_label);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "BAD FILE NUMBER #" <& file_number <& " IN WRITE.");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end if;
end func;
const proc: exec_write (inout string: symbol, inout string: line) is func
local
var string: variable_name is "";
var string: param1 is "";
var float: num1 is 0.0;
var boolean: finished is FALSE;
begin
if endOfStatement(symbol) then
writeln(win);
flush(win);
writeln(log, "WRITE");
else
repeat
if isStringExpr(symbol) then
param1 := exec_str_expr(symbol, line, variable_name);
write(win, literal(param1));
line_marker;
writeln(log, "WRITE " <& literal(param1));
else
num1 := exec_expr(symbol, line);
write(win, num1);
line_marker;
writeln(log, "WRITE " <& num1);
end if;
if symbol = "," then
symbol := get_symbol(line);
write(win, ", ");
else
finished := TRUE;
end if;
until finished;
writeln(win);
flush(win);
end if;
end func;
const proc: exec_read (inout string: symbol, inout string: line) is func
local
var string: variable_name is "";
var string: data_elem is "";
var string: param1 is "";
var float: num1 is 0.0;
begin
repeat
symbol := get_symbol(line);
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
param1 := get_data_field(symbol, line);
if not in_error_handler then
setStringVar(variable_name, param1);
line_marker;
write(log, "READ " <& variable_name <& " " <& literal(param1) <&
" IN DATA LINE ");
line_marker(data_line_number);
writeln(log);
end if;
elsif isNumericVar(symbol) then
variable_name := get_name(symbol, line);
data_elem := trim(get_data_field(symbol, line));
if not in_error_handler then
if data_elem = "" then
setNumericVar(variable_name, 0.0);
line_marker;
write(log, "READ " <& variable_name <& " 0.0 IN DATA LINE ");
line_marker(data_line_number);
writeln(log);
else
param1 := get_symbol(data_elem);
if param1 = "-" then
param1 &:= get_symbol(data_elem);
elsif param1 = "+" then
param1 := get_symbol(data_elem);
end if;
block
num1 := float(param1);
setNumericVar(variable_name, num1);
line_marker;
write(log, "READ " <& variable_name <& " " <& num1 <& " IN DATA LINE ");
line_marker(data_line_number);
writeln(log);
exception
catch RANGE_ERROR:
error_marker;
write(err, "NUMBER EXPECTED IN READ FOUND " <& literal(param1) <&
" IN DATA LINE ");
line_marker(data_line_number);
writeln(err, ".");
end block;
if data_elem <> "" then
error_marker;
write(err, "FOUND " <& literal(data_elem) <& " AFTER " <&
literal(param1) <& " IN DATA LINE ");
line_marker(data_line_number);
writeln(err, ".");
end if;
end if;
end if;
else
error_marker;
writeln(err, "VARIABLE EXPECTED - FOUND " <& literal(symbol) <& ".");
end if;
until symbol <> "," or in_error_handler;
end func;
const proc: exec_input_from_file (inout string: symbol, inout string: line) is func
local
var integer: file_number is 0;
var file: aFile is STD_NULL;
var string: variable_name is "";
var string: param1 is "";
var float: num1 is 0.0;
begin
symbol := get_symbol(line);
file_number := round(exec_expr(symbol, line));
aFile := getFileValue(file_number);
if aFile <> STD_NULL then
if eof(aFile) then
aFile.bufferChar := EOF;
elsif aFile.bufferChar = EOF then
aFile.bufferChar := getc(aFile);
end if;
while symbol = "," do
symbol := get_symbol(line);
skip_space_cr_lf(aFile);
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
param1 := read_input_string(aFile);
setStringVar(variable_name, param1);
line_marker;
writeln(log, "INPUT #" <& file_number <& ", " <& variable_name <&
" " <& literal(param1));
elsif isNumericVar(symbol) then
variable_name := get_name(symbol, line);
param1 := read_input_number(aFile);
block
num1 := float(param1);
setNumericVar(variable_name, num1);
line_marker;
writeln(log, "INPUT #" <& file_number <& ", " <& variable_name <&
" " <& num1);
exception
catch RANGE_ERROR:
error_marker;
writeln(err, "NUMBER EXPECTED FOR INPUT OF " <& variable_name <&
" FOUND " <& literal(param1) <& ".");
end block;
else
error_marker;
writeln(err, "VARIABLE EXPECTED - FOUND " <& literal(symbol) <& ".");
end if;
skipSpace(aFile);
if aFile.bufferChar = ',' or aFile.bufferChar = '\r' then
aFile.bufferChar := getc(aFile);
end if;
end while;
elsif on_error_label <> "" then
error_code := 52;
line_marker;
writeln(log, error_code <& " BAD FILE NUMBER #" <& file_number <&
" - ON ERROR GOTO " <& on_error_label);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "BAD FILE NUMBER #" <& file_number <& " IN INPUT.");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end if;
end func;
const proc: read_input (inout file: inFile,
inout string: symbol, inout string: line) is func
local
var string: variable_name is "";
var string: param1 is "";
begin
while symbol = "," do
symbol := get_symbol(line);
skipSpace(inFile);
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
param1 := read_input_string(inFile);
assign_input_string(variable_name, param1);
elsif isNumericVar(symbol) then
variable_name := get_name(symbol, line);
param1 := read_input_number(inFile);
assign_input_number(variable_name, param1);
else
error_marker;
writeln(err, "VARIABLE EXPECTED - FOUND " <& literal(symbol) <& ".");
end if;
if inFile.bufferChar = ',' then
inFile.bufferChar := getc(inFile);
end if;
end while;
end func;
const proc: exec_input (inout string: symbol, inout string: line) is func
local
var string: variable_name is "";
var string: param1 is "";
var string: param2 is "";
begin
if symbol = ";" then
symbol := get_symbol(line);
end if;
if isStringExpr(symbol) then
param1 := exec_str_expr(symbol, line, variable_name);
if symbol = ";" or (variable_name = "" and (symbol = "," or symbol = ":")) then
write(win, param1);
line_marker;
write(log, "INPUT " <& literal(param1));
if symbol = ";" or symbol = ":" then
if symbol = ";" then
write(win, "? ");
write(log, "? ");
end if;
symbol := ",";
end if;
flush(win);
writeln(log);
IN.bufferChar := getc(IN);
read_input(IN, symbol, line);
elsif variable_name <> "" then
write(win, "? ");
flush(win);
line_marker;
writeln(log, "INPUT ? " <& variable_name);
IN.bufferChar := getc(IN);
skipSpace(IN);
param2 := read_input_string(IN);
assign_input_string(variable_name, param2);
if IN.bufferChar = ',' then
IN.bufferChar := getc(IN);
end if;
read_input(IN, symbol, line);
else
error_expect2(";", ",", symbol);
end if;
elsif isNumericVar(symbol) then
variable_name := get_name(symbol, line);
write(win, "? ");
flush(win);
line_marker;
writeln(log, "INPUT ? " <& variable_name);
IN.bufferChar := getc(IN);
skipSpace(IN);
param1 := read_input_number(IN);
assign_input_number(variable_name, param1);
if IN.bufferChar = ',' then
IN.bufferChar := getc(IN);
end if;
read_input(IN, symbol, line);
else
error_marker;
writeln(err, "VARIABLE OR STRING EXPECTED - FOUND " <& literal(symbol) <& ".");
end if;
end func;
const proc: exec_line_input_from_file (inout string: symbol, inout string: line) is func
local
var integer: file_number is 0;
var file: aFile is STD_NULL;
var string: variable_name is "";
var string: param1 is "";
begin
symbol := get_symbol(line);
file_number := round(exec_expr(symbol, line));
aFile := getFileValue(file_number);
if aFile <> STD_NULL then
expect(",", symbol, line);
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
param1 := getln(aFile);
setStringVar(variable_name, param1);
line_marker;
writeln(log, "LINE INPUT #" <& file_number <& ", " <& variable_name <&
" " <& literal(param1));
else
error_marker;
writeln(err, "STRING VARIABLE EXPECTED IN LINE INPUT FOUND " <&
literal(symbol) <& ".");
end if;
elsif on_error_label <> "" then
error_code := 52;
line_marker;
writeln(log, error_code <& " BAD FILE NUMBER #" <& file_number <&
" - ON ERROR GOTO " <& on_error_label);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "BAD FILE NUMBER #" <& file_number <& " IN LINE INPUT.");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end if;
end func;
const proc: exec_line_input (inout string: symbol, inout string: line) is func
local
var string: variable_name is "";
var string: param1 is "";
var string: param2 is "";
begin
if symbol = ";" then
symbol := get_symbol(line);
end if;
if isStringExpr(symbol) then
param1 := exec_str_expr(symbol, line, variable_name);
if symbol = ";" or symbol = "," then
symbol := get_symbol(line);
write(win, param1);
flush(win);
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
line_marker;
write(log, "LINE INPUT " <& literal(param1) <& "; " <& variable_name);
flush(log);
readln(param2);
writeln(win);
flush(win);
setStringVar(variable_name, param2);
writeln(log, " <- " <& literal(param2));
else
error_marker;
writeln(err, "STRING VARIABLE EXPECTED FOR LINE INPUT - FOUND " <&
symbol <& ".");
end if;
elsif variable_name <> "" then
write(win, "? ");
flush(win);
line_marker;
write(log, "LINE INPUT " <& variable_name);
flush(log);
readln(param2);
writeln(win);
flush(win);
setStringVar(variable_name, param2);
writeln(log, " <- " <& literal(param2));
else
error_expect2(";", ",", symbol);
end if;
else
error_marker;
writeln(err, "STRING EXPECTED FOR LINE INPUT - FOUND " <&
symbol <& ".");
end if;
end func;
const proc: exec_linput_from_file (inout string: symbol, inout string: line) is func
local
var integer: file_number is 0;
var file: aFile is STD_NULL;
var string: variable_name is "";
var string: param1 is "";
begin
symbol := get_symbol(line);
file_number := round(exec_expr(symbol, line));
aFile := getFileValue(file_number);
if aFile <> STD_NULL then
expect(":", symbol, line);
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
param1 := getln(aFile);
setStringVar(variable_name, param1);
line_marker;
writeln(log, "LINPUT #" <& file_number <& ": " <& variable_name <&
" " <& literal(param1));
else
error_marker;
writeln(err, "STRING VARIABLE EXPECTED IN LINPUT FOUND " <&
literal(symbol) <& ".");
end if;
elsif on_error_label <> "" then
error_code := 52;
line_marker;
writeln(log, error_code <& " BAD FILE NUMBER #" <& file_number <&
" - ON ERROR GOTO " <& on_error_label);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "BAD FILE NUMBER #" <& file_number <& " IN LINPUT.");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end if;
end func;
const proc: exec_linput (inout string: symbol, inout string: line) is func
local
var string: variable_name is "";
var string: param1 is "";
var string: param2 is "";
begin
if isStringExpr(symbol) then
param1 := exec_str_expr(symbol, line, variable_name);
if symbol = ":" then
symbol := get_symbol(line);
write(win, param1);
flush(win);
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
line_marker;
write(log, "LINPUT " <& literal(param1) <& ": " <& variable_name);
flush(log);
readln(param2);
writeln(win);
flush(win);
setStringVar(variable_name, param2);
writeln(log, " <- " <& literal(param2));
else
error_marker;
writeln(err, "STRING VARIABLE EXPECTED FOR LINPUT - FOUND " <&
symbol <& ".");
end if;
elsif variable_name <> "" then
write(win, "? ");
flush(win);
line_marker;
write(log, "LINPUT " <& variable_name);
flush(log);
readln(param2);
writeln(win);
flush(win);
setStringVar(variable_name, param2);
writeln(log, " <- " <& literal(param2));
else
error_expect(":", symbol);
end if;
else
error_marker;
writeln(err, "STRING EXPECTED FOR LINPUT - FOUND " <&
symbol <& ".");
end if;
end func;
const proc: exec_display (inout string: symbol, inout string: line) is func
local
const set of string: display_keywords is {"AT", "BEEP", "ERASE", "SIZE"};
var integer: row is 0;
var integer: column is 0;
var integer: count is 0;
var string: unused_name is "";
var string: param1 is "";
var float: num1 is 0.0;
var boolean: finished is FALSE;
begin
line_marker;
write(log, "DISPLAY ");
if symbol in display_keywords then
repeat
if symbol = "AT" then
symbol := get_symbol(line);
expect("(", symbol, line);
row := round(exec_expr(symbol, line));
expect(",", symbol, line);
column := round(exec_expr(symbol, line));
expect(")", symbol, line);
write(log, "AT(" <& row <& ", " <& column <& ") ");
setPos(win, row, column);
end if;
if symbol = "BEEP" then
symbol := get_symbol(line);
write(log, "DISPLAY **BEEP ");
end if;
if symbol = "ERASE" then
symbol := get_symbol(line);
expect("ALL", symbol, line);
clear(win);
write(log, "ERASE ALL ");
end if;
if symbol = "SIZE" then
symbol := get_symbol(line);
expect("(", symbol, line);
count := round(exec_expr(symbol, line));
expect(")", symbol, line);
write(win, " " mult count);
write(win, "\b" mult count);
write(log, "SIZE(" <& count <& ") ");
end if;
until symbol not in display_keywords;
expect(":", symbol, line);
write(log, ": ");
end if;
repeat
if isStringExpr(symbol) then
param1 := exec_str_expr(symbol, line, unused_name);
write(win, literal(param1));
write(log, literal(param1));
else
num1 := exec_expr(symbol, line);
write(win, num1);
write(log, num1);
end if;
if symbol = "," then
symbol := get_symbol(line);
write(log, ", ");
elsif symbol = ";" then
symbol := get_symbol(line);
write(log, "; ");
else
finished := TRUE;
end if;
until finished;
writeln(log);
end func;
const func file: basicOpen (in var string: filePath, in string: access) is func
result
var file: fileOpened is STD_NULL;
local
var array string: pathElems is 0 times "";
var integer: startElem is 1;
var integer: number is 0;
var array string: directoryContent is 0 times "";
var string: directoryElement is "";
var boolean: foundTwice is FALSE;
var string: foundElement is "";
var boolean: path_okay is TRUE;
var string: path is "";
begin
if filePath <> "" then
filePath := convDosPath(filePath);
pathElems := split(filePath, '/');
if length(pathElems) >= 1 and pathElems[1] = "" then
path := "/";
startElem := 2;
else
path := getcwd;
startElem := 1;
end if;
for number range startElem to length(pathElems) do
if fileType(path & "/" & pathElems[number]) <> FILE_ABSENT then
path &:= "/" & pathElems[number];
elsif fileType(path) = FILE_DIR then
directoryContent := readDir(path);
foundTwice := FALSE;
foundElement := "";
for directoryElement range directoryContent do
if upper(pathElems[number]) = upper(directoryElement) then
if foundElement = "" then
foundElement := directoryElement;
else
foundTwice := TRUE;
end if;
end if;
end for;
if foundElement <> "" and not foundTwice and
fileType(path & "/" & foundElement) <> FILE_ABSENT then
path &:= "/" & foundElement;
elsif access[1 len 1] <> "r" then
path &:= "/" & pathElems[number];
else
path_okay := FALSE;
end if;
else
path_okay := FALSE;
end if;
end for;
else
path_okay := FALSE;
end if;
if path_okay then
fileOpened := open(path, access);
fileOpened.bufferChar := EOF;
end if;
end func;
const proc: exec_open (inout string: symbol, inout string: line) is func
local
var string: unused_name is "";
var string: param1 is "";
var string: param2 is "";
var string: param_for is "";
var string: param_access is "";
var string: mode is "";
var string: file_name is "";
var integer: index1 is 0;
var file: aFile is STD_NULL;
begin
symbol := get_symbol(line);
param1 := exec_str_expr(symbol, line, unused_name);
if symbol = "FOR" then
param_for := get_symbol(line);
if param_for = "INPUT" then
mode := "r";
elsif param_for = "OUTPUT" then
mode := "w";
elsif param_for = "APPEND" then
mode := "a";
elsif param_for = "RANDOM" then
mode := "r+";
elsif param_for = "BINARY" then
mode := "r+";
else
mode := "r";
error_marker;
writeln(err, "ILLEGAL - OPEN FOR " <& param_for);
end if;
symbol := get_symbol(line);
else
mode := "r+";
end if;
if symbol = "ACCESS" then
symbol := get_symbol(line);
if symbol = "READ" then
param_access := symbol;
symbol := get_symbol(line);
end if;
if symbol = "WRITE" then
if param_access <> "" then
param_access &:= " ";
end if;
param_access &:= symbol;
symbol := get_symbol(line);
end if;
end if;
if symbol = "SHARED" then
symbol := get_symbol(line);
elsif symbol = "LOCK" then
symbol := get_symbol(line);
if symbol = "READ" then
symbol := get_symbol(line);
end if;
if symbol = "WRITE" then
symbol := get_symbol(line);
end if;
end if;
if symbol = "AS" or symbol = "AS#" then
if symbol = "AS#" then
symbol := "#";
else
symbol := get_symbol(line);
end if;
if symbol = "#" then
symbol := get_symbol(line);
end if;
index1 := round(exec_expr(symbol, line));
if symbol = "LEN" then
symbol := get_symbol(line);
expect("=", symbol, line);
reclen_value[index1] := round(exec_expr(symbol, line));
else
reclen_value[index1] := 0;
end if;
file_name := param1;
aFile := basicOpen(file_name, mode);
if aFile = STD_NULL and param_access = "" and
(param_for = "" or param_for = "RANDOM" or param_for = "BINARY") then
mode := "w+";
aFile := basicOpen(file_name, mode);
if aFile = STD_NULL then
mode := "w";
aFile := basicOpen(file_name, mode);
if aFile = STD_NULL then
mode := "r";
aFile := basicOpen(file_name, mode);
end if;
end if;
end if;
if aFile <> STD_NULL then
setFileValue(index1, aFile);
end if;
line_marker;
write(log, "OPEN " <& param1);
if param_for <> "" then
write(log, " FOR " <& param_for);
end if;
if param_access <> "" then
write(log, " ACCESS " <& param_access);
end if;
writeln(log, " AS #" <& index1 <&
" - open(" <& literal(file_name) <& ", " <& literal(mode) <& ")");
else
if param1 <> "" then
if param1[.. 1] = "I" then
mode := "r";
elsif param1[.. 1] = "O" then
mode := "w";
elsif param1[.. 1] = "R" then
mode := "r+";
elsif param1[.. 1] = "B" then
mode := "r+";
end if;
end if;
if mode = "" then
mode := "r";
error_marker;
writeln(err, "ILLEGAL - OPEN " <& param1);
end if;
expect(",", symbol, line);
if symbol = "#" then
symbol := get_symbol(line);
end if;
index1 := round(exec_expr(symbol, line));
expect(",", symbol, line);
param2 := exec_str_expr(symbol, line, unused_name);
file_name := param2;
line_marker;
aFile := basicOpen(file_name, mode);
if aFile <> STD_NULL then
setFileValue(index1, aFile);
end if;
if symbol = "," then
symbol := get_symbol(line);
reclen_value[index1] := round(exec_expr(symbol, line));
else
reclen_value[index1] := 0;
end if;
line_marker;
write(log, "OPEN " <& literal(param1) <& ", #" <& index1 <&
", " <& literal(param2));
writeln(log, " - open(" <& literal(file_name) <& ", " <& literal(mode) <& ")");
end if;
if aFile = STD_NULL then
if on_error_label <> "" then
error_code := 53;
line_marker;
writeln(log, error_code <& " FILE NOT FOUND " <& literal(file_name) <&
" - ON ERROR GOTO " <& on_error_label);
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "FILE NOT FOUND " <& literal(file_name));
end if;
end if;
end func;
const proc: exec_close (inout string: symbol, inout string: line) is func
local
var integer: file_number is 0;
var file: aFile is STD_NULL;
var boolean: okay is FALSE;
begin
if symbol = "CLOSE#" then
symbol := "#";
else
symbol := get_symbol(line);
end if;
if endOfStatement(symbol) then
closeAllFiles;
line_marker;
writeln(log, "CLOSE");
else
repeat
if symbol = "#" then
symbol := get_symbol(line);
end if;
file_number := round(exec_expr(symbol, line));
aFile := getFileValue(file_number);
if aFile <> STD_NULL then
close(aFile);
setFileValue(file_number, STD_NULL);
line_marker;
writeln(log, "CLOSE #" <& file_number);
else
line_marker;
writeln(log, "CLOSE #" <& file_number <& " - FILE ALREADY CLOSED.");
end if;
if symbol = "," then
symbol := get_symbol(line);
else
okay := TRUE;
end if;
until okay;
end if;
end func;
const proc: exec_file_put (inout string: symbol, inout string: line) is func
local
var integer: file_number is 0;
var file: outFile is STD_NULL;
var integer: position is 0;
var boolean: with_position is FALSE;
var integer: reclen is 0;
var string: variable_name is "";
var string: field is "";
begin
if symbol = "#" then
symbol := get_symbol(line);
end if;
file_number := round(exec_expr(symbol, line));
outFile := getFileValue(file_number);
if outFile <> STD_NULL then
if symbol = "," then
symbol := get_symbol(line);
if symbol <> "," and not endOfStatement(symbol) then
position := round(exec_expr(symbol, line));
with_position := TRUE;
end if;
if symbol = "," then
symbol := get_symbol(line);
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
end if;
end if;
end if;
if with_position then
if position >= 1 then
if reclen_value[file_number] <> 0 then
reclen := reclen_value[file_number];
else
if length(field_value[file_number]) >= 1 then
reclen := 0;
for field range field_value[file_number] do
reclen +:= length(getStringVar(field));
end for;
error_marker;
writeln(err, "PUT #" <& file_number <&
" FILE HAS NO RECORD LENGTH SPECIFIED - USE THE FIELD SIZE: " <& reclen);
elsif variable_name <> "" then
reclen := length(getStringVar(variable_name));
error_marker;
writeln(err, "PUT #" <& file_number <&
" FILE HAS NO RECORD LENGTH SPECIFIED - USE THE SIZE OF THE VARIABLE: " <& reclen);
else
reclen := 0;
error_marker;
writeln(err, "PUT #" <& file_number <&
" FILE HAS NO RECORD LENGTH SPECIFIED - POSITION IGNORED");
end if;
end if;
if reclen <> 0 then
seek(outFile, succ(pred(position) * reclen));
end if;
else
error_marker;
writeln(err, "PUT #" <& file_number <&
" WITH A RECORD NUMBER OF " <& position);
end if;
end if;
if length(field_value[file_number]) >= 1 then
for field range field_value[file_number] do
write(outFile, getStringVar(field));
end for;
elsif variable_name <> "" then
write(outFile, getStringVar(variable_name));
else
error_marker;
writeln(err, "PUT #" <& file_number <&
" - NO STRING VARIABLE PRESENT");
end if;
line_marker;
write(log, "PUT #" <& file_number <& ", ");
if with_position then
write(log, position);
end if;
if length(field_value[file_number]) >= 1 then
for field range field_value[file_number] do
write(log, ", " <& field <& "=" <&
literal(getStringVar(field)));
end for;
elsif variable_name <> "" then
write(log, ", " <& variable_name <& "=" <&
literal(getStringVar(variable_name)));
end if;
writeln(log);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while
elsif on_error_label <> "" then
error_code := 52;
line_marker;
writeln(log, error_code <& " BAD FILE NUMBER #" <& file_number <&
" - ON ERROR GOTO " <& on_error_label);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "BAD FILE NUMBER #" <& file_number <& " IN PUT.");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end if;
end func;
const proc: exec_file_get (inout string: symbol, inout string: line) is func
local
var integer: file_number is 0;
var file: inFile is STD_NULL;
var integer: position is 0;
var boolean: with_position is FALSE;
var integer: reclen is 0;
var string: variable_name is "";
var string: field is "";
begin
if symbol = "#" then
symbol := get_symbol(line);
end if;
file_number := round(exec_expr(symbol, line));
inFile := getFileValue(file_number);
if inFile <> STD_NULL then
if symbol = "," then
symbol := get_symbol(line);
if symbol <> "," and not endOfStatement(symbol) then
position := round(exec_expr(symbol, line));
with_position := TRUE;
end if;
if symbol = "," then
symbol := get_symbol(line);
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
end if;
end if;
end if;
if with_position then
if position >= 1 then
if reclen_value[file_number] <> 0 then
reclen := reclen_value[file_number];
else
if length(field_value[file_number]) >= 1 then
reclen := 0;
for field range field_value[file_number] do
reclen +:= length(getStringVar(field));
end for;
error_marker;
writeln(err, "GET #" <& file_number <&
" FILE HAS NO RECORD LENGTH SPECIFIED - USE THE FIELD SIZE: " <& reclen);
elsif variable_name <> "" then
reclen := length(getStringVar(variable_name));
error_marker;
writeln(err, "GET #" <& file_number <&
" FILE HAS NO RECORD LENGTH SPECIFIED - USE THE SIZE OF THE VARIABLE: " <& reclen);
else
reclen := 0;
error_marker;
writeln(err, "GET #" <& file_number <&
" FILE HAS NO RECORD LENGTH SPECIFIED - POSITION IGNORED");
end if;
end if;
if reclen <> 0 then
seek(inFile, succ(pred(position) * reclen));
end if;
else
error_marker;
writeln(err, "GET #" <& file_number <&
" WITH A RECORD NUMBER OF " <& position);
end if;
end if;
if length(field_value[file_number]) >= 1 then
for field range field_value[file_number] do
setStringVar(field, gets(inFile, length(getStringVar(field))));
end for;
elsif variable_name <> "" then
setStringVar(variable_name, gets(inFile,
length(getStringVar(variable_name))));
else
error_marker;
writeln(err, "GET #" <& file_number <&
" - NO STRING VARIABLE PRESENT");
end if;
line_marker;
write(log, "GET #" <& file_number <& ", ");
if with_position then
write(log, position);
end if;
if length(field_value[file_number]) >= 1 then
for field range field_value[file_number] do
write(log, ", " <& field <& "=" <& literal(getStringVar(field)));
end for;
elsif variable_name <> "" then
write(log, ", " <& variable_name <& "=" <& literal(getStringVar(variable_name)));
end if;
writeln(log);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while
elsif on_error_label <> "" then
error_code := 52;
line_marker;
writeln(log, error_code <& " BAD FILE NUMBER #" <& file_number <&
" - ON ERROR GOTO " <& on_error_label);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "BAD FILE NUMBER #" <& file_number <& " IN GET.");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end if;
end func;
const proc: exec_seek (inout string: symbol, inout string: line) is func
local
var integer: file_number is 0;
var file: aFile is STD_NULL;
var integer: position is 0;
begin
if symbol = "SEEK#" then
symbol := get_symbol(line);
else
symbol := get_symbol(line);
if symbol = "#" then
symbol := get_symbol(line);
end if;
end if;
file_number := round(exec_expr(symbol, line));
aFile := getFileValue(file_number);
if aFile <> STD_NULL then
expect(",", symbol, line);
position := round(exec_expr(symbol, line));
seek(aFile, position);
aFile.bufferChar := EOF;
line_marker;
writeln(log, "SEEK #" <& file_number <& ", " <& position);
elsif on_error_label <> "" then
error_code := 52;
line_marker;
writeln(log, error_code <& " BAD FILE NUMBER #" <& file_number <&
" - ON ERROR GOTO " <& on_error_label);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "BAD FILE NUMBER #" <& file_number <& " IN SEEK.");
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end if;
end func;
const proc: clearProgram is func
begin
closeAllFiles;
numeric_var := numeric_hash.EMPTY_HASH;
string_var := string_hash.EMPTY_HASH;
image_var := image_hash.EMPTY_HASH;
def_fn_list := def_fn_hash.EMPTY_HASH;
defstr_var := (set of char).EMPTY_SET;
data_line_number := 0;
data_line := "";
end func;
const proc: exec_clear (inout string: symbol, inout string: line) is func
begin
symbol := get_symbol(line);
clearProgram;
line_marker;
writeln(log, "CLEAR " <& symbol);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end func;
const func string: parseType (inout string: symbol, inout string: line) is func
result
var string: typeName is "";
begin
typeName := get_symbol(line);
if typeName = "SHARED" then
typeName := get_symbol(line);
end if;
symbol := get_symbol(line);
end func;
const proc: initArray (in var string: arrayName, in boolean: isStringVar,
in integer: dimension, in dimensionType: dimensionBounds) is func
local
var integer: index is 0;
begin
if dimension <= length(dimensionBounds) then
if dimension = 1 then
arrayName &:= "(";
else
arrayName &:= ",";
end if;
for index range dimensionBounds[dimension].lbound to dimensionBounds[dimension].ubound do
if dimension = length(dimensionBounds) then
if isStringVar then
setStringVar(arrayName & str(index) & ")", "");
else
setNumericVar(arrayName & str(index) & ")", 0.0);
end if;
else
initArray(arrayName & str(index), isStringVar, succ(dimension), dimensionBounds);
end if;
end for;
end if;
end func;
const proc: exec_dim (inout string: symbol, inout string: line) is func
local
var string: variableName is "";
var dimensionType: dimensionBounds is 0 times boundsType.value;
var boundsType: bounds is boundsType.value;
var string: typeName is "";
var integer: dimension is 0;
var boolean: finished is FALSE;
begin
symbol := get_symbol(line);
if symbol = "SHARED" then
symbol := get_symbol(line);
end if;
repeat
if symbol[1] >= 'A' and symbol[1] <= 'Z' then
variableName := symbol;
symbol := get_symbol(line);
if symbol = "(" or symbol = "[" then
dimensionBounds := 0 times boundsType.value;
repeat
symbol := get_symbol(line);
bounds.ubound := round(exec_expr(symbol, line));
if symbol = "TO" then
symbol := get_symbol(line);
bounds.lbound := bounds.ubound;
bounds.ubound := round(exec_expr(symbol, line));
else
bounds.lbound := 0;
end if;
dimensionBounds &:= [] (bounds);
until symbol <> ",";
if symbol =")" or symbol = "]" then
symbol := get_symbol(line);
if symbol = "AS" then
typeName := parseType(symbol, line);
if typeName = "STRING" then
incl(string_var_name, variableName);
end if;
else
typeName := "";
end if;
initArray(variableName, isStringVar(variableName), 1, dimensionBounds);
ignore(varptr(variableName));
line_marker;
write(log, "DIM " <& variableName <& "(");
for dimension range 1 to length(dimensionBounds) do
if dimension <> 1 then
write(log, ", ");
end if;
write(log, dimensionBounds[dimension].lbound <& " TO " <&
dimensionBounds[dimension].ubound);
end for;
write(log, ")");
if typeName <> "" then
write(log, " AS " <& typeName);
end if;
writeln(log);
end if;
else
if symbol = "AS" then
typeName := parseType(symbol, line);
if typeName = "STRING" then
incl(string_var_name, variableName);
end if;
else
typeName := "";
end if;
line_marker;
write(log, "DIM " <& variableName);
if typeName <> "" then
write(log, " AS " <& typeName);
end if;
writeln(log);
end if;
end if;
if symbol = "," then
symbol := get_symbol(line);
else
finished := TRUE;
end if;
until finished;
end func;
const proc: exec_defType_numeric (inout string: symbol, inout string: line) is func
local
var string: statement is "";
var string: param1 is "";
var string: param2 is "";
var char: ch1 is ' ';
var boolean: okay is FALSE;
begin
statement := symbol;
symbol := get_symbol(line);
okay := FALSE;
repeat
if length(symbol) = 1 and symbol >= "A" and symbol <= "Z" then
param1 := symbol;
symbol := get_symbol(line);
if symbol = "-" then
symbol := get_symbol(line);
if length(symbol) = 1 and symbol >= param1 and symbol <= "Z" then
param2 := symbol;
symbol := get_symbol(line);
for ch1 range param1[1] to param2[1] do
excl(defstr_var, ch1);
end for;
line_marker;
writeln(log, statement <& " " <& param1 <& "-" <& param2);
else
error_marker;
writeln(err, "ILLEGAL " <& statement <& " " <& param1 <& "-" <& symbol);
end if;
else
excl(defstr_var, param1[1]);
line_marker;
writeln(log, statement <& " " <& param1);
end if;
else
error_marker;
writeln(err, "ILLEGAL " <& statement <& " " <& symbol);
end if;
if symbol = "," then
symbol := get_symbol(line);
else
okay := TRUE;
end if;
until okay;
end func;
const proc: exec_defstr (inout string: symbol, inout string: line) is func
local
var string: param1 is "";
var string: param2 is "";
var char: ch1 is ' ';
var boolean: okay is FALSE;
begin
symbol := get_symbol(line);
defstr_var := (set of char).EMPTY_SET;
okay := FALSE;
repeat
if length(symbol) = 1 and symbol >= "A" and symbol <= "Z" then
param1 := symbol;
symbol := get_symbol(line);
if symbol = "-" then
symbol := get_symbol(line);
if length(symbol) = 1 and symbol >= param1 and symbol <= "Z" then
param2 := symbol;
symbol := get_symbol(line);
for ch1 range param1[1] to param2[1] do
incl(defstr_var, ch1);
end for;
line_marker;
writeln(log, "DEFSTR " <& param1 <& "-" <& param2);
else
error_marker;
writeln(err, "ILLEGAL DEFSTR " <& param1 <& "-" <& symbol);
end if;
else
incl(defstr_var, param1[1]);
line_marker;
writeln(log, "DEFSTR " <& param1);
end if;
else
error_marker;
writeln(err, "ILLEGAL DEFSTR " <& symbol);
end if;
if symbol = "," then
symbol := get_symbol(line);
else
okay := TRUE;
end if;
until okay;
end func;
const proc: exec_type (inout string: symbol, inout string: line) is func
begin
symbol := next_symbol(line);
line_marker;
writeln(log, "**TYPE " <& symbol);
while symbol <> "END" and symbol <> "" do
if ignoreRestOfLine(symbol) then
line := "";
end if;
symbol := next_symbol(line);
end while;
if symbol = "END" then
repeat
symbol := get_symbol(line);
until symbol <> "END";
if ignoreRestOfLine(symbol) then
line := "";
end if;
if symbol <> "TYPE" then
exec_type(symbol, line);
else
symbol := get_symbol(line);
end if;
end if;
end func;
const func string: readVarNameFromBloadFile (inout file: aFile, inout integer: byteIndex) is func
result
var string: bloadName is "";
local
var integer: twoTimes is 0;
var integer: number is 0;
var integer: count is 0;
var char: ch is ' ';
begin
for twoTimes range 1 to 2 do
number := ord(getc(aFile));
for count range 1 to number do
ch := getc(aFile);
incr(byteIndex);
if ch >= '\128;' then
ch := chr(ord(ch) - 128);
end if;
bloadName &:= str(ch);
end for;
end for;
end func;
const proc: exec_bload (inout string: symbol, inout string: line) is func
local
var string: unused_name is "";
var string: file_name is "";
var string: variable_name is "";
var string: arrayName is "";
var string: bloadName is "";
var integer: address is 0;
var file: aFile is STD_NULL;
var integer: sizeInBytes is 0;
var integer: byteIndex is 0;
var string: name_start is "";
var string: name_end is "";
var integer: lbound is 0;
var integer: ubound is 0;
var integer: intIndex is 0;
var integer: number is 0;
begin
symbol := get_symbol(line);
file_name := exec_str_expr(symbol, line, unused_name);
if symbol = "," then
symbol := get_symbol(line);
address := round(exec_expr(symbol, line));
variable_name := varname(address);
end if;
if variable_name = "" then
variable_name := varseg_variable;
end if;
if variable_name <> "" then
lbound := getFirstIndex(variable_name, name_start, name_end);
if name_start = "" then
arrayName := variable_name;
lbound := exec_lbound(arrayName, 1);
ubound := exec_ubound(arrayName, 1);
name_start := arrayName & "(";
name_end := ")";
else
arrayName := name_start[ .. pred(length(name_start))];
ubound := exec_ubound(arrayName, 1);
end if;
intIndex := lbound;
aFile := basicOpen(file_name, "r");
if aFile <> STD_NULL then
if getc(aFile) = '\16#FD;' then
ignore(gets(aFile, 4));
sizeInBytes := ord(getc(aFile)) + 256 * ord(getc(aFile));
writeln(log, "sizeInBytes=" <& sizeInBytes);
for byteIndex range 0 to pred(sizeInBytes) step 2 do
if intIndex > ubound then
arrayName := varname(succ(varptr(arrayName)));
lbound := exec_lbound(arrayName, 1);
ubound := exec_ubound(arrayName, 1);
name_start := arrayName & "(";
name_end := ")";
intIndex := lbound;
bloadName := readVarNameFromBloadFile(aFile, byteIndex);
ignore(literal(gets(aFile, 5)));
byteIndex +:= 5;
if bloadName <> arrayName then
byteIndex := sizeInBytes;
end if;
end if;
number := ord(getc(aFile)) + 256 * ord(getc(aFile));
setNumericVar(name_start & str(intIndex) & name_end, flt(number));
incr(intIndex);
end for;
end if;
close(aFile);
else
if on_error_label <> "" then
error_code := 53;
line_marker;
writeln(log, error_code <& " FILE NOT FOUND " <& literal(file_name) <&
" - ON ERROR GOTO " <& on_error_label);
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "FILE NOT FOUND " <& literal(file_name));
end if;
end if;
end if;
line_marker;
writeln(log, "BLOAD " <& literal(file_name) <& ", VARPTR(" <& variable_name <& ")");
end func;
const proc: exec_files (inout string: symbol, inout string: line) is func
local
var string: filespec is "";
var string: unused_name is "";
var string: fileName is ""
begin
symbol := get_symbol(line);
if symbol <> "" then
filespec := exec_str_expr(symbol, line, unused_name);
for fileName range findMatchingFiles(convDosPath(filespec), FALSE) do
writeln(fileName);
end for;
else
for fileName range readDir(".") do
writeln(fileName);
end for;
end if;
writeln(log, "FILES " <& filespec);
end func;
const func PRIMITIVE_WINDOW: getCga2ImageFromBytes (in string: bytes) is func
result
var PRIMITIVE_WINDOW: image is PRIMITIVE_WINDOW.value;
local
var integer: width is 0;
var integer: height is 0;
var integer: bytesPerLine is 0;
var integer: lineStartByte is 0;
var integer: xPos is 0;
var integer: yPos is 0;
var integer: byteIndex is 0;
var integer: imageByte is 0;
var integer: colorNum is 0;
begin
if bytes <> "" then
width := bytes2Int(bytes[1 fixLen 2], UNSIGNED, LE);
height := bytes2Int(bytes[3 fixLen 2], UNSIGNED, LE);
image := newPixmap(width, height);
bytesPerLine := pred(width) mdiv 8 + 1;
for yPos range 0 to pred(height) do
lineStartByte := yPos * bytesPerLine;
for xPos range 0 to pred(width) do
colorNum := 0;
byteIndex := lineStartByte + xPos mdiv 8;
imageByte := ord(bytes[5 + byteIndex]);
if (imageByte >> (7 - xPos mod 8)) mod 2 = 1 then
point(image, xPos, yPos, white);
else
point(image, xPos, yPos, black);
end if;
end for;
end for;
end if;
end func;
const func PRIMITIVE_WINDOW: getCga4ImageFromBytes (in string: bytes) is func
result
var PRIMITIVE_WINDOW: image is PRIMITIVE_WINDOW.value;
local
var integer: width is 0;
var integer: height is 0;
var integer: bytesPerLine is 0;
var integer: lineStartByte is 0;
var integer: xPos is 0;
var integer: yPos is 0;
var integer: byteIndex is 0;
var integer: imageByte is 0;
var integer: colorNum is 0;
const array color: palette1 is [] (black, light_green, light_red, brown);
begin
if bytes <> "" then
width := bytes2Int(bytes[1 fixLen 2], UNSIGNED, LE);
height := bytes2Int(bytes[3 fixLen 2], UNSIGNED, LE);
width := width div 2;
image := newPixmap(width, height);
bytesPerLine := pred(width) mdiv 4 + 1;
for yPos range 0 to pred(height) do
lineStartByte := yPos * bytesPerLine;
for xPos range 0 to pred(width) do
colorNum := 0;
byteIndex := lineStartByte + xPos mdiv 4;
imageByte := ord(bytes[5 + byteIndex]);
colorNum := (imageByte >> (6 - xPos mod 4 * 2)) mod 4;
point(image, xPos, yPos, palette1[succ(colorNum)]);
end for;
end for;
end if;
end func;
const func PRIMITIVE_WINDOW: getEgaImageFromBytes (in string: bytes) is func
result
var PRIMITIVE_WINDOW: image is PRIMITIVE_WINDOW.value;
local
var integer: width is 0;
var integer: height is 0;
var integer: bytesPerLine is 0;
var integer: lineStartByte is 0;
var integer: xPos is 0;
var integer: yPos is 0;
var integer: colorBitNum is 0;
var integer: byteIndex is 0;
var integer: imageByte is 0;
var integer: colorNum is 0;
begin
if bytes <> "" then
width := bytes2Int(bytes[1 fixLen 2], UNSIGNED, LE);
height := bytes2Int(bytes[3 fixLen 2], UNSIGNED, LE);
image := newPixmap(width, height);
bytesPerLine := pred(width) mdiv 8 + 1;
for yPos range 0 to pred(height) do
lineStartByte := yPos * 4 * bytesPerLine;
for xPos range 0 to pred(width) do
colorNum := 0;
for colorBitNum range 0 to 3 do
byteIndex := lineStartByte + colorBitNum * bytesPerLine + xPos mdiv 8;
imageByte := ord(bytes[5 + byteIndex]);
colorNum +:= ((imageByte >> (7 - xPos mod 8)) mod 2) << colorBitNum;
end for;
point(image, xPos, yPos, color_num(colorNum));
end for;
end for;
end if;
end func;
const func PRIMITIVE_WINDOW: getVgaImageFromBytes (in string: bytes) is func
result
var PRIMITIVE_WINDOW: image is PRIMITIVE_WINDOW.value;
local
var integer: width is 0;
var integer: height is 0;
var integer: bytesPerLine is 0;
var integer: lineStartByte is 0;
var integer: xPos is 0;
var integer: yPos is 0;
var integer: byteIndex is 0;
var integer: imageByte is 0;
begin
if bytes <> "" then
width := bytes2Int(bytes[1 fixLen 2], UNSIGNED, LE) mdiv 8;
height := bytes2Int(bytes[3 fixLen 2], UNSIGNED, LE);
image := newPixmap(width, height);
bytesPerLine := width;
for yPos range 0 to pred(height) do
lineStartByte := yPos * bytesPerLine;
for xPos range 0 to pred(width) do
byteIndex := lineStartByte + xPos;
imageByte := ord(bytes[5 + byteIndex]);
point(image, xPos, yPos, color_num(imageByte));
end for;
end for;
end if;
end func;
const func string: getBytesFromArray (in string: name_start,
in string: name_end, in integer: lbound, in integer: ubound) is func
result
var string: bytes is "";
local
var integer: index is 0;
var float: element is 0.0;
var string: bytesFromInt2 is "";
var string: bytesFromFlt4 is "";
var string: bytesFromDbl8 is "";
var boolean: allInteger is TRUE;
var boolean: allFloat is TRUE;
begin
for index range lbound to ubound do
element := getNumericVar(name_start & str(index) & name_end);
if element >= -32768.0 and element <= 65535.0 then
bytesFromInt2 &:= bytes(round(element) mod 65536, UNSIGNED, LE, 2);
else
allInteger := FALSE;
end if;
if element >= -3.4028235e38 and element <= 3.4028235e38 or
abs(element) = Infinity or isNaN(element) then
bytesFromFlt4 &:= bytes(bin32(element), LE, 4);
else
allFloat := FALSE;
end if;
bytesFromDbl8 &:= bytes(bin64(element), LE, 8);
end for;
if allInteger then
bytes := bytesFromInt2;
elsif allFloat then
bytes := bytesFromFlt4;
else
bytes := bytesFromDbl8;
end if;
end func;
const func PRIMITIVE_WINDOW: getImageFromArray (in string: name_start,
in string: name_end, in integer: lbound, in integer: ubound) is func
result
var PRIMITIVE_WINDOW: image is PRIMITIVE_WINDOW.value;
begin
case screenMode of
when {1}:
image := getCga4ImageFromBytes(
getBytesFromArray(name_start, name_end, lbound, ubound));
when {2, 3}:
image := getCga2ImageFromBytes(
getBytesFromArray(name_start, name_end, lbound, ubound));
when {4, 7, 8}:
image := getEgaImageFromBytes(
getBytesFromArray(name_start, name_end, lbound, ubound));
when {13}:
image := getVgaImageFromBytes(
getBytesFromArray(name_start, name_end, lbound, ubound));
otherwise:
error_marker;
writeln(err, "CANNOT GET IMAGE FOR MODE: " <& screenMode);
end case;
end func;
const func PRIMITIVE_WINDOW: getImageFromArray (in string: variable_name) is func
result
var PRIMITIVE_WINDOW: image is PRIMITIVE_WINDOW.value;
local
var string: name_start is "";
var string: name_end is "";
var integer: lbound is 0;
var integer: ubound is 0;
begin
lbound := getFirstIndex(variable_name, name_start, name_end);
if name_start = "" then
lbound := exec_lbound(variable_name, 1);
ubound := exec_ubound(variable_name, 1);
image := getImageFromArray(variable_name & "(", ")", lbound, ubound);
else
ubound := exec_ubound(name_start[ .. pred(length(name_start))], 1);
image := getImageFromArray(name_start, name_end, lbound, ubound);
end if;
end func;
const proc: exec_screen (inout string: symbol, inout string: line) is func
local
var integer: newScreenMode is 0;
var integer: colorswitch is 0;
var integer: active is 0;
var integer: visible is 0;
begin
symbol := get_symbol(line);
newScreenMode := round(exec_expr(symbol, line));
if symbol = "," then
symbol := get_symbol(line);
if symbol <> "," then
colorswitch := round(exec_expr(symbol, line));
end if;
end if;
if symbol = "," then
symbol := get_symbol(line);
if symbol <> "," then
active := round(exec_expr(symbol, line));
end if;
end if;
if symbol = "," then
symbol := get_symbol(line);
if symbol <> "," then
visible := round(exec_expr(symbol, line));
end if;
end if;
if newScreenMode <> screenMode then
case newScreenMode of
when {0}:
scr := open(CONSOLE);
win := openWindow(scr, 1, 1, TEXT_LINES, TEXT_COLUMNS);
KEYBOARD := CONSOLE_KEYBOARD;
OUT := win;
IN := openEcho(KEYBOARD, OUT);
IN := openLine(IN);
screenMode := newScreenMode;
when {1}:
screen(320, 200);
win := open(curr_win, 8);
screenMode := newScreenMode;
when {2}:
screen(640, 200);
win := open(curr_win, 8);
screenMode := newScreenMode;
when {7}:
screen(320, 200);
win := open(curr_win, 8);
screenMode := newScreenMode;
when {8}:
screen(640, 200);
win := open(curr_win, 8);
screenMode := newScreenMode;
when {9}:
screen(640, 350);
win := open(curr_win, 14);
screenMode := newScreenMode;
when {10}:
screen(640, 350);
win := open(curr_win, 14);
screenMode := newScreenMode;
when {11}:
screen(640, 480);
win := open(curr_win, 16);
screenMode := newScreenMode;
when {12}:
screen(640, 480);
win := open(curr_win, 16);
screenMode := newScreenMode;
when {13}:
screen(320, 200);
win := open(curr_win, 16);
screenMode := newScreenMode;
otherwise:
error_marker;
writeln(err, "ILLEGAL SCREEN NUMBER: " <& newScreenMode);
end case;
if screenMode <> 0 and curr_win <> PRIMITIVE_WINDOW.value then
clear(curr_win, white);
color(white, black);
scr := open(curr_win);
KEYBOARD := GRAPH_KEYBOARD;
OUT := win;
IN := openEcho(KEYBOARD, OUT);
IN := openLine(IN);
end if;
end if;
line_marker;
writeln(log, "SCREEN " <& newScreenMode <& ", " <&
colorswitch <& ", " <& active <& ", " <& visible);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
end func;
const proc: exec_pset (inout string: symbol, inout string: line) is func
local
var integer: col is 0;
begin
symbol := get_symbol(line);
if symbol = "STEP" then
symbol := get_symbol(line);
expect("(", symbol, line);
currX +:= round(exec_expr(symbol, line));
expect(",", symbol, line);
currY +:= round(exec_expr(symbol, line));
expect(")", symbol, line);
else
expect("(", symbol, line);
currX := round(exec_expr(symbol, line));
expect(",", symbol, line);
currY := round(exec_expr(symbol, line));
expect(")", symbol, line);
end if;
if symbol = "," then
symbol := get_symbol(line);
col := round(exec_expr(symbol, line));
else
col := foreground_color;
end if;
point(currX, currY, color_num(col));
flushGraphic;
line_marker;
writeln(log, "PSET (" <& currX <& ", " <& currY <& "), " <& col);
end func;
const proc: exec_preset (inout string: symbol, inout string: line) is func
local
var integer: col is 0;
begin
symbol := get_symbol(line);
if symbol = "STEP" then
symbol := get_symbol(line);
expect("(", symbol, line);
currX +:= round(exec_expr(symbol, line));
expect(",", symbol, line);
currY +:= round(exec_expr(symbol, line));
expect(")", symbol, line);
else
expect("(", symbol, line);
currX := round(exec_expr(symbol, line));
expect(",", symbol, line);
currY := round(exec_expr(symbol, line));
expect(")", symbol, line);
end if;
if symbol = "," then
symbol := get_symbol(line);
col := round(exec_expr(symbol, line));
else
col := background_color;
end if;
point(currX, currY, color_num(col));
flushGraphic;
line_marker;
writeln(log, "PRESET (" <& currX <& ", " <& currY <& "), " <& col);
end func;
const proc: exec_line (inout string: symbol, inout string: line) is func
local
var string: param1 is "";
var integer: x1 is 0;
var integer: y1 is 0;
var integer: col is 0;
var boolean: style_present is FALSE;
var integer: style is 0;
begin
if symbol = "STEP" then
symbol := get_symbol(line);
expect("(", symbol, line);
x1 := currX + round(exec_expr(symbol, line));
expect(",", symbol, line);
y1 := currY + round(exec_expr(symbol, line));
expect(")", symbol, line);
elsif symbol = "-" then
x1 := currX;
y1 := currY;
else
expect("(", symbol, line);
x1 := round(exec_expr(symbol, line));
expect(",", symbol, line);
y1 := round(exec_expr(symbol, line));
expect(")", symbol, line);
end if;
expect("-", symbol, line);
if symbol = "STEP" then
symbol := get_symbol(line);
expect("(", symbol, line);
currX := x1 + round(exec_expr(symbol, line));
expect(",", symbol, line);
currY := y1 + round(exec_expr(symbol, line));
else
expect("(", symbol, line);
currX := round(exec_expr(symbol, line));
expect(",", symbol, line);
currY := round(exec_expr(symbol, line));
end if;
expect(")", symbol, line);
col := foreground_color;
if symbol = "," then
symbol := get_symbol(line);
if symbol <> "," then
col := round(exec_expr(symbol, line));
end if;
if symbol = "," then
symbol := get_symbol(line);
if symbol <> "," then
param1 := symbol;
symbol := get_symbol(line);
end if;
if symbol = "," then
symbol := get_symbol(line);
style := round(exec_expr(symbol, line));
style_present := TRUE;
end if;
end if;
end if;
if param1 = "BF" then
rectTo(x1, y1, currX, currY, color_num(col));
elsif param1 = "B" then
boxTo(x1, y1, currX, currY, color_num(col));
else
lineTo(x1, y1, currX, currY, color_num(col));
end if;
flushGraphic;
line_marker;
write(log, "LINE (" <& x1 <& ", " <& y1 <&
") - (" <& currX <& ", " <& currY <& "), " <& col);
if param1 <> "" then
write(log, ", " <& param1);
elsif style_present then
write(log, ", ");
end if;
if style_present then
write(log, ", " <& style);
end if;
writeln(log);
end func;
const proc: exec_circle (inout string: symbol, inout string: line) is func
local
var integer: radius is 0;
var integer: col is 0;
var integer: start is 0;
var integer: stop is 0;
var integer: aspect is 0;
begin
symbol := get_symbol(line);
if symbol = "STEP" then
symbol := get_symbol(line);
expect("(", symbol, line);
currX +:= round(exec_expr(symbol, line));
expect(",", symbol, line);
currY +:= round(exec_expr(symbol, line));
else
expect("(", symbol, line);
currX := round(exec_expr(symbol, line));
expect(",", symbol, line);
currY := round(exec_expr(symbol, line));
end if;
expect(")", symbol, line);
expect(",", symbol, line);
radius := round(exec_expr(symbol, line));
col := foreground_color;
if symbol = "," then
symbol := get_symbol(line);
if symbol <> "," then
col := round(exec_expr(symbol, line));
end if;
end if;
if symbol = "," then
symbol := get_symbol(line);
if symbol <> "," then
start := round(exec_expr(symbol, line));
end if;
end if;
if symbol = "," then
symbol := get_symbol(line);
if symbol <> "," then
stop := round(exec_expr(symbol, line));
end if;
end if;
if symbol = "," then
symbol := get_symbol(line);
if symbol <> "," then
aspect := round(exec_expr(symbol, line));
end if;
end if;
circle(currX, currY, radius, color_num(col));
flushGraphic;
line_marker;
writeln(log, "CIRCLE (" <& currX <& ", " <& currY <& "), " <&
radius <& ", " <& col);
end func;
const proc: exec_put (inout string: symbol, inout string: line) is func
local
var integer: x1 is 0;
var integer: y1 is 0;
var string: variable_name is "";
var PRIMITIVE_WINDOW: image is PRIMITIVE_WINDOW.value;
begin
expect("(", symbol, line);
x1 := round(exec_expr(symbol, line));
expect(",", symbol, line);
y1 := round(exec_expr(symbol, line));
expect(")", symbol, line);
expect(",", symbol, line);
variable_name := get_name(symbol, line);
if symbol = "," then
symbol := get_symbol(line);
symbol := get_symbol(line);
end if;
if variable_name in image_var then
image := image_var[variable_name];
else
image := getImageFromArray(variable_name);
if image <> PRIMITIVE_WINDOW.value then
line_marker;
writeln(log, "LOAD IMAGE VARIABLE FROM ARRAY " <& literal(variable_name));
image_var @:= [variable_name] image;
else
error_marker;
writeln(err, "CANNOT LOAD IMAGE VARIABLE FROM ARRAY " <& literal(variable_name));
end if;
end if;
if image <> PRIMITIVE_WINDOW.value then
line_marker;
writeln(log, "PUT (" <& x1 <& ", " <& y1 <& "), " <& variable_name);
put(x1, y1, image);
else
error_marker;
writeln(err, "UNDEFINED IMAGE VARIABLE " <& literal(variable_name));
end if;
end func;
const proc: exec_get (inout string: symbol, inout string: line) is func
local
var integer: x1 is 0;
var integer: y1 is 0;
var integer: x2 is 0;
var integer: y2 is 0;
var integer: help is 0;
var string: variable_name is "";
var PRIMITIVE_WINDOW: image is PRIMITIVE_WINDOW.value;
begin
expect("(", symbol, line);
x1 := round(exec_expr(symbol, line));
expect(",", symbol, line);
y1 := round(exec_expr(symbol, line));
expect(")", symbol, line);
expect("-", symbol, line);
if symbol = "STEP" then
symbol := get_symbol(line);
expect("(", symbol, line);
x2 := x1 + round(exec_expr(symbol, line));
expect(",", symbol, line);
y2 := y1 + round(exec_expr(symbol, line));
else
expect("(", symbol, line);
x2 := round(exec_expr(symbol, line));
expect(",", symbol, line);
y2 := round(exec_expr(symbol, line));
end if;
expect(")", symbol, line);
expect(",", symbol, line);
variable_name := get_name(symbol, line);
if x1 > x2 or y1 > y2 then
error_marker;
write(err, "GET (" <& x1 <& ", " <& y1 <&
") - (" <& x2 <& ", " <& y2 <& ") = ");
end if;
if x1 > x2 and y1 > y2 then
writeln(err, "GET (LOWER RIGHT) - (UPPER LEFT)");
help := x1;
x1 := x2;
x2 := help;
help := y1;
y1 := y2;
y2 := help;
elsif x1 > x2 then
writeln(err, "GET (UPPER RIGHT) - (LOWER LEFT)");
help := x1;
x1 := x2;
x2 := help;
elsif y1 > y2 then
writeln(err, "GET (LOWER LEFT) - (UPPER RIGHT)");
help := y1;
y1 := y2;
y2 := help;
end if;
image := getPixmap(x1, y1, x2 - x1 + 1, y2 - y1 + 1);
image_var @:= [variable_name] image;
line_marker;
writeln(log, "GET (" <& x1 <& ", " <& y1 <&
") - (" <& x2 <& ", " <& y2 <& "), " <& variable_name);
end func;
const func string: getChar (inout string: stri) is func
result
var string: symbol is "";
begin
symbol := stri[1 len 1];
stri := stri[2 ..];
end func;
const func string: getSign (inout string: stri) is func
result
var string: symbol is "";
begin
symbol := stri[1 len 1];
if symbol = "+" or symbol = "-" then
stri := stri[2 ..];
else
symbol := "";
end if;
end func;
const proc: exec_draw (inout string: symbol, inout string: line) is func
local
var string: cmdStri is "";
var string: unused_name is "";
var integer: xPos is 1;
var integer: yPos is 1;
var integer: xOld is 1;
var integer: yOld is 1;
var char: currCmd is ' ';
var string: param1 is "";
var string: sign is "";
var integer: num1 is 0;
var integer: num2 is 0;
var boolean: pen_down is TRUE;
var boolean: move_back is FALSE;
var integer: scale_factor is 1;
var integer: turn_factor is 0;
begin
symbol := get_symbol(line);
cmdStri := exec_str_expr(symbol, line, unused_name);
line_marker;
writeln(log, "**DRAW " <& literal(cmdStri));
skipWhiteSpace(cmdStri);
while cmdStri <> "" do
currCmd := upper(getChar(cmdStri)[1]);
skipWhiteSpace(cmdStri);
if currCmd = 'B' then
pen_down := FALSE;
writeln(log, "B - PEN UP");
if cmdStri <> "" then
currCmd := upper(getChar(cmdStri)[1]);
else
currCmd := ' ';
end if;
skipWhiteSpace(cmdStri);
elsif currCmd = 'N' then
move_back := TRUE;
if cmdStri <> "" then
currCmd := upper(getChar(cmdStri)[1]);
else
currCmd := ' ';
end if;
skipWhiteSpace(cmdStri);
end if;
xOld := xPos;
yOld := yPos;
case currCmd of
when {' '}:
noop;
when {'U'}:
param1 := getDigits(cmdStri);
if param1 <> "" then
yPos -:= scale_factor * integer(param1);
if pen_down then
lineTo(xOld, yOld, xPos, yPos, color_num(foreground_color));
end if;
end if;
when {'D'}:
param1 := getDigits(cmdStri);
if param1 <> "" then
yPos +:= scale_factor * integer(param1);
if pen_down then
lineTo(xOld, yOld, xPos, yPos, color_num(foreground_color));
end if;
end if;
when {'L'}:
param1 := getDigits(cmdStri);
if param1 <> "" then
xPos -:= scale_factor * integer(param1);
if pen_down then
lineTo(xOld, yOld, xPos, yPos, color_num(foreground_color));
end if;
end if;
when {'R'}:
param1 := getDigits(cmdStri);
if param1 <> "" then
xPos +:= scale_factor * integer(param1);
if pen_down then
lineTo(xOld, yOld, xPos, yPos, color_num(foreground_color));
end if;
end if;
when {'E'}:
param1 := getDigits(cmdStri);
if param1 <> "" then
num1 := integer(param1);
xPos +:= scale_factor * num1;
yPos -:= scale_factor * num1;
if pen_down then
lineTo(xOld, yOld, xPos, yPos, color_num(foreground_color));
end if;
end if;
when {'F'}:
param1 := getDigits(cmdStri);
if param1 <> "" then
num1 := integer(param1);
xPos +:= scale_factor * num1;
yPos +:= scale_factor * num1;
if pen_down then
lineTo(xOld, yOld, xPos, yPos, color_num(foreground_color));
end if;
end if;
when {'G'}:
param1 := getDigits(cmdStri);
if param1 <> "" then
num1 := integer(param1);
xPos -:= scale_factor * num1;
yPos +:= scale_factor * num1;
if pen_down then
lineTo(xOld, yOld, xPos, yPos, color_num(foreground_color));
end if;
end if;
when {'H'}:
param1 := getDigits(cmdStri);
if param1 <> "" then
num1 := integer(param1);
xPos -:= scale_factor * num1;
yPos -:= scale_factor * num1;
if pen_down then
lineTo(xOld, yOld, xPos, yPos, color_num(foreground_color));
end if;
end if;
when {'M'}:
skipWhiteSpace(cmdStri);
sign := getSign(cmdStri);
param1 := getDigits(cmdStri);
if param1 <> "" then
num1 := integer(param1);
if sign = "" then
xPos := scale_factor * num1;
else
xPos -:= scale_factor * num1;
end if;
skipWhiteSpace(cmdStri);
param1 := getChar(cmdStri);
if param1 = "," then
skipWhiteSpace(cmdStri);
sign := getSign(cmdStri);
param1 := getDigits(cmdStri);
if param1 <> "" then
num2 := integer(param1);
if sign = "" then
yPos := scale_factor * num2;
else
yPos -:= scale_factor * num2;
end if;
if pen_down then
lineTo(xOld, yOld, xPos, yPos, color_num(foreground_color));
end if;
writeln(log, "MOVE");
end if;
end if;
end if;
when {'C'}:
param1 := getDigits(cmdStri);
if param1 <> "" then
foreground_color := integer(param1);
writeln(log, "COLOR " <& foreground_color);
end if;
when {'S'}:
param1 := getDigits(cmdStri);
if param1 <> "" then
scale_factor := integer(param1);
writeln(log, "SCALE " <& scale_factor);
end if;
when {'T'}:
currCmd := upper(getChar(cmdStri)[1]);
if currCmd = 'A' then
param1 := getDigits(cmdStri);
if param1 <> "" then
turn_factor := integer(param1);
writeln(log, "TURN ANGLE " <& turn_factor);
end if;
end if;
when {'\3;'}:
num1 := bytes2Int(cmdStri[1 fixLen 2], UNSIGNED, LE);
param1 := varname(num1);
cmdStri := getStringVar(param1) & cmdStri[3 ..];
writeln(log, "VARPTR$(" <& param1 <& ")");
end case;
pen_down := TRUE;
move_back := FALSE;
end while;
end func;
const proc: exec_plot (inout string: symbol, inout string: line) is func
local
var integer: currX is 0;
var integer: currY is 0;
var integer: col is 0;
begin
currX := round(exec_expr(symbol, line));
expect(",", symbol, line);
currY := round(exec_expr(symbol, line));
col := round(getNumericVar("COLOR"));
point(currX, currY, loresColor[col mod length(loresColor)]);
flushGraphic;
line_marker;
writeln(log, "PLOT " <& currX <& ", " <& currY);
end func;
const proc: exec_hplot (inout string: symbol, inout string: line) is func
local
var integer: col is 0;
var integer: currX is 0;
var integer: currY is 0;
var integer: destX is 0;
var integer: destY is 0;
begin
col := round(getNumericVar("HCOLOR"));
currX := round(exec_expr(symbol, line));
expect(",", symbol, line);
currY := round(exec_expr(symbol, line));
if symbol = "TO" then
repeat
symbol := get_symbol(line);
destX := round(exec_expr(symbol, line));
expect(",", symbol, line);
destY := round(exec_expr(symbol, line));
lineTo(currX, currY, destX, destY,
hiresColor[col mod length(hiresColor)]);
flushGraphic;
line_marker;
writeln(log, "HPLOT " <& currX <& ", " <& currY <&
" TO " <& destX <& ", " <& destY);
currX := destX;
currY := destY;
until symbol <> "TO";
else
point(currX, currY, hiresColor[col mod length(hiresColor)]);
flushGraphic;
line_marker;
writeln(log, "HPLOT " <& currX <& ", " <& currY);
end if;
end func;
const proc: setup_graphic is func
begin
if screenMode <> -1 then
screen(1024, 768);
clear(curr_win, light_cyan);
win := openPixmapFontFile(curr_win);
color(win, black, light_cyan);
KEYBOARD := GRAPH_KEYBOARD;
OUT := win;
IN := openEcho(KEYBOARD, win);
IN := openLine(IN);
scale(win, 4);
currentFont := font8x8;
setFont(win, currentFont);
screenMode := -1;
end if;
end func;
const proc: exec_call_char (inout string: symbol, inout string: line) is func
local
var integer: character_code is 0;
var string: patternArgument is "";
var string: unused_name is "";
var array string: charPicture is 8 times " " mult 8;
var integer: patternStartPos is 1;
var char: patternChar is ' ';
var string: pattern is "";
var integer: pos is 0;
var integer: patternLine is 1;
var boolean: right is FALSE;
var integer: number is 0;
var integer: bit is 0;
begin
setup_graphic;
symbol := get_symbol(line);
expect("(", symbol, line);
character_code := round(exec_expr(symbol, line));
expect(",", symbol, line);
patternArgument := exec_str_expr(symbol, line, unused_name);
expect(")", symbol, line);
patternChar := chr(character_code);
repeat
pattern := patternArgument[patternStartPos len 16];
patternLine := 1;
for pos range 1 to length(pattern) do
number := integer(pattern[pos fixLen 1], 16);
for bit range 1 to 4 do
if odd(number) then
charPicture[patternLine] @:= [ord(right) * 4 + 5 - bit] 'X';
end if;
number >>:= 1;
end for;
if right then
incr(patternLine);
end if;
right := not right;
end for;
currentFont.fontPictures @:= [patternChar] charPicture;
setFont(win, currentFont);
patternStartPos +:= 16;
incr(patternChar);
until patternStartPos > length(patternArgument);
line_marker;
writeln(log, "CALL CHAR(" <& character_code <& ", " <& literal(patternArgument) <& ")");
end func;
const proc: exec_call_clear (inout string: symbol, inout string: line) is func
begin
setup_graphic;
symbol := get_symbol(line);
clear(curr_win, light_cyan);
line_marker;
writeln(log, "CALL CLEAR");
end func;
const proc: exec_call_color (inout string: symbol, inout string: line) is func
local
var integer: character_set is 0;
var integer: foreground is 0;
var integer: background is 0;
var boolean: done is FALSE;
begin
setup_graphic;
symbol := get_symbol(line);
expect("(", symbol, line);
if symbol = "#" then
repeat
symbol := get_symbol(line);
character_set := round(exec_expr(symbol, line));
expect(",", symbol, line);
foreground := round(exec_expr(symbol, line));
line_marker;
writeln(log, "CALL COLOR(#" <& character_set <& ", " <&
foreground <& ")");
until symbol <> ",";
else
repeat
character_set := round(exec_expr(symbol, line));
expect(",", symbol, line);
foreground := round(exec_expr(symbol, line));
expect(",", symbol, line);
background := round(exec_expr(symbol, line));
line_marker;
writeln(log, "CALL COLOR(" <& character_set <& ", " <&
foreground <& ", " <& background <& ")");
if symbol = "," then
symbol := get_symbol(line);
else
done := TRUE;
end if;
until done;
end if;
expect(")", symbol, line);
end func;
const proc: exec_call_hchar (inout string: symbol, inout string: line) is func
local
var integer: row is 0;
var integer: column is 0;
var integer: character_code is 0;
var integer: repetition is 1;
begin
setup_graphic;
symbol := get_symbol(line);
expect("(", symbol, line);
row := round(exec_expr(symbol, line));
expect(",", symbol, line);
column := round(exec_expr(symbol, line));
expect(",", symbol, line);
character_code := round(exec_expr(symbol, line));
if symbol = "," then
symbol := get_symbol(line);
repetition := round(exec_expr(symbol, line));
end if;
expect(")", symbol, line);
for repetition do
setPos(win, row, column);
write(win, chr(character_code));
if column < 32 then
incr(column);
else
incr(row);
column := 1;
end if;
end for;
line_marker;
writeln(log, "CALL HCHAR(" <& row <& ", " <& column <& ", " <&
character_code <& ", " <& repetition <& ")");
end func;
const proc: exec_call_key (inout string: symbol, inout string: line) is func
local
var integer: key_unit is 0;
var string: return_variable is "";
var string: status_variable is "";
begin
setup_graphic;
symbol := get_symbol(line);
expect("(", symbol, line);
key_unit := round(exec_expr(symbol, line));
expect(",", symbol, line);
return_variable := get_name(symbol, line);
expect(",", symbol, line);
status_variable := get_name(symbol, line);
expect(")", symbol, line);
if inputReady(KEYBOARD) then
setNumericVar(return_variable, flt(ord(getc(KEYBOARD))));
setNumericVar(status_variable, 1.0);
else
setNumericVar(return_variable, -1.0);
setNumericVar(status_variable, 0.0);
end if;
line_marker;
writeln(log, "CALL KEY(" <& key_unit <& ", " <& return_variable <& ", " <& status_variable <& ")");
end func;
const proc: exec_call_screen (inout string: symbol, inout string: line) is func
local
var integer: color_code is 0;
begin
setup_graphic;
symbol := get_symbol(line);
expect("(", symbol, line);
color_code := round(exec_expr(symbol, line));
expect(")", symbol, line);
line_marker;
writeln(log, "CALL SCREEN(" <& color_code <& ")");
end func;
const proc: exec_call_sound (inout string: symbol, inout string: line) is func
local
var float: duration is 0.0;
var integer: frequency is 0;
var integer: volume is 0;
begin
symbol := get_symbol(line);
expect("(", symbol, line);
duration := exec_expr(symbol, line);
expect(",", symbol, line);
frequency := round(exec_expr(symbol, line));
expect(",", symbol, line);
volume := round(exec_expr(symbol, line));
expect(")", symbol, line);
line_marker;
writeln(log, "CALL SOUND(" <& duration <& ", " <& frequency <& ", " <& volume <& ")");
end func;
const proc: exec_call_vchar (inout string: symbol, inout string: line) is func
local
var integer: row is 0;
var integer: column is 0;
var integer: character_code is 0;
var integer: repetition is 1;
begin
setup_graphic;
symbol := get_symbol(line);
expect("(", symbol, line);
row := round(exec_expr(symbol, line));
expect(",", symbol, line);
column := round(exec_expr(symbol, line));
expect(",", symbol, line);
character_code := round(exec_expr(symbol, line));
if symbol = "," then
symbol := get_symbol(line);
repetition := round(exec_expr(symbol, line));
end if;
expect(")", symbol, line);
for repetition do
setPos(win, row, column);
write(win, chr(character_code));
if row < 24 then
incr(row);
else
incr(column);
row := 1;
end if;
end for;
line_marker;
writeln(log, "CALL VCHAR(" <& row <& ", " <& column <& ", " <&
character_code <& ", " <& repetition <& ")");
end func;
const proc: exec_let (inout string: symbol, inout string: line,
inout boolean: process_next) is func
local
var boolean: is_let_statement is TRUE;
var string: variable_name is "";
var string: unused_name is "";
var string: backup_line is "";
var string: param1 is "";
var float: num1 is 0.0;
begin
if symbol = "LET" then
symbol := get_symbol(line);
elsif not is_let_statement(line) then
is_let_statement := FALSE;
if startsWith(symbol, "REM") then
line_marker;
writeln(log, "REM " <& symbol <& line);
symbol := "";
elsif startsWith(symbol, "IF") then
line := symbol[3 ..] & line;
exec_if(symbol, line, process_next);
elsif startsWith(symbol, "GOTO") then
line := symbol[5 ..] & line;
exec_goto(symbol, line);
elsif startsWith(symbol, "GOSUB") then
line := symbol[6 ..] & line;
exec_gosub(symbol, line);
elsif startsWith(symbol, "ELSE") and not startsWith(symbol, "ELSEIF") then
line := symbol[5 ..] & line;
exec_else(symbol, line);
elsif startsWith(symbol, "NEXT") then
line := symbol[5 ..] & line;
exec_next(symbol, line);
elsif startsWith(symbol, "ON") then
line := symbol[3 ..] & line;
exec_on(symbol, line);
elsif startsWith(symbol, "PRINT") then
line := symbol[6 ..] & line;
symbol := get_symbol(line);
exec_print(symbol, line);
elsif startsWith(symbol, "LPRINT") then
line := symbol[7 ..] & line;
symbol := get_symbol(line);
exec_print(symbol, line);
elsif startsWith(symbol, "INPUT") then
line := symbol[6 ..] & line;
symbol := get_symbol(line);
exec_input(symbol, line);
elsif startsWith(symbol, "READ") then
line := symbol[5 ..] & line;
exec_read(symbol, line);
elsif startsWith(symbol, "CLEAR") then
line := symbol[6 ..] & line;
exec_clear(symbol, line);
elsif startsWith(symbol, "DIM") then
line := symbol[4 ..] & line;
exec_dim(symbol, line);
elsif symbol in label then
param1 := symbol;
symbol := get_symbol(line);
if symbol = ":" then
line_marker;
writeln(log, "SKIP LABEL: " <& param1);
else
error_marker;
writeln(err, "COLON EXPECTED AFTER LABEL " <& param1 <&
" - FOUND " <& literal(symbol) <& ".");
end if;
elsif symbol in usedLabel and symbol in multipleDefinedLabel then
param1 := symbol;
symbol := get_symbol(line);
if symbol = ":" then
line_marker;
writeln(log, "SKIP MULTIPLE DEFINED LABEL: " <& param1);
else
error_marker;
writeln(err, "COLON EXPECTED AFTER LABEL " <& param1 <&
" - FOUND " <& literal(symbol) <& ".");
end if;
else
is_let_statement := TRUE;
end if;
end if;
if is_let_statement then
if isStringVar(symbol) then
backup_line := symbol & line;
variable_name := get_name(symbol, line);
backup_line := backup_line[.. length(backup_line) - length(line)];
if symbol = "=" then
symbol := get_symbol(line);
param1 := exec_str_expr(symbol, line, unused_name);
if startsWith(variable_name, "IF") and startsWith(symbol, "THEN") then
line := backup_line[3 ..] & "\"" & param1 & "\"" & symbol & line;
line_marker;
writeln(log, "IF RECOGNIZED: IF " <& literal(line));
exec_if(symbol, line, process_next);
else
setStringVar(variable_name, param1);
line_marker;
writeln(log, "LET " <& variable_name <& "=" <& literal(param1));
end if;
else
error_marker;
writeln(err, "\"=\" EXPECTED AFTER " <& literal(variable_name) <&
" - FOUND " <& literal(symbol) <& ".");
end if;
elsif isNumericVar(symbol) then
variable_name := get_name(symbol, line);
if symbol = "=" then
symbol := get_symbol(line);
num1 := exec_expr(symbol, line);
if startsWith(variable_name, "IF") and startsWith(symbol, "THEN") then
line := variable_name[3 ..] & "=" & str(num1) & symbol & line;
line_marker;
writeln(log, "IF RECOGNIZED: IF " <& literal(line));
exec_if(symbol, line, process_next);
elsif startsWith(variable_name, "FOR") and startsWith(symbol, "TO") then
line := variable_name[4 ..] & "=" & str(num1) & symbol & line;
line_marker;
writeln(log, "FOR RECOGNIZED: FOR " <& literal(line));
exec_for(symbol, line);
else
setNumericVar(variable_name, num1);
line_marker;
writeln(log, "LET " <& variable_name <& "=" <& num1);
end if;
else
error_marker;
writeln(err, "\"=\" EXPECTED AFTER " <& literal(variable_name) <&
" - FOUND " <& literal(symbol) <& ".");
end if;
else
error_marker;
writeln(err, "VARIABLE EXPECTED - FOUND " <& literal(symbol) <& ".");
end if;
end if;
end func;
const func boolean: runOrChain (in string: cmd, in string: name) is forward;
const func boolean: execCmd (inout string: symbol, inout string: line) is func
result
var boolean: running is TRUE;
local
var string: variable_name is "";
var string: variable2_name is "";
var string: unused_name is "";
var string: param1 is "";
var string: param2 is "";
var string: param3 is "";
var float: num1 is 0.0;
var float: num2 is 0.0;
var integer: index1 is 0;
var integer: index2 is 0;
var integer: index3 is 0;
var char: current_key is ' ';
var boolean: okay is FALSE;
var boolean: process_next is FALSE;
begin
repeat
process_next := FALSE;
case symbol of
when {""}:
noop;
when {"BEEP"}:
symbol := get_symbol(line);
line_marker;
writeln(log, "**BEEP");
when {"BLOAD"}:
exec_bload(symbol, line);
when {"CALL"}:
symbol := get_symbol(line);
if symbol in subprogram then
line_marker;
writeln(log, "CALL " <& symbol);
advance_after_statement(line);
set_return_position(line);
gosubReturn[1].subName := symbol;
file_line_number := subprogram[symbol];
statement_label := prg[file_line_number].label;
line := prg[file_line_number].line;
symbol := get_symbol(line);
symbol := get_symbol(line);
set_sub_entry_position;
line_marker;
writeln(log, "EXECUTE SUB " <& symbol);
elsif symbol in sub_declared then
error_marker;
writeln(err, "CALL DECLARED BUT UNDEFINED SUB " <& symbol);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
elsif symbol = "+" or symbol = "-" or
symbol <> "" and symbol[1] in digit_char then
index1 := round(exec_expr(symbol, line));
error_marker;
writeln(err, "CALL UNDEFINED SUB " <& index1 <& ".");
elsif symbol = "CHAR" then
exec_call_char(symbol, line);
elsif symbol = "CLEAR" then
exec_call_clear(symbol, line);
elsif symbol = "COLOR" then
exec_call_color(symbol, line);
elsif symbol = "HCHAR" then
exec_call_hchar(symbol, line);
elsif symbol = "KEY" then
exec_call_key(symbol, line);
elsif symbol = "SCREEN" then
exec_call_screen(symbol, line);
elsif symbol = "SOUND" then
exec_call_sound(symbol, line);
elsif symbol = "VCHAR" then
exec_call_vchar(symbol, line);
else
error_marker;
writeln(err, "CALL UNDEFINED SUB " <& literal(symbol) <& ".");
end if;
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
when {"CASE"}:
line_marker;
writeln(log, "CASE - SKIP TO \"END SELECT\"");
symbol := find_end_select(line);
if symbol = "SELECT" then
symbol := get_symbol(line);
line_marker;
writeln(log, "END SELECT");
else
error_marker;
writeln(err, "NO CORRESPONDING \"END SELECT\" FOUND");
end if;
when {"CHAIN"}:
symbol := get_symbol(line);
if isStringExpr(symbol) then
param1 := exec_str_expr(symbol, line, variable_name);
if runOrChain("CHAIN", param1) then
writeln(log, "load program finished");
line_marker;
writeln(log, "CHAIN " <& literal(param1) <& " - " <&
length(prg) <& " LINES");
file_line_number := 0;
data_line_number := 0;
symbol := "";
line := "";
elsif on_error_label <> "" then
symbol := get_symbol(line);
error_code := 53;
line_marker;
writeln(log, error_code <& " CHAIN " <& literal(param1) <&
" - FILE NOT FOUND - ON ERROR GOTO " <& on_error_label);
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "CHAIN " <& literal(param1) <& " - FILE NOT FOUND.");
end if;
else
error_marker;
writeln(err, "STRING EXPECTED FOR CHAIN - FOUND " <& symbol <& ".");
end if;
when {"CIRCLE"}:
exec_circle(symbol, line);
when {"CLEAR"}:
exec_clear(symbol, line);
when {"CLOSE", "CLOSE#"}:
exec_close(symbol, line);
when {"CLS"}:
symbol := get_symbol(line);
if symbol = "0" or symbol = "1" or symbol = "2" then
symbol := get_symbol(line);
end if;
clear(win);
setPos(win, 1, 1);
line_marker;
writeln(log, "CLS");
when {"COLOR"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("COLOR", symbol, line);
elsif symbol = ":" and "COLOR" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: COLOR");
else
if symbol <> "," then
foreground_color := round(exec_expr(symbol, line));
end if;
if symbol = "," then
symbol := get_symbol(line);
background_color := round(exec_expr(symbol, line));
if symbol = "," then
symbol := get_symbol(line);
index1 := round(exec_expr(symbol, line));
end if;
end if;
line_marker;
writeln(log, "**COLOR " <& foreground_color <& "," <& background_color);
end if;
when {"COMMON"}:
line_marker;
writeln(log, "**COMMON " <& line);
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
when {"CONST"}:
repeat
symbol := get_symbol(line);
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
if symbol = "=" then
symbol := get_symbol(line);
param3 := exec_str_expr(symbol, line, unused_name);
setStringVar(variable_name, param3);
line_marker;
writeln(log, "CONST " <& variable_name <& "=" <& literal(param3));
else
error_marker;
writeln(err, "\"=\" EXPECTED AFTER " <& literal(variable_name) <&
" - FOUND " <& literal(symbol) <& ".");
end if;
elsif isNumericVar(symbol) then
variable_name := get_name(symbol, line);
if symbol = "=" then
symbol := get_symbol(line);
num1 := exec_expr(symbol, line);
setNumericVar(variable_name, num1);
line_marker;
writeln(log, "CONST " <& variable_name <& "=" <& num1);
else
error_marker;
writeln(err, "\"=\" EXPECTED AFTER " <& literal(variable_name) <&
" - FOUND " <& literal(symbol) <& ".");
end if;
else
error_marker;
writeln(err, "VARIABLE EXPECTED - FOUND " <& literal(symbol) <& ".");
end if;
until symbol <> ",";
when {"DATA", "DATA&"}:
symbol := "";
line_marker;
writeln(log, "DATA");
when {"DECLARE"}:
symbol := get_symbol(line);
if symbol = "SUB" then
symbol := get_symbol(line);
sub_declared @:= [symbol] file_line_number;
line_marker;
writeln(log, "**DECLARE SUB " <& symbol <& " " <& line);
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
elsif symbol = "FUNCTION" then
symbol := get_symbol(line);
line_marker;
writeln(log, "**DECLARE FUNCTION " <& symbol <& " " <& line);
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
else
error_marker;
writeln(err, "ILLEGAL DECLARE " <& symbol);
end if;
when {"DECR"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("DECR", symbol, line);
elsif symbol = ":" and "DECR" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: DECR");
else
variable_name := get_name(symbol, line);
if symbol = "," then
symbol := get_symbol(line);
num1 := exec_expr(symbol, line);
else
num1 := 1.0;
end if;
setNumericVar(variable_name, getNumericVar(variable_name) - num1);
line_marker;
writeln(log, "DECR " <& variable_name <& " BY " <& num1);
end if;
when {"DEF"}:
symbol := get_symbol(line);
if symbol = "SEG" then
symbol := get_symbol(line);
if symbol = "=" then
symbol := get_symbol(line);
if symbol = "VARSEG" then
symbol := get_symbol(line);
expect("(", symbol, line);
varseg_variable := get_name(symbol, line);
expect(")", symbol, line);
line_marker;
writeln(log, "**DEF SEG = VARSEG(" <& varseg_variable <& ")");
else
index1 := round(exec_expr(symbol, line));
line_marker;
writeln(log, "**DEF SEG = " <& index1);
end if;
else
line_marker;
writeln(log, "**DEF SEG");
end if;
else
variable_name := symbol;
if variable_name[1] >= 'A' and variable_name[1] <= 'Z' then
define_function(variable_name, symbol, line, TRUE);
end if;
end if;
when {"DEFDBL"}:
exec_defType_numeric(symbol, line);
when {"DEFINT"}:
exec_defType_numeric(symbol, line);
when {"DEFLNG"}:
exec_defType_numeric(symbol, line);
when {"DEFSNG"}:
exec_defType_numeric(symbol, line);
when {"DEFSTR"}:
exec_defstr(symbol, line);
when {"DELAY"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("DELAY", symbol, line);
elsif symbol = ":" and "DELAY" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: DELAY");
else
num1 := exec_expr(symbol, line);
flush(win);
delay(num1);
line_marker;
writeln(log, "DELAY " <& num1);
end if;
when {"DIM"}:
exec_dim(symbol, line);
when {"DISPLAY"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("DISPLAY", symbol, line);
elsif symbol = ":" and "DISPLAY" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: DISPLAY");
else
exec_display(symbol, line);
end if;
when {"DO"}:
exec_do(symbol, line);
when {"DRAW"}:
exec_draw(symbol, line);
when {"ELSE"}:
exec_else(symbol, line);
when {"ELSEIF"}:
line_marker;
writeln(log, "ELSEIF - THE \"THEN\" BLOCK BEFORE WAS EXECUTED");
symbol := find_end_if(line);
if symbol = "IF" then
symbol := get_symbol(line);
line_marker;
writeln(log, "END IF");
else
error_marker;
writeln(err, "ELSEIF - MISSING \"END IF\".");
end if;
when {"ENDIF"}:
symbol := get_symbol(line);
line_marker;
writeln(log, "END IF - THE \"THEN\" OR \"ELSE\" BLOCK BEFORE WAS EXECUTED");
when {"END"}:
symbol := get_symbol(line);
if symbol = "IF" then
symbol := get_symbol(line);
line_marker;
writeln(log, "END IF - THE \"THEN\" OR \"ELSE\" BLOCK BEFORE WAS EXECUTED");
elsif symbol = "SELECT" then
symbol := get_symbol(line);
line_marker;
writeln(log, "END SELECT");
elsif symbol = "SUB" then
if length(gosubReturn) >= 1 then
check_loop_stacks_before_return("END SUB " & gosubReturn[1].subName);
line_marker;
write(log, "END SUB " <& gosubReturn[1].subName <& " - RETURN TO ");
do_return(symbol, line);
line_marker;
writeln(log);
else
symbol := get_symbol(line);
error_marker;
writeln(err, "END SUB - RETURN WITHOUT CALL.");
end if;
elsif symbol = "FUNCTION" then
if length(gosubReturn) >= 1 then
check_loop_stacks_before_return("END FUNCTION " & gosubReturn[1].subName);
line_marker;
writeln(log, "END FUNCTION " <& gosubReturn[1].subName);
symbol := "";
running := FALSE;
else
symbol := get_symbol(line);
error_marker;
writeln(err, "END FUNCTION - RETURN WITHOUT CALL.");
end if;
elsif endOfStatement(symbol) then
line_marker;
writeln(log, "END");
symbol := "";
running := FALSE;
else
error_marker;
writeln(err, "UNEXPECTED SYMBOL AFTER END " <& literal(symbol));
end if;
when {"ERASE"}:
line_marker;
writeln(log, "**ERASE " <& line);
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
when {"ERROR"}:
symbol := get_symbol(line);
error_code := round(exec_expr(symbol, line));
if on_error_label <> "" then
line_marker;
writeln(log, "ERROR " <& error_code <&
" - ON ERROR GOTO " <& on_error_label);
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "ERROR " <& error_code <& " WITHOUT ON ERROR HANDLER.");
end if;
when {"EXIT"}:
symbol := get_symbol(line);
if symbol = "FOR" then
if length(forLoop) = 0 then
error_marker;
write(err, "EXIT FOR - NOT INSIDE \"FOR\" LOOP");
else
line_marker;
writeln(log, "EXIT FOR " <& forLoop[1].varName);
param1 := statement_label;
symbol := "";
if find_next(symbol, line, forLoop[1].varName) then
forLoop := forLoop[2 .. ];
else
error_marker(param1);
writeln(err, "NO CORRESPONDING \"NEXT\" OR \"NEXT " <&
forLoop[1].varName <& "\" FOUND FOR \"EXIT FOR\"");
end if;
end if;
elsif symbol = "DO" or symbol = "LOOP" then
param1 := statement_label;
symbol := find_loop(line);
if symbol = "LOOP" then
doLoop := doLoop[2 .. ];
line_marker;
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
writeln(log, "EXIT DO");
else
error_marker(param1);
writeln(err, "NO CORRESPONDING \"LOOP\" FOUND FOR \"EXIT DO\"");
end if;
elsif symbol = "SELECT" then
param1 := statement_label;
symbol := find_end_select(line);
if symbol = "SELECT" then
symbol := get_symbol(line);
line_marker;
writeln(log, "EXIT SELECT");
else
error_marker(param1);
writeln(err, "NO \"END SELECT\" FOUND");
end if;
elsif symbol = "SUB" then
if length(gosubReturn) >= 1 then
check_loop_stacks_before_return("EXIT SUB " & gosubReturn[1].subName);
line_marker;
write(log, "EXIT SUB " <& gosubReturn[1].subName <& " - RETURN TO ");
do_return(symbol, line);
line_marker;
writeln(log);
else
symbol := get_symbol(line);
error_marker;
writeln(err, "EXIT SUB - RETURN WITHOUT CALL.");
end if;
elsif symbol = "FUNCTION" then
if length(gosubReturn) >= 1 then
check_loop_stacks_before_return("EXIT FUNCTION " & gosubReturn[1].subName);
line_marker;
write(log, "EXIT FUNCTION " <& gosubReturn[1].subName <& " - RETURN TO ");
do_return(symbol, line);
line_marker;
writeln(log);
else
symbol := get_symbol(line);
error_marker;
writeln(err, "EXIT FUNCTION - RETURN WITHOUT CALL.");
end if;
else
error_marker;
writeln(err, "ILLEGAL STATEMENT \"EXIT " <& symbol <& "\"");
end if;
when {"FIELD", "FIELD#"}:
if symbol = "FIELD#" then
symbol := get_symbol(line);
else
symbol := get_symbol(line);
if symbol = "#" then
symbol := get_symbol(line);
end if;
end if;
index1 := round(exec_expr(symbol, line));
field_value[index1] := 0 times "";
while symbol = "," do
symbol := get_symbol(line);
index2 := round(exec_expr(symbol, line));
if symbol = "AS" then
symbol := get_symbol(line);
elsif startsWith(symbol, "AS") then
symbol := symbol[3 ..];
else
error_expect("AS", symbol);
end if;
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
setStringVar(variable_name, "" lpad index2);
field_value[index1] &:= [] (variable_name);
line_marker;
writeln(log, "FIELD #" <& index1 <& ", " <& index2 <&
" AS " <& variable_name);
else
error_marker;
writeln(err, "STRING VARIABLE EXPECTED AS FIELD - FOUND " <&
literal(symbol) <& ".");
end if;
end while;
when {"FILES"}:
exec_files(symbol, line);
when {"FLASH"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("FLASH", symbol, line);
elsif symbol = ":" and "FLASH" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: FLASH");
else
line_marker;
writeln(log, "**FLASH");
end if;
when {"FOR"}:
exec_for(symbol, line);
when {"FUNCTION"}:
symbol := get_symbol(line);
line_marker;
writeln(log, "SKIP FUNCTION " <& symbol);
symbol := find_end_function(line);
symbol := get_symbol(line);
line_marker;
writeln(log, "END SKIP FUNCTION " <& symbol <& " " <& line);
when {"GET", "GET#"}:
if symbol = "GET#" then
symbol := "#";
else
symbol := get_symbol(line);
end if;
if symbol = "(" or symbol = "STEP" then
exec_get(symbol, line);
elsif isStringVar(symbol) then
variable_name := get_name(symbol, line);
line_marker;
write(log, "GET " <& variable_name);
flush(log);
flush(win);
current_key := getc(KEYBOARD);
setStringVar(variable_name, str(current_key));
if current_key in keyDescription then
write(log, " (" <& keyDescription[current_key] <& ")");
end if;
writeln(log);
else
exec_file_get(symbol, line);
end if;
when {"GO"}:
symbol := get_symbol(line);
if symbol = "TO" then
exec_goto(symbol, line);
elsif symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("GO", symbol, line);
elsif symbol = ":" and "GO" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: GO");
else
error_marker;
writeln(err, "UNEXPECTED SYMBOL \"GO\".");
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
end if;
when {"GOSUB"}:
exec_gosub(symbol, line);
when {"GOTO"}:
exec_goto(symbol, line);
when {"GR"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("GR", symbol, line);
elsif symbol = ":" and "GR" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: GR");
else
screen(320, 200);
win := open(curr_win, 8);
if curr_win <> PRIMITIVE_WINDOW.value then
clear(curr_win, black);
color(white, black);
scr := open(curr_win);
KEYBOARD := GRAPH_KEYBOARD;
OUT := win;
IN := openEcho(KEYBOARD, OUT);
IN := openLine(IN);
end if;
line_marker;
writeln(log, "GR");
end if;
when {"HGR"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("HGR", symbol, line);
elsif symbol = ":" and "HGR" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: HGR");
else
screen(320, 200);
win := open(curr_win, 8);
if curr_win <> PRIMITIVE_WINDOW.value then
clear(curr_win, black);
color(white, black);
scr := open(curr_win);
KEYBOARD := GRAPH_KEYBOARD;
OUT := win;
IN := openEcho(KEYBOARD, OUT);
IN := openLine(IN);
end if;
line_marker;
writeln(log, "HGR");
end if;
when {"HOME"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("HOME", symbol, line);
elsif symbol = ":" and "HOME" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: HOME");
else
clear(win);
setPos(win, 1, 1);
line_marker;
writeln(log, "HOME");
end if;
when {"HPLOT"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("HPLOT", symbol, line);
elsif symbol = ":" and "HPLOT" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: HPLOT");
else
exec_hplot(symbol, line);
end if;
when {"HTAB"}:
if is_let_statement(line) then
symbol := get_symbol(line);
exec_let("HTAB", symbol, line);
else
symbol := get_symbol(line);
if symbol = ":" and "HTAB" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: HTAB");
else
index1 := line(win);
index2 := round(exec_expr(symbol, line));
setPos(win, index1, index2);
line_marker;
writeln(log, "HTAB " <& index2);
end if;
end if;
when {"IF"}:
exec_if(symbol, line, process_next);
when {"INCR"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("INCR", symbol, line);
elsif symbol = ":" and "INCR" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: INCR");
else
variable_name := get_name(symbol, line);
if symbol = "," then
symbol := get_symbol(line);
num1 := exec_expr(symbol, line);
else
num1 := 1.0;
end if;
setNumericVar(variable_name, getNumericVar(variable_name) + num1);
line_marker;
writeln(log, "INCR " <& variable_name <& " BY " <& num1);
end if;
when {"INP"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("INP", symbol, line);
elsif symbol = ":" and "INP" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: INP");
else
exec_input(symbol, line);
end if;
when {"INPUT", "INPUT#"}:
if symbol = "INPUT#" then
symbol := "#";
else
symbol := get_symbol(line);
end if;
if symbol = "#" then
exec_input_from_file(symbol, line);
else
exec_input(symbol, line);
end if;
when {"INVERSE"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("INVERSE", symbol, line);
elsif symbol = ":" and "INVERSE" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: INVERSE");
else
line_marker;
writeln(log, "**INVERSE");
end if;
when {"KEY"}:
line_marker;
writeln(log, "**KEY " <& line);
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
when {"LINE"}:
symbol := get_symbol(line);
if symbol = "INPUT" or symbol = "INPUT#" then
if symbol = "INPUT#" then
symbol := "#";
else
symbol := get_symbol(line);
end if;
if symbol = "#" then
exec_line_input_from_file(symbol, line);
else
exec_line_input(symbol, line);
end if;
elsif symbol = "(" or symbol = "-" or symbol = "STEP" then
exec_line(symbol, line);
else
expect("INPUT", symbol, line);
end if;
when {"LINPUT"}:
symbol := get_symbol(line);
if symbol = "#" then
exec_linput_from_file(symbol, line);
else
exec_linput(symbol, line);
end if;
when {"LINPUT#"}:
exec_linput_from_file(symbol, line);
when {"LIST"}:
symbol := get_symbol(line);
if symbol <> "" and symbol[1] in digit_char then
index1 := integer(symbol);
symbol := get_symbol(line);
if symbol = "-" then
symbol := get_symbol(line);
if symbol <> "" and symbol[1] in digit_char then
index2 := integer(symbol);
symbol := get_symbol(line);
else
index2 := MAX_LINENUM;
end if;
else
index2 := index1;
end if;
else
index1 := 0;
if symbol = "-" then
symbol := get_symbol(line);
if symbol <> "" and symbol[1] in digit_char then
index2 := integer(symbol);
symbol := get_symbol(line);
else
index2 := MAX_LINENUM;
end if;
else
index2 := MAX_LINENUM;
end if;
end if;
writeln(log, "LIST " <& index1 <& "-" <& index2);
listProg(win, index1, index2);
when {"LOAD"}:
symbol := get_symbol(line);
if isStringExpr(symbol) then
param1 := exec_str_expr(symbol, line, variable_name);
clearProgram;
if runOrChain("LOAD", param1) then
writeln(log, "load program finished");
line_marker;
writeln(log, "LOAD " <& literal(param1) <& " - " <&
length(prg) <& " LINES");
file_line_number := 0;
symbol := "";
line := "";
elsif on_error_label <> "" then
symbol := get_symbol(line);
error_code := 53;
line_marker;
writeln(log, error_code <& " LOAD " <& literal(param1) <&
" - FILE NOT FOUND - ON ERROR GOTO " <& on_error_label);
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "LOAD " <& literal(param1) <& " - FILE NOT FOUND.");
end if;
else
error_marker;
writeln(err, "STRING EXPECTED FOR LOAD - FOUND " <& symbol <& ".");
end if;
when {"LOCATE"}:
symbol := get_symbol(line);
if symbol = "," or endOfStatement(symbol) then
index1 := line(win);
else
index1 := round(exec_expr(symbol, line));
end if;
if symbol = "," then
symbol := get_symbol(line);
end if;
if symbol = "," or endOfStatement(symbol) then
index2 := column(win);
else
index2 := round(exec_expr(symbol, line));
end if;
if symbol = "," then
symbol := get_symbol(line);
end if;
if symbol = "," or endOfStatement(symbol) then
okay := FALSE;
else
okay := TRUE;
num1 := exec_expr(symbol, line);
end if;
if symbol = "," then
symbol := get_symbol(line);
end if;
if symbol <> "," and not endOfStatement(symbol) then
ignore(exec_expr(symbol, line));
end if;
if symbol = "," then
symbol := get_symbol(line);
end if;
if not endOfStatement(symbol) then
ignore(exec_expr(symbol, line));
end if;
setPos(win, index1, index2);
if okay then
if round(num1) = 0 then
cursor(scr, FALSE);
else
cursor(scr, TRUE);
end if;
end if;
line_marker;
write(log, "LOCATE " <& index1 <& ", " <& index2);
if okay then
write(log, ", " <& num1);
end if;
writeln(log);
when {"LOOP"}:
exec_loop(symbol, line);
when {"LPRINT"}:
symbol := get_symbol(line);
exec_print(symbol, line);
when {"LSET"}:
symbol := get_symbol(line);
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
if symbol = "=" then
symbol := get_symbol(line);
param3 := exec_str_expr(symbol, line, unused_name);
index1 := length(getStringVar(variable_name));
if length(param3) <= index1 then
param3 := param3 rpad index1;
else
param3 := param3[.. index1];
end if;
setStringVar(variable_name, param3);
line_marker;
writeln(log, "LSET " <& variable_name <& "=" <& literal(param3));
else
error_marker;
writeln(err, "\"=\" EXPECTED AFTER \"LSET " <& variable_name <&
"\" - FOUND " <& literal(symbol) <& ".");
end if;
else
error_marker;
writeln(err, "STRING VARIABLE EXPECTED AFTER LSET - FOUND " <&
literal(symbol) <& ".");
end if;
when {"MID$"}:
exec_mid_statement(symbol, line);
when {"MID"}:
line_marker;
writeln(log, "ASSUMING A MID$ STATEMENT");
exec_mid_statement(symbol, line);
when {"NEXT"}:
exec_next(symbol, line);
when {"NORMAL"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("NORMAL", symbol, line);
elsif symbol = ":" and "NORMAL" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: NORMAL");
else
line_marker;
writeln(log, "**NORMAL");
end if;
when {"ON"}:
exec_on(symbol, line);
when {"OPEN"}:
exec_open(symbol, line);
when {"OPTION"}:
line_marker;
writeln(log, "OPTION " <& line);
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
when {"OUT"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("OUT", symbol, line);
elsif symbol = ":" and "OUT" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: OUT");
else
symbol := get_symbol(line);
index1 := round(exec_expr(symbol, line));
expect(",", symbol, line);
index2 := round(exec_expr(symbol, line));
line_marker;
writeln(log, "**OUT " <& index1 <& ", " <& index2);
end if;
when {"PAINT"}:
line_marker;
writeln(log, "**PAINT " <& line);
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
when {"PALETTE"}:
line_marker;
writeln(log, "**PALETTE " <& line);
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
when {"PLAY"}:
symbol := get_symbol(line);
line_marker;
writeln(log, "**PLAY " <& line);
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
when {"PLOT"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("PLOT", symbol, line);
elsif symbol = ":" and "PLOT" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: PLOT");
else
exec_plot(symbol, line);
end if;
when {"POKE"}:
symbol := get_symbol(line);
index1 := round(exec_expr(symbol, line));
expect(",", symbol, line);
index2 := round(exec_expr(symbol, line));
line_marker;
writeln(log, "**POKE " <& index1 <& ", " <& index2);
when {"PR", "PR#"}:
if symbol = "PR#" then
symbol := "#";
else
symbol := get_symbol(line);
end if;
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("PR", symbol, line);
elsif symbol = ":" and "PR" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: PR");
elsif symbol = "#" then
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("PR#", symbol, line);
else
index1 := round(exec_expr(symbol, line));
line_marker;
writeln(log, "**PR#" <& index1);
end if;
else
error_marker;
writeln(err, "\"=\" EXPECTED AFTER \"PR\" - FOUND " <&
literal(symbol) <& ".");
end if;
when {"PRESET"}:
exec_preset(symbol, line);
when {"PRI"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("PRI", symbol, line);
elsif symbol = ":" and "PRI" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: PRI");
else
exec_print(symbol, line);
end if;
when {"PRINT", "PRINT#", "?"}:
if symbol = "PRINT#" then
symbol := "#";
else
symbol := get_symbol(line);
end if;
if symbol = "#" then
exec_print_to_file(symbol, line);
else
if symbol = "USING" then
line_marker;
write(log, "PRINT ");
exec_print_using(win, symbol, line);
else
exec_print(symbol, line);
end if;
end if;
when {"PSET"}:
exec_pset(symbol, line);
when {"PUT", "PUT#"}:
if symbol = "PUT#" then
symbol := "#";
else
symbol := get_symbol(line);
end if;
if symbol = "(" or symbol = "STEP" then
exec_put(symbol, line);
else
exec_file_put(symbol, line);
end if;
when {"RANDOMIZE"}:
symbol := get_symbol(line);
if not endOfStatement(symbol) then
num1 := exec_expr(symbol, line);
end if;
line_marker;
writeln(log, "RANDOMIZE");
when {"READ"}:
exec_read(symbol, line);
when {"REDIM"}:
line_marker;
writeln(log, "REDIM " <& line);
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
when {"REM"}:
symbol := "";
line_marker;
writeln(log, "REM " <& line);
when {"RESET"}:
symbol := get_symbol(line);
closeAllFiles;
line_marker;
writeln(log, "RESET");
when {"RESTORE"}:
symbol := get_symbol(line);
if label_or_linenum(symbol) then
data_line_number := label[symbol];
decr(data_line_number);
data_line := "";
line_marker;
writeln(log, "RESTORE " <& symbol);
symbol := get_symbol(line);
else
data_line_number := 0;
data_line := "";
line_marker;
writeln(log, "RESTORE");
end if;
when {"RESUME"}:
symbol := get_symbol(line);
if symbol = "NEXT" then
if in_error_handler then
line_marker;
writeln(log, "RESUME NEXT");
do_resume_next(symbol, line);
if symbol <> "" then
process_next := TRUE;
end if;
elsif on_error_label <> "" then
symbol := get_symbol(line);
error_code := 20;
line_marker;
writeln(log, error_code <& " RESUME NEXT WITHOUT ERROR" <&
" - ON ERROR GOTO " <& on_error_label);
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "RESUME NEXT - NOT IN ERROR HANDLER.");
end if;
elsif label_or_linenum(symbol) then
if in_error_handler then
line_marker;
writeln(log, "RESUME " <& symbol);
goto_label_or_linenum(symbol);
in_error_handler := FALSE;
symbol := "";
line := "";
elsif on_error_label <> "" then
param1 := symbol;
symbol := get_symbol(line);
error_code := 20;
line_marker;
writeln(log, error_code <& " RESUME " <& param1 <& " WITHOUT ERROR" <&
" - ON ERROR GOTO " <& on_error_label);
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "RESUME " <& symbol <& " - NOT IN ERROR HANDLER.");
end if;
elsif symbol = "0" or endOfStatement(symbol) then
if in_error_handler then
do_resume_same(symbol, line);
elsif on_error_label <> "" then
if symbol = "0" then
symbol := get_symbol(line);
end if;
error_code := 20;
line_marker;
writeln(log, error_code <& " RESUME 0 WITHOUT ERROR" <&
" - ON ERROR GOTO " <& on_error_label);
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "RESUME 0 - NOT IN ERROR HANDLER.");
end if;
else
error_marker;
writeln(err, "RESUME " <& symbol <& " - UNDEFINED RESUME.");
end if;
when {"RETURN"}:
if length(gosubReturn) >= 1 then
check_loop_stacks_before_return("RETURN");
line_marker;
write(log, "RETURN FROM \"GOSUB ");
line_marker(gosubReturn[1].subEntryLine);
write(log, "\"");
do_return(symbol, line);
write(log, " AT LINE ");
line_marker;
writeln(log);
elsif on_error_label <> "" then
symbol := get_symbol(line);
error_code := 3;
line_marker;
writeln(log, error_code <& " RETURN WITHOUT GOSUB" <&
" - ON ERROR GOTO " <& on_error_label);
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
symbol := get_symbol(line);
error_marker;
writeln(err, "RETURN WITHOUT GOSUB.");
end if;
when {"RSET"}:
symbol := get_symbol(line);
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
if symbol = "=" then
symbol := get_symbol(line);
param3 := exec_str_expr(symbol, line, unused_name);
index1 := length(getStringVar(variable_name));
if length(param3) <= index1 then
param3 := param3 lpad index1;
else
param3 := param3[.. index1];
end if;
setStringVar(variable_name, param3);
line_marker;
writeln(log, "RSET " <& variable_name <& "=" <& literal(param3));
else
error_marker;
writeln(err, "\"=\" EXPECTED AFTER \"RSET " <& variable_name <&
"\" - FOUND " <& literal(symbol) <& ".");
end if;
else
error_marker;
writeln(err, "STRING VARIABLE EXPECTED AFTER RSET - FOUND " <&
literal(symbol) <& ".");
end if;
when {"RUN"}:
symbol := get_symbol(line);
if isStringExpr(symbol) then
param1 := exec_str_expr(symbol, line, variable_name);
clearProgram;
if runOrChain("RUN", param1) then
writeln(log, "load program finished");
line_marker;
writeln(log, "RUN " <& literal(param1) <& " - " <&
length(prg) <& " LINES");
file_line_number := 0;
symbol := "";
line := "";
elsif on_error_label <> "" then
symbol := get_symbol(line);
error_code := 53;
line_marker;
writeln(log, error_code <& " RUN " <& literal(param1) <&
" - FILE NOT FOUND - ON ERROR GOTO " <& on_error_label);
goto_on_error(on_error_label, line);
symbol := "";
line := "";
else
error_marker;
writeln(err, "RUN " <& literal(param1) <& " - FILE NOT FOUND.");
end if;
elsif label_or_linenum(symbol) then
clearProgram;
line_marker;
writeln(log, "RUN " <& symbol);
goto_label_or_linenum(symbol);
symbol := "";
line := "";
else
clearProgram;
line_marker;
writeln(log, "RUN");
file_line_number := 0;
symbol := "";
line := "";
end if;
when {"SCREEN"}:
exec_screen(symbol, line);
when {"SEEK", "SEEK#"}:
exec_seek(symbol, line);
when {"SELECT"}:
exec_select(symbol, line);
when {"SHARED"}:
line_marker;
writeln(log, "SHARED " <& line);
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
when {"SLEEP"}:
symbol := get_symbol(line);
if endOfStatement(symbol) then
index1 := 1;
else
index1 := round(exec_expr(symbol, line));
end if;
flush(win);
sleep(index1);
line_marker;
writeln(log, "SLEEP " <& index1);
when {"SOUND"}:
symbol := get_symbol(line);
num1 := exec_expr(symbol, line);
expect(",", symbol, line);
num2 := exec_expr(symbol, line);
line_marker;
writeln(log, "**SOUND " <& symbol);
when {"STOP", "SYSTEM"}:
line_marker;
writeln(log, symbol);
symbol := "";
running := FALSE;
when {"SWAP"}:
symbol := get_symbol(line);
if isStringVar(symbol) then
variable_name := get_name(symbol, line);
expect(",", symbol, line);
if isStringVar(symbol) then
variable2_name := get_name(symbol, line);
param1 := getStringVar(variable_name);
param2 := getStringVar(variable2_name);
setStringVar(variable_name, param2);
setStringVar(variable2_name, param1);
else
error_marker;
writeln(err, "STRING VARIABLE EXPECTED - FOUND " <& literal(symbol) <& ".");
end if;
elsif isNumericVar(symbol) then
variable_name := get_name(symbol, line);
expect(",", symbol, line);
if isNumericVar(symbol) then
variable2_name := get_name(symbol, line);
num1 := getNumericVar(variable_name);
num2 := getNumericVar(variable2_name);
setNumericVar(variable_name, num2);
setNumericVar(variable2_name, num1);
else
error_marker;
writeln(err, "NUMERIC VARIABLE EXPECTED - FOUND " <& literal(symbol) <& ".");
end if;
else
error_marker;
writeln(err, "VARIABLE EXPECTED - FOUND " <& literal(symbol) <& ".");
end if;
when {"SUB"}:
symbol := get_symbol(line);
line_marker;
writeln(log, "SKIP SUB " <& symbol);
symbol := find_end_sub(line);
symbol := get_symbol(line);
line_marker;
writeln(log, "END SKIP SUB " <& symbol <& " " <& line);
when {"TEXT"}:
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let("TEXT", symbol, line);
elsif symbol = ":" and "TEXT" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: TEXT");
else
scr := open(CONSOLE);
win := openWindow(scr, 1, 1, TEXT_LINES, TEXT_COLUMNS);
KEYBOARD := CONSOLE_KEYBOARD;
OUT := win;
IN := openEcho(KEYBOARD, OUT);
IN := openLine(IN);
line_marker;
writeln(log, "TEXT");
end if;
when {"TYPE"}:
exec_type(symbol, line);
when {"VTAB"}:
if is_let_statement(line) then
symbol := get_symbol(line);
exec_let("VTAB", symbol, line);
else
symbol := get_symbol(line);
if symbol = ":" and "VTAB" in usedLabel then
line_marker;
writeln(log, "SKIP LABEL: VTAB");
else
index1 := round(exec_expr(symbol, line));
index2 := column(win);
setPos(win, index1, index2);
line_marker;
writeln(log, "VTAB " <& index1);
end if;
end if;
when {"WAIT"}:
symbol := get_symbol(line);
index1 := round(exec_expr(symbol, line));
expect(",", symbol, line);
index2 := round(exec_expr(symbol, line));
if symbol = "," then
symbol := get_symbol(line);
index3 := round(exec_expr(symbol, line));
else
index3 := 0;
end if;
line_marker;
case index1 of
when {16#3DA}:
writeln(log, "WAIT " <& index1 <& ", " <& index2 <& ", " <& index3 <&
" - Wait for vertical retrace");
otherwise:
writeln(log, "**WAIT " <& index1 <& ", " <& index2 <& ", " <& index3);
end case;
when {"WEND"}:
if length(whileLoop) >= 1 then
index1 := whileLoop[1].condLine;
param2 := prg[index1].line[whileLoop[1].condColumn .. ];
param1 := get_symbol(param2);
num1 := exec_expr(param1, param2);
if num1 <> 0.0 then
line_marker;
file_line_number := index1;
statement_label := prg[file_line_number].linenum;
symbol := param1;
line := param2;
writeln(log, "WEND - CONTINUE WHILE");
else
symbol := get_symbol(line);
whileLoop := whileLoop[2 .. ];
line_marker;
writeln(log, "WEND - END WHILE");
end if;
else
error_marker;
writeln(err, "UNEXPECTED \"WEND\"");
end if;
when {"WHILE"}:
index1 := file_line_number;
index2 := length(prg[file_line_number].line) - length(line) + 1;
symbol := get_symbol(line);
num1 := exec_expr(symbol, line);
line_marker;
writeln(log, "WHILE " <& num1);
if num1 <> 0.0 then
whileLoop := [] (whileLoopDescrType.value) & whileLoop;
whileLoop[1].condLine := index1;
whileLoop[1].condColumn := index2;
else
line_marker;
writeln(log, "EMPTY WHILE");
if symbol <> "WEND" then
param1 := statement_label;
symbol := find_wend(line);
end if;
if symbol = "WEND" then
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
line_marker;
writeln(log, "CONTINUE AFTER WEND");
else
error_marker(param1);
writeln(err, "NO CORRESPONDING \"WEND\" FOUND FOR \"WHILE\"");
end if;
end if;
when {"WIDTH"}:
line_marker;
writeln(log, "**WIDTH " <& line);
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
when {"WRITE", "WRITE#"}:
if symbol = "WRITE#" then
symbol := "#";
else
symbol := get_symbol(line);
end if;
if symbol = "#" then
exec_write_to_file(symbol, line);
else
exec_write(symbol, line);
end if;
when {"'"}:
symbol := "";
line_marker;
writeln(log, "'" <& line);
when {"%"}:
variable_name := "";
repeat
variable_name &:= symbol;
symbol := get_symbol(line);
if symbol <> "" and symbol[1] in alphanum_char then
variable_name &:= symbol;
symbol := get_symbol(line);
end if;
until symbol <> "_";
append_index(variable_name, symbol, line);
if symbol = "=" then
symbol := get_symbol(line);
num1 := exec_expr(symbol, line);
setNumericVar(variable_name, num1);
line_marker;
writeln(log, variable_name <& "=" <& num1);
else
error_marker;
writeln(err, "\"=\" EXPECTED AFTER " <& literal(variable_name) <&
" - FOUND " <& literal(symbol) <& ".");
end if;
when {":"}:
error_marker;
writeln(err, "UNEXPECTED \":\" - IGNORED.");
otherwise:
if symbol in subprogram then
line_marker;
writeln(log, "CALL " <& symbol);
advance_after_statement(line);
set_return_position(line);
gosubReturn[1].subName := symbol;
file_line_number := subprogram[symbol];
statement_label := prg[file_line_number].label;
line := prg[file_line_number].line;
symbol := get_symbol(line);
symbol := get_symbol(line);
set_sub_entry_position;
line_marker;
writeln(log, "EXECUTE SUB " <& symbol);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
elsif symbol in sub_declared then
error_marker;
writeln(err, "CALL DECLARED BUT UNDEFINED SUB " <& symbol);
while not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
elsif symbol in usedLabel then
param1 := symbol;
symbol := get_symbol(line);
if symbol = "=" or symbol = "(" or symbol = "[" then
exec_let(param1, symbol, line);
elsif symbol = ":" then
line_marker;
writeln(log, "SKIP LABEL: " <& param1);
else
error_marker;
writeln(err, "COLON EXPECTED AFTER LABEL " <& param1 <&
" - FOUND " <& literal(symbol) <& ".");
end if;
else
exec_let(symbol, line, process_next);
end if;
end case;
if symbol = ":" then
symbol := get_symbol(line);
if symbol = ":" then
symbol := get_symbol(line);
end if;
process_next := TRUE;
end if;
until not process_next;
if symbol = "REM" then
line_marker;
writeln(log, "REM " <& line);
elsif symbol = "'" then
line_marker;
writeln(log, "'" <& line);
elsif symbol = "ELSE" then
line_marker;
writeln(log, "SKIP ELSE PART - CONTINUE AT NEXT LINE");
elsif symbol <> "" then
error_marker;
writeln(err, "UNEXPECTED SYMBOL " <& literal(symbol) <& ".");
repeat
symbol := get_symbol(line);
until endOfStatement(symbol);
if symbol = ":" then
symbol := get_symbol(line);
running := execCmd(symbol, line);
end if;
end if;
end func;
const proc: execLines is func
local
var boolean: running is TRUE;
var string: symbol is "";
var string: line is "";
begin
while running do
if file_line_number > length(prg) then
writeln(log, "END OF PROGRAM REACHED");
running := FALSE;
elsif prg[file_line_number].line <> "" then
statement_label := prg[file_line_number].linenum;
line := prg[file_line_number].line;
symbol := get_symbol(line);
running := execCmd(symbol, line);
end if;
incr(file_line_number);
end while;
end func;
const proc: runProg is func
begin
file_line_number := 1;
execLines;
end func;
const proc: logLine (in lineType: aLine) is func
begin
if aLine.linenum <> "" then
write(log, aLine.linenum lpad 5 <& " ");
else
write(log, "" lpad 5 <& " ");
end if;
writeln(log, aLine.line);
end func;
const proc: prepareLoops is func
local
var boolean: processing is TRUE;
var string: symbol is "";
var string: line is "";
var string: headLabel is "";
var integer: headLine is 0;
var integer: headColumn is 0;
var integer: tailLine is 0;
var integer: tailColumn is 0;
var string: variable_name is "";
begin
file_line_number := 1;
while processing do
if file_line_number > length(prg) then
processing := FALSE;
elsif prg[file_line_number].line <> "" then
statement_label := prg[file_line_number].linenum;
line := prg[file_line_number].line;
repeat
symbol := get_symbol(line);
if symbol = "DO" then
headLabel := statement_label;
headLine := file_line_number;
headColumn := length(prg[file_line_number].line) - length(line) + 1;
symbol := find_loop(line);
if symbol = "LOOP" then
tailLine := file_line_number;
tailColumn := length(prg[file_line_number].line) - length(line) + 1;
addDoLoopHeader(tailLine, tailColumn, headLine, headColumn);
file_line_number := headLine;
line := prg[file_line_number].line[headColumn .. ];
symbol := get_symbol(line);
else
file_line_number := headLine;
line := prg[file_line_number].line[headColumn .. ];
symbol := get_symbol(line);
if symbol <> "=" then
error_marker(headLabel);
writeln(err, "DO - NO STATICALLY CORRESPONDING \"LOOP\" STATEMENT FOUND ");
end if;
end if;
elsif symbol = "LOOP" then
tailLine := file_line_number;
tailColumn := length(prg[file_line_number].line) - length(line) + 1;
if not doLoopHeaderPresent(tailLine, tailColumn, headLine, headColumn) then
error_marker;
writeln(err, "LOOP - NO STATICALLY CORRESPONDING \"DO\" STATEMENT FOUND");
end if;
elsif ignoreRestOfLine(symbol) then
line := "";
symbol := "";
end if;
while symbol <> "THEN" and not endOfStatement(symbol) do
symbol := get_symbol(line);
end while;
if ignoreRestOfLine(symbol) then
line := "";
symbol := "";
end if;
until symbol = "";
end if;
incr(file_line_number);
end while;
file_line_number := 1;
end func;
const proc: preprocessLine (in var string: line) is func
local
var string: symbol is "";
var string: label is "";
begin
symbol := get_symbol(line);
while symbol <> "" do
if symbol = "GOTO" or symbol = "GOSUB" or
symbol = "THEN" or symbol = "ELSE" or
symbol = "RESTORE" or symbol = "RUN" then
label := get_symbol(line);
symbol := get_symbol(line);
if endOfStatement(symbol) and
label not in not_allowed_as_label and
label <> "" and label[1] in letter_char then
incl(usedLabel, label);
end if;
elsif symbol = "REM" or symbol = "'" then
symbol := "";
else
symbol := get_symbol(line);
end if;
if symbol = ":" then
symbol := get_symbol(line);
incl(usedAsStatement, symbol);
end if;
end while;
end func;
const proc: checkLabels is func
local
var string: aLabel is "";
var integer: number is 0;
var boolean: first is TRUE;
begin
for key aLabel range multipleDefinedLabel do
if aLabel in usedLabel then
write(err, " ***** LABEL " <& aLabel <&
" DEFINED IN MULTIPLE LINES: ");
for number range multipleDefinedLabel[aLabel] do
if first then
first := FALSE;
else
write(log, ", ");
end if;
if number <= length(prg) and prg[number].linenum <> "" then
write(err, prg[number].linenum);
else
write(err, "(" <& number <& ")");
end if;
end for;
writeln(err);
end if;
end for;
for key aLabel range subprogram do
excl(usedLabel, aLabel);
end for;
usedLabel := usedLabel - usedAsStatement;
for aLabel range usedAsStatement do
excl(label, aLabel);
end for;
for aLabel range usedLabel do
if aLabel not in label then
if aLabel in multipleDefinedLabel then
writeln(err, " ***** LABEL " <& aLabel <&
" USED BUT DEFINED MULTIPLE TIMES.");
else
writeln(err, " ***** LABEL " <& aLabel <&
" USED BUT NOT DEFINED.");
end if;
end if;
end for;
end func;
const func boolean: loadProg (in string: name) is forward;
const proc: loadProg (in string: name, inout file: infile) is func
local
var integer: file_line_number is 0;
var string: symbol is "";
var string: line_number is "";
var string: line_label is "";
var string: line is "";
var string: help_line is "";
var string: variable_name is "";
var boolean: control_z is FALSE;
var boolean: continuation_line is FALSE;
var integer: number is 1;
var integer: line_number_incr is 1;
begin
repeat
line := getln(infile);
for number range 1 to pred(line_number_incr) do
prg &:= [] (lineType.value);
writeln(log);
end for;
file_line_number +:= line_number_incr;
line_number_incr := 1;
repeat
if pos(line, "\Z") <> 0 then
line := line[.. pred(pos(line, "\Z"))];
control_z := TRUE;
end if;
line := trim(line);
if length(line) >= 2 and line[pred(length(line)) ..] = " _" then
continuation_line := TRUE;
line := line[.. pred(length(line))] & getln(infile);
incr(line_number_incr);
else
continuation_line := FALSE;
end if;
until not continuation_line;
if line <> "" then
if line[1] in digit_char then
line_number := getDigits(line);
if line <> "" and line[1] = '.' then
line_number &:= ".";
line := line[2 .. ];
line_number &:= getDigits(line);
end if;
while line <> "" and line[1] = ' ' do
line := line[2 .. ];
end while;
if line_number in label then
writeln(err, " ***** LINE NUMBER " <& line_number <&
" ALREADY DEFINED AS " <& name <&
"(" <& label[line_number] <& ")");
else
label @:= [line_number] succ(length(prg));
end if;
else
line_number := "";
end if;
help_line := line;
symbol := get_symbol(help_line);
if symbol = "'" or symbol = "REM" then
repeat
symbol := get_symbol(help_line);
until symbol = "" or symbol = "$";
symbol := get_symbol(help_line);
if symbol = "INCLUDE" then
symbol := get_symbol(help_line);
if symbol = ":" then
symbol := get_symbol(help_line);
if symbol = "'" then
symbol := help_line[.. pred(pos(help_line, '\''))];
if symbol <> "" then
prg &:= [] (lineType.value);
prg[length(prg)].fileName := name;
prg[length(prg)].fileLine := file_line_number;
prg[length(prg)].linenum := line_number;
prg[length(prg)].label := line_label;
prg[length(prg)].line := line;
logLine(prg[length(prg)]);
if not loadProg(symbol) then
writeln(err, " ***** INCLUDE FILE " <& literal(symbol) <&
" NOT FOUND.");
end if;
writeln(log, "---------- END INCLUDE ----------");
end if;
end if;
end if;
end if;
elsif symbol = "#" or symbol = "$" then
symbol := get_symbol(help_line);
if symbol = "INCLUDE" then
symbol := get_symbol(help_line);
if symbol <> "" and symbol[1] = '"' then
symbol := symbol[2 ..];
prg &:= [] (lineType.value);
prg[length(prg)].fileName := name;
prg[length(prg)].fileLine := file_line_number;
prg[length(prg)].linenum := line_number;
prg[length(prg)].label := line_label;
prg[length(prg)].line := line;
logLine(prg[length(prg)]);
if not loadProg(symbol) then
writeln(err, " ***** INCLUDE FILE " <& literal(symbol) <&
" NOT FOUND.");
end if;
writeln(log, "---------- END INCLUDE ----------");
end if;
end if;
elsif symbol = "SUB" then
symbol := get_symbol(help_line);
if symbol in subprogram then
writeln(err, " ***** SUB " <& symbol <&
" ALREADY DEFINED AS " <& name <&
"(" <& subprogram[symbol] <& ")");
else
subprogram @:= [symbol] succ(length(prg));
end if;
line_label := "";
elsif symbol = "FUNCTION" then
symbol := get_symbol(help_line);
if symbol in subfunction then
writeln(err, " ***** FUNCTION " <& symbol <&
" ALREADY DEFINED AS " <& name <&
"(" <& subfunction[symbol] <& ")");
else
subfunction @:= [symbol] succ(length(prg));
end if;
line_label := "";
elsif symbol = "" or symbol in not_allowed_as_label or
symbol in sub_declared then
line_label := "";
elsif startsWith(symbol, "NEXT") and length(symbol) = 5 and
symbol[5] in letter_char then
line_label := "";
elsif startsWith(symbol, "READ") and length(symbol) = 5 and
symbol[5] in letter_char then
line_label := "";
elsif startsWith(symbol, "GOTO") and isDigitString(symbol[5 ..]) or
startsWith(symbol, "GOSUB") and isDigitString(symbol[6 ..]) then
line_label := "";
else
line_label := symbol;
symbol := get_symbol(help_line);
if line_label[1] in letter_char and symbol = ":" then
if line_label in multipleDefinedLabel then
multipleDefinedLabel[line_label] &:= succ(length(prg));
line_label := "";
elsif line_label in label then
multipleDefinedLabel @:= [line_label] [] (label[line_label], succ(length(prg)));
excl(label, line_label);
line_label := "";
else
label @:= [line_label] succ(length(prg));
end if;
else
line_label := "";
end if;
end if;
preprocessLine(line);
prg &:= [] (lineType.value);
prg[length(prg)].fileName := name;
prg[length(prg)].fileLine := file_line_number;
prg[length(prg)].linenum := line_number;
prg[length(prg)].label := line_label;
prg[length(prg)].line := line;
logLine(prg[length(prg)]);
else
prg &:= [] (lineType.value);
writeln(log);
end if;
until eof(infile) or control_z;
checkLabels;
if length(label) <> 0 then
writeln(log, "Labels:");
for number key line_label range label do
if line_label[1] not in digit_char then
write(log, line_label <& ": ");
if number <= length(prg) then
if prg[number].linenum <> "" then
write(log, prg[number].linenum);
else
if prg[number].fileName <> prg[1].fileName then
write(log, prg[number].fileName);
end if;
write(log, "(" <& prg[number].fileLine <& ")");
end if;
end if;
writeln(log);
end if;
end for;
end if;
writeln(log, "usedLabels: " <& usedLabel);
end func;
const func boolean: runOrChain (in string: cmd, in string: name) is func
result
var boolean: successful is FALSE;
local
var file: infile is STD_NULL;
begin
if lower(name[length(name) - 3 ..]) <> ".bas" then
infile := basicOpen(name & ".bas", "r");
end if;
if infile = STD_NULL then
infile := basicOpen(name, "r");
end if;
if infile <> STD_NULL then
line_marker;
writeln(log, cmd <& " " <& literal(name));
prg := 0 times lineType.value;
label := label_hash.EMPTY_HASH;
subprogram := label_hash.EMPTY_HASH;
subfunction := label_hash.EMPTY_HASH;
sub_declared := label_hash.EMPTY_HASH;
usedLabel := stringSet.value;
usedAsStatement := stringSet.value;
multipleDefinedLabel := multipleDefinedType.value;
loadProg(name, infile);
prepareLoops;
close(infile);
successful := TRUE;
end if;
end func;
const func boolean: loadProg (in string: name) is func
result
var boolean: successful is FALSE;
local
var file: infile is STD_NULL;
begin
if lower(name[length(name) - 3 ..]) <> ".bas" then
infile := basicOpen(name & ".bas", "r");
end if;
if infile = STD_NULL then
infile := basicOpen(name, "r");
end if;
if infile <> STD_NULL then
loadProg(name, infile);
close(infile);
successful := TRUE;
end if;
end func;
const proc: interactiveMode is func
local
var file: commandFile is STD_NULL;
var string: symbol is "";
var string: line is "";
var boolean: running is TRUE;
begin
scr := open(CONSOLE);
cursor(scr, TRUE);
win := openWindow(scr, 1, 1, TEXT_LINES, TEXT_COLUMNS);
OUT := win;
IN := openEcho(KEYBOARD, OUT);
IN := openLine(IN);
err := OUT;
commandFile := openEditLine(KEYBOARD, OUT);
writeln("Type END to exit direct mode.");
repeat
write("] ");
readln(commandFile, line);
symbol := get_symbol(line);
running := execCmd(symbol, line);
until not running;
end func;
const proc: main is func
local
var array string: arg_v is 0 times "";
var integer: argumentIndex is 1;
var boolean: doPauseAtEnd is FALSE;
var boolean: doLog is FALSE;
var boolean: interactive is FALSE;
begin
arg_v := argv(PROGRAM);
if length(arg_v) >= 1 then
while argumentIndex <= length(arg_v) and
startsWith(arg_v[argumentIndex], "-") do
if arg_v[argumentIndex] = "-p" then
doPauseAtEnd := TRUE;
elsif arg_v[argumentIndex] = "-l" then
doLog := TRUE;
elsif arg_v[argumentIndex] = "-i" then
interactive := TRUE;
else
writeln(" ***** Unknown option " <& arg_v[argumentIndex]);
end if;
incr(argumentIndex);
end while;
if argumentIndex <= length(arg_v) then
if succ(argumentIndex) <= length(arg_v) then
command_line := join(arg_v[succ(argumentIndex) ..], " ");
end if;
err := open("bas7.log", "w");
if err = STD_NULL then
writeln(" ***** Could not open log file.");
else
err := openLine(err);
end if;
if doLog then
log := err;
end if;
if loadProg(arg_v[argumentIndex]) then
writeln(log, "load program finished");
prepareLoops;
scr := open(CONSOLE);
cursor(scr, TRUE);
win := openWindow(scr, 1, 1, TEXT_LINES, TEXT_COLUMNS);
OUT := win;
IN := openEcho(KEYBOARD, OUT);
IN := openLine(IN);
runProg;
if doPauseAtEnd then
writeln("=== Program finished ===");
write("Press return to continue ");
readln(KEYBOARD);
end if;
else
writeln(" ***** File " <& literal(arg_v[argumentIndex]) <&
" not found.");
end if;
elsif interactive then
interactiveMode;
else
writeln(" ***** File name missing");
end if;
else
writeln("Bas7 Version 1.0 - Basic interpreter");
writeln("Copyright (C) 1994, 2001, 2004 - 2010, 2013, 2016 - 2020 Thomas Mertes");
writeln("This is free software; see the source for copying conditions. There is NO");
writeln("warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.");
writeln("Bas7 is written in the Seed7 programming language");
writeln("Homepage: http://seed7.sourceforge.net");
writeln;
writeln("usage: bas7 [options] basic_program");
writeln;
writeln("options: -p Ask for a prompt at the end of the program");
writeln(" -l List program and write log of executed statements");
end if;
end func;